mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2026-01-06 20:35:30 +01:00
22724 lines
602 KiB
ObjectPascal
22724 lines
602 KiB
ObjectPascal
{
|
|
This file is part of the Free Component Library (FCL)
|
|
Copyright (c) 2018 by Michael Van Canneyt
|
|
|
|
Unit tests for Pascal-to-Javascript converter class.
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************
|
|
|
|
Examples:
|
|
./testpas2js --suite=TTestModule.TestEmptyProgram
|
|
./testpas2js --suite=TTestModule.TestEmptyUnit
|
|
}
|
|
unit tcmodules;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, fpcunit, testregistry, contnrs,
|
|
jstree, jswriter, jsbase,
|
|
PasTree, PScanner, PasResolver, PParser, PasResolveEval,
|
|
FPPas2Js;
|
|
|
|
const
|
|
// default parser+scanner options
|
|
po_tcmodules = po_Pas2js+[po_KeepScannerError];
|
|
co_tcmodules = [coNoTypeInfo];
|
|
type
|
|
TSrcMarkerKind = (
|
|
mkLabel,
|
|
mkResolverReference,
|
|
mkDirectReference
|
|
);
|
|
PSrcMarker = ^TSrcMarker;
|
|
TSrcMarker = record
|
|
Kind: TSrcMarkerKind;
|
|
Filename: string;
|
|
Row: integer;
|
|
StartCol, EndCol: integer; // token start, end column
|
|
Identifier: string;
|
|
Next: PSrcMarker;
|
|
end;
|
|
|
|
{ TTestHintMessage }
|
|
|
|
TTestHintMessage = class
|
|
public
|
|
Id: int64;
|
|
MsgType: TMessageType;
|
|
MsgNumber: integer;
|
|
Msg: string;
|
|
SourcePos: TPasSourcePos;
|
|
end;
|
|
|
|
{ TTestPasParser }
|
|
|
|
TTestPasParser = Class(TPasParser)
|
|
end;
|
|
|
|
TOnFindUnit = function(const aUnitName: String): TPasModule of object;
|
|
|
|
{ TTestEnginePasResolver }
|
|
|
|
TTestEnginePasResolver = class(TPas2JsResolver)
|
|
private
|
|
FFilename: string;
|
|
FModule: TPasModule;
|
|
FOnFindUnit: TOnFindUnit;
|
|
FParser: TTestPasParser;
|
|
FStreamResolver: TStreamResolver;
|
|
FScanner: TPas2jsPasScanner;
|
|
FSource: string;
|
|
public
|
|
destructor Destroy; override;
|
|
function FindUnit(const AName, InFilename: String; NameExpr,
|
|
InFileExpr: TPasExpr): TPasModule; override;
|
|
procedure UsedInterfacesFinished(Section: TPasSection); override;
|
|
property OnFindUnit: TOnFindUnit read FOnFindUnit write FOnFindUnit;
|
|
property Filename: string read FFilename write FFilename;
|
|
property StreamResolver: TStreamResolver read FStreamResolver write FStreamResolver;
|
|
property Scanner: TPas2jsPasScanner read FScanner write FScanner;
|
|
property Parser: TTestPasParser read FParser write FParser;
|
|
property Source: string read FSource write FSource;
|
|
property Module: TPasModule read FModule;
|
|
end;
|
|
|
|
{ TCustomTestModule }
|
|
|
|
TCustomTestModule = Class(TTestCase)
|
|
private
|
|
FConverter: TPasToJSConverter;
|
|
FEngine: TTestEnginePasResolver;
|
|
FExpectedErrorClass: ExceptClass;
|
|
FExpectedErrorMsg: string;
|
|
FExpectedErrorNumber: integer;
|
|
FFilename: string;
|
|
FFileResolver: TStreamResolver;
|
|
FJSImplementationSrc: TJSSourceElements;
|
|
FJSImplementationUses: TJSArrayLiteral;
|
|
FJSInitBody: TJSFunctionBody;
|
|
FJSImplentationUses: TJSArrayLiteral;
|
|
FJSInterfaceUses: TJSArrayLiteral;
|
|
FJSModule: TJSSourceElements;
|
|
FJSModuleSrc: TJSSourceElements;
|
|
FJSSource: TStringList;
|
|
FModule: TPasModule;
|
|
FJSModuleCallArgs: TJSArguments;
|
|
FModules: TObjectList;// list of TTestEnginePasResolver
|
|
FParser: TTestPasParser;
|
|
FPasProgram: TPasProgram;
|
|
FHintMsgs: TObjectList; // list of TTestHintMessage
|
|
FHintMsgsGood: TFPList; // list of TTestHintMessage marked as expected
|
|
FJSRegModuleCall: TJSCallExpression;
|
|
FScanner: TPas2jsPasScanner;
|
|
FSkipTests: boolean;
|
|
FSource: TStringList;
|
|
FFirstPasStatement: TPasImplBlock;
|
|
{$IFDEF EnablePasTreeGlobalRefCount}
|
|
FElementRefCountAtSetup: int64;
|
|
{$ENDIF}
|
|
function GetMsgCount: integer;
|
|
function GetMsgs(Index: integer): TTestHintMessage;
|
|
function GetResolverCount: integer;
|
|
function GetResolvers(Index: integer): TTestEnginePasResolver;
|
|
function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
|
|
procedure OnParserLog(Sender: TObject; const Msg: String);
|
|
procedure OnPasResolverLog(Sender: TObject; const Msg: String);
|
|
procedure OnScannerLog(Sender: TObject; const Msg: String);
|
|
protected
|
|
procedure SetUp; override;
|
|
function CreateConverter: TPasToJSConverter; virtual;
|
|
function LoadUnit(const aUnitName: String): TPasModule;
|
|
procedure InitScanner(aScanner: TPas2jsPasScanner); virtual;
|
|
procedure TearDown; override;
|
|
Procedure Add(Line: string); virtual;
|
|
Procedure Add(const Lines: array of string);
|
|
Procedure StartParsing; virtual;
|
|
procedure ParseModuleQueue; virtual;
|
|
procedure ParseModule; virtual;
|
|
procedure ParseProgram; virtual;
|
|
procedure ParseUnit; virtual;
|
|
protected
|
|
function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; virtual;
|
|
function AddModule(aFilename: string): TTestEnginePasResolver; virtual;
|
|
function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; virtual;
|
|
function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
|
|
ImplementationSrc: string): TTestEnginePasResolver; virtual;
|
|
procedure AddSystemUnit; virtual;
|
|
procedure StartProgram(NeedSystemUnit: boolean); virtual;
|
|
procedure StartUnit(NeedSystemUnit: boolean); virtual;
|
|
procedure ConvertModule; virtual;
|
|
procedure ConvertProgram; virtual;
|
|
procedure ConvertUnit; virtual;
|
|
function ConvertJSModuleToString(El: TJSElement): string; virtual;
|
|
procedure CheckDottedIdentifier(Msg: string; El: TJSElement; DottedName: string);
|
|
function GetDottedIdentifier(El: TJSElement): string;
|
|
procedure CheckSource(Msg,Statements: String; InitStatements: string = '';
|
|
ImplStatements: string = ''); virtual;
|
|
procedure CheckDiff(Msg, Expected, Actual: string); virtual;
|
|
procedure CheckUnit(Filename, ExpectedSrc: string); virtual;
|
|
procedure CheckHint(MsgType: TMessageType; MsgNumber: integer;
|
|
Msg: string; Marker: PSrcMarker = nil); virtual;
|
|
procedure CheckResolverUnexpectedHints(WithSourcePos: boolean = false); virtual;
|
|
procedure SetExpectedScannerError(Msg: string; MsgNumber: integer);
|
|
procedure SetExpectedParserError(Msg: string; MsgNumber: integer);
|
|
procedure SetExpectedPasResolverError(Msg: string; MsgNumber: integer);
|
|
procedure SetExpectedConverterError(Msg: string; MsgNumber: integer);
|
|
function IsErrorExpected(E: Exception): boolean;
|
|
procedure HandleScannerError(E: EScannerError);
|
|
procedure HandleParserError(E: EParserError);
|
|
procedure HandlePasResolveError(E: EPasResolve);
|
|
procedure HandlePas2JSError(E: EPas2JS);
|
|
procedure HandleException(E: Exception);
|
|
procedure FailException(E: Exception);
|
|
procedure WriteSources(const aFilename: string; aRow, aCol: integer);
|
|
function IndexOfResolver(const Filename: string): integer;
|
|
function GetResolver(const Filename: string): TTestEnginePasResolver;
|
|
function GetDefaultNamespace: string;
|
|
property PasProgram: TPasProgram Read FPasProgram;
|
|
property Resolvers[Index: integer]: TTestEnginePasResolver read GetResolvers;
|
|
property ResolverCount: integer read GetResolverCount;
|
|
property Engine: TTestEnginePasResolver read FEngine;
|
|
property Filename: string read FFilename;
|
|
Property Module: TPasModule Read FModule;
|
|
property FirstPasStatement: TPasImplBlock read FFirstPasStatement;
|
|
property Converter: TPasToJSConverter read FConverter;
|
|
property JSSource: TStringList read FJSSource;
|
|
property JSModule: TJSSourceElements read FJSModule;
|
|
property JSRegModuleCall: TJSCallExpression read FJSRegModuleCall;
|
|
property JSModuleCallArgs: TJSArguments read FJSModuleCallArgs;
|
|
property JSImplementationUses: TJSArrayLiteral read FJSImplementationUses;
|
|
property JSInterfaceUses: TJSArrayLiteral read FJSInterfaceUses;
|
|
property JSModuleSrc: TJSSourceElements read FJSModuleSrc;
|
|
property JSInitBody: TJSFunctionBody read FJSInitBody;
|
|
property JSImplementationSrc: TJSSourceElements read FJSImplementationSrc;
|
|
property ExpectedErrorClass: ExceptClass read FExpectedErrorClass write FExpectedErrorClass;
|
|
property ExpectedErrorMsg: string read FExpectedErrorMsg write FExpectedErrorMsg;
|
|
property ExpectedErrorNumber: integer read FExpectedErrorNumber write FExpectedErrorNumber;
|
|
property SkipTests: boolean read FSkipTests write FSkipTests;
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
property Source: TStringList read FSource;
|
|
property FileResolver: TStreamResolver read FFileResolver;
|
|
property Scanner: TPas2jsPasScanner read FScanner;
|
|
property Parser: TTestPasParser read FParser;
|
|
property MsgCount: integer read GetMsgCount;
|
|
property Msgs[Index: integer]: TTestHintMessage read GetMsgs;
|
|
end;
|
|
|
|
{ TTestModule }
|
|
|
|
TTestModule = class(TCustomTestModule)
|
|
Published
|
|
// program/units
|
|
Procedure TestEmptyProgram;
|
|
Procedure TestEmptyProgramUseStrict;
|
|
Procedure TestEmptyUnit;
|
|
Procedure TestEmptyUnitUseStrict;
|
|
Procedure TestDottedUnitNames;
|
|
Procedure TestDottedUnitNameImpl;
|
|
Procedure TestDottedUnitExpr;
|
|
Procedure Test_ModeFPCFail;
|
|
Procedure Test_ModeSwitchCBlocksFail;
|
|
Procedure TestUnit_UseSystem;
|
|
Procedure TestUnit_Intf1Impl2Intf1;
|
|
Procedure TestIncludeVersion;
|
|
|
|
// vars/const
|
|
Procedure TestVarInt;
|
|
Procedure TestVarBaseTypes;
|
|
Procedure TestBaseTypeSingleFail;
|
|
Procedure TestBaseTypeExtendedFail;
|
|
Procedure TestConstBaseTypes;
|
|
Procedure TestUnitImplVars;
|
|
Procedure TestUnitImplConsts;
|
|
Procedure TestUnitImplRecord;
|
|
Procedure TestRenameJSNameConflict;
|
|
Procedure TestLocalConst;
|
|
Procedure TestVarExternal;
|
|
Procedure TestVarExternalOtherUnit;
|
|
Procedure TestVarAbsoluteFail;
|
|
Procedure TestConstExternal;
|
|
|
|
// numbers
|
|
Procedure TestDouble;
|
|
Procedure TestInteger;
|
|
Procedure TestIntegerRange;
|
|
Procedure TestIntegerTypecasts;
|
|
Procedure TestCurrency;
|
|
Procedure TestForBoolDo;
|
|
Procedure TestForIntDo;
|
|
Procedure TestForIntInDo;
|
|
|
|
// strings
|
|
Procedure TestCharConst;
|
|
Procedure TestChar_Compare;
|
|
Procedure TestChar_BuiltInProcs;
|
|
Procedure TestStringConst;
|
|
Procedure TestStringConstSurrogate;
|
|
Procedure TestString_Length;
|
|
Procedure TestString_Compare;
|
|
Procedure TestString_SetLength;
|
|
Procedure TestString_CharAt;
|
|
Procedure TestStringHMinusFail;
|
|
Procedure TestStr;
|
|
Procedure TestBaseType_AnsiStringFail;
|
|
Procedure TestBaseType_WideStringFail;
|
|
Procedure TestBaseType_ShortStringFail;
|
|
Procedure TestBaseType_RawByteStringFail;
|
|
Procedure TestTypeShortstring_Fail;
|
|
Procedure TestCharSet_Custom;
|
|
Procedure TestForCharDo;
|
|
Procedure TestForCharInDo;
|
|
|
|
// alias types
|
|
Procedure TestAliasTypeRef;
|
|
Procedure TestTypeCast_BaseTypes;
|
|
Procedure TestTypeCast_AliasBaseTypes;
|
|
|
|
// functions
|
|
Procedure TestEmptyProc;
|
|
Procedure TestProcOneParam;
|
|
Procedure TestFunctionWithoutParams;
|
|
Procedure TestProcedureWithoutParams;
|
|
Procedure TestPrgProcVar;
|
|
Procedure TestProcTwoArgs;
|
|
Procedure TestProc_DefaultValue;
|
|
Procedure TestUnitProcVar;
|
|
Procedure TestImplProc;
|
|
Procedure TestFunctionResult;
|
|
Procedure TestNestedProc;
|
|
Procedure TestNestedProc_ResultString;
|
|
Procedure TestForwardProc;
|
|
Procedure TestNestedForwardProc;
|
|
Procedure TestAssignFunctionResult;
|
|
Procedure TestFunctionResultInCondition;
|
|
Procedure TestFunctionResultInForLoop;
|
|
Procedure TestFunctionResultInTypeCast;
|
|
Procedure TestExit;
|
|
Procedure TestBreak;
|
|
Procedure TestBreakAsVar;
|
|
Procedure TestContinue;
|
|
Procedure TestProc_External;
|
|
Procedure TestProc_ExternalOtherUnit;
|
|
Procedure TestProc_Asm;
|
|
Procedure TestProc_Assembler;
|
|
Procedure TestProc_VarParam;
|
|
Procedure TestProc_VarParamString;
|
|
Procedure TestProc_VarParamV;
|
|
Procedure TestProc_Overload;
|
|
Procedure TestProc_OverloadForward;
|
|
Procedure TestProc_OverloadIntfImpl;
|
|
Procedure TestProc_OverloadNested;
|
|
Procedure TestProc_OverloadUnitCycle;
|
|
Procedure TestProc_Varargs;
|
|
Procedure TestProc_ConstOrder;
|
|
Procedure TestProc_DuplicateConst;
|
|
Procedure TestProc_LocalVarAbsolute;
|
|
Procedure TestProc_ReservedWords;
|
|
|
|
// enums, sets
|
|
Procedure TestEnum_Name;
|
|
Procedure TestEnum_Number;
|
|
Procedure TestEnum_ConstFail;
|
|
Procedure TestEnum_Functions;
|
|
Procedure TestEnum_AsParams;
|
|
Procedure TestEnumRange_Array;
|
|
Procedure TestEnum_ForIn;
|
|
Procedure TestEnum_ScopedNumber;
|
|
Procedure TestEnum_InFunction;
|
|
Procedure TestSet_Enum;
|
|
Procedure TestSet_Operators;
|
|
Procedure TestSet_Operator_In;
|
|
Procedure TestSet_Functions;
|
|
Procedure TestSet_PassAsArgClone;
|
|
Procedure TestSet_AsParams;
|
|
Procedure TestSet_Property;
|
|
Procedure TestSet_EnumConst;
|
|
Procedure TestSet_IntConst;
|
|
Procedure TestSet_AnonymousEnumType;
|
|
Procedure TestSet_AnonymousEnumTypeChar; // ToDo
|
|
Procedure TestSet_ConstEnum;
|
|
Procedure TestSet_ConstChar;
|
|
Procedure TestSet_ConstInt;
|
|
Procedure TestSet_ForIn;
|
|
|
|
// statements
|
|
Procedure TestNestBegin;
|
|
Procedure TestIncDec;
|
|
Procedure TestAssignments;
|
|
Procedure TestArithmeticOperators1;
|
|
Procedure TestLogicalOperators;
|
|
Procedure TestBitwiseOperators;
|
|
Procedure TestFunctionInt;
|
|
Procedure TestFunctionString;
|
|
Procedure TestIfThen;
|
|
Procedure TestForLoop;
|
|
Procedure TestForLoopInsideFunction;
|
|
Procedure TestForLoop_ReadVarAfter;
|
|
Procedure TestForLoop_Nested;
|
|
Procedure TestRepeatUntil;
|
|
Procedure TestAsmBlock;
|
|
Procedure TestAsmPas_Impl; // ToDo
|
|
Procedure TestTryFinally;
|
|
Procedure TestTryExcept;
|
|
Procedure TestTryExcept_ReservedWords;
|
|
Procedure TestIfThenRaiseElse;
|
|
Procedure TestCaseOf;
|
|
Procedure TestCaseOf_UseSwitch;
|
|
Procedure TestCaseOfNoElse;
|
|
Procedure TestCaseOfNoElse_UseSwitch;
|
|
Procedure TestCaseOfRange;
|
|
Procedure TestCaseOfString;
|
|
Procedure TestCaseOfExternalClassConst;
|
|
|
|
// arrays
|
|
Procedure TestArray_Dynamic;
|
|
Procedure TestArray_Dynamic_Nil;
|
|
Procedure TestArray_DynMultiDimensional;
|
|
Procedure TestArray_StaticInt;
|
|
Procedure TestArray_StaticBool;
|
|
Procedure TestArray_StaticChar;
|
|
Procedure TestArray_StaticMultiDim;
|
|
Procedure TestArrayOfRecord;
|
|
Procedure TestArray_StaticRecord;
|
|
Procedure TestArrayOfSet;
|
|
// call(set) literal and clone var
|
|
// call([set]) literal and clone var
|
|
Procedure TestArray_DynAsParam;
|
|
Procedure TestArray_StaticAsParam;
|
|
Procedure TestArrayElement_AsParams;
|
|
Procedure TestArrayElementFromFuncResult_AsParams;
|
|
Procedure TestArrayEnumTypeRange;
|
|
Procedure TestArray_SetLengthOutArg;
|
|
Procedure TestArray_SetLengthProperty;
|
|
Procedure TestArray_SetLengthMultiDim;
|
|
Procedure TestArray_OpenArrayOfString;
|
|
Procedure TestArray_Concat;
|
|
Procedure TestArray_Copy;
|
|
Procedure TestArray_InsertDelete;
|
|
Procedure TestArray_DynArrayConstObjFPC;
|
|
Procedure TestArray_DynArrayConstDelphi;
|
|
Procedure TestArray_ArrayLitAsParam;
|
|
Procedure TestArray_ArrayLitMultiDimAsParam;
|
|
Procedure TestArray_ArrayLitStaticAsParam;
|
|
Procedure TestArray_ForInArrOfString;
|
|
Procedure TestExternalClass_TypeCastArrayToExternalClass;
|
|
Procedure TestExternalClass_TypeCastArrayFromExternalClass;
|
|
|
|
// record
|
|
Procedure TestRecord_Empty;
|
|
Procedure TestRecord_Var;
|
|
Procedure TestRecord_VarExternal;
|
|
Procedure TestWithRecordDo;
|
|
Procedure TestRecord_Assign;
|
|
Procedure TestRecord_PassAsArgClone;
|
|
Procedure TestRecord_AsParams;
|
|
Procedure TestRecordElement_AsParams;
|
|
Procedure TestRecordElementFromFuncResult_AsParams;
|
|
Procedure TestRecordElementFromWith_AsParams;
|
|
Procedure TestRecord_Equal;
|
|
Procedure TestRecord_TypeCastJSValueToRecord;
|
|
Procedure TestRecord_VariantFail;
|
|
Procedure TestRecord_FieldArray;
|
|
Procedure TestRecord_Const;
|
|
Procedure TestRecord_TypecastFail;
|
|
Procedure TestRecord_InFunction;
|
|
|
|
// classes
|
|
Procedure TestClass_TObjectDefaultConstructor;
|
|
Procedure TestClass_TObjectConstructorWithParams;
|
|
Procedure TestClass_TObjectConstructorWithDefaultParam;
|
|
Procedure TestClass_Var;
|
|
Procedure TestClass_Method;
|
|
Procedure TestClass_Implementation;
|
|
Procedure TestClass_Inheritance;
|
|
Procedure TestClass_TypeAlias;
|
|
Procedure TestClass_AbstractMethod;
|
|
Procedure TestClass_CallInherited_ProcNoParams;
|
|
Procedure TestClass_CallInherited_WithParams;
|
|
Procedure TestClasS_CallInheritedConstructor;
|
|
Procedure TestClass_ClassVar_Assign;
|
|
//ToDo Procedure TestClass_ClassVar_Arg;
|
|
Procedure TestClass_CallClassMethod;
|
|
Procedure TestClass_Property;
|
|
Procedure TestClass_Property_ClassMethod;
|
|
Procedure TestClass_Property_Indexed;
|
|
Procedure TestClass_Property_IndexSpec;
|
|
Procedure TestClass_PropertyOfTypeArray;
|
|
Procedure TestClass_PropertyDefault;
|
|
Procedure TestClass_PropertyDefault2;
|
|
Procedure TestClass_PropertyOverride;
|
|
Procedure TestClass_PropertyIncVisibility;
|
|
Procedure TestClass_Assigned;
|
|
Procedure TestClass_WithClassDoCreate;
|
|
Procedure TestClass_WithClassInstDoProperty;
|
|
Procedure TestClass_WithClassInstDoPropertyWithParams;
|
|
Procedure TestClass_WithClassInstDoFunc;
|
|
Procedure TestClass_TypeCast;
|
|
Procedure TestClass_TypeCastUntypedParam;
|
|
Procedure TestClass_Overloads;
|
|
Procedure TestClass_OverloadsAncestor;
|
|
Procedure TestClass_OverloadConstructor;
|
|
Procedure TestClass_OverloadDelphiOverride;
|
|
Procedure TestClass_ReintroducedVar;
|
|
Procedure TestClass_RaiseDescendant;
|
|
Procedure TestClass_ExternalMethod;
|
|
Procedure TestClass_ExternalVirtualNameMismatchFail;
|
|
Procedure TestClass_ExternalOverrideFail;
|
|
Procedure TestClass_ExternalVar;
|
|
Procedure TestClass_Const;
|
|
Procedure TestClass_LocalVarSelfFail;
|
|
Procedure TestClass_ArgSelfFail;
|
|
Procedure TestClass_NestedProcSelf;
|
|
Procedure TestClass_NestedProcSelf2;
|
|
Procedure TestClass_NestedProcClassSelf;
|
|
Procedure TestClass_NestedProcCallInherited;
|
|
Procedure TestClass_TObjectFree;
|
|
Procedure TestClass_TObjectFreeNewInstance;
|
|
Procedure TestClass_TObjectFreeLowerCase;
|
|
Procedure TestClass_TObjectFreeFunctionFail;
|
|
Procedure TestClass_TObjectFreePropertyFail;
|
|
Procedure TestClass_ForIn;
|
|
|
|
// class of
|
|
Procedure TestClassOf_Create;
|
|
Procedure TestClassOf_Call;
|
|
Procedure TestClassOf_Assign;
|
|
Procedure TestClassOf_Is;
|
|
Procedure TestClassOf_Compare;
|
|
Procedure TestClassOf_ClassVar;
|
|
Procedure TestClassOf_ClassMethod;
|
|
Procedure TestClassOf_ClassProperty;
|
|
Procedure TestClassOf_ClassMethodSelf;
|
|
Procedure TestClassOf_TypeCast;
|
|
Procedure TestClassOf_ImplicitFunctionCall;
|
|
Procedure TestClassOf_Const;
|
|
|
|
// nested class
|
|
Procedure TestNestedClass_Alias;
|
|
Procedure TestNestedClass_Record;
|
|
Procedure TestNestedClass_Class;
|
|
|
|
// external class
|
|
Procedure TestExternalClass_Var;
|
|
Procedure TestExternalClass_Const;
|
|
Procedure TestExternalClass_Dollar;
|
|
Procedure TestExternalClass_DuplicateVarFail;
|
|
Procedure TestExternalClass_Method;
|
|
Procedure TestExternalClass_ClassMethod;
|
|
Procedure TestExternalClass_FunctionResultInTypeCast;
|
|
Procedure TestExternalClass_NonExternalOverride;
|
|
Procedure TestExternalClass_OverloadHint;
|
|
Procedure TestExternalClass_Property;
|
|
Procedure TestExternalClass_ClassProperty;
|
|
Procedure TestExternalClass_ClassOf;
|
|
Procedure TestExternalClass_ClassOtherUnit;
|
|
Procedure TestExternalClass_Is;
|
|
Procedure TestExternalClass_As;
|
|
Procedure TestExternalClass_DestructorFail;
|
|
Procedure TestExternalClass_New;
|
|
Procedure TestExternalClass_ClassOf_New;
|
|
Procedure TestExternalClass_FuncClassOf_New;
|
|
Procedure TestExternalClass_New_PasClassFail;
|
|
Procedure TestExternalClass_New_PasClassBracketsFail;
|
|
Procedure TestExternalClass_LocalConstSameName;
|
|
Procedure TestExternalClass_ReintroduceOverload;
|
|
Procedure TestExternalClass_Inherited;
|
|
Procedure TestExternalClass_PascalAncestorFail;
|
|
Procedure TestExternalClass_NewInstance;
|
|
Procedure TestExternalClass_NewInstance_NonVirtualFail;
|
|
Procedure TestExternalClass_NewInstance_FirstParamNotString_Fail;
|
|
Procedure TestExternalClass_NewInstance_SecondParamTyped_Fail;
|
|
Procedure TestExternalClass_PascalProperty;
|
|
Procedure TestExternalClass_TypeCastToRootClass;
|
|
Procedure TestExternalClass_TypeCastToJSObject;
|
|
Procedure TestExternalClass_TypeCastStringToExternalString;
|
|
Procedure TestExternalClass_TypeCastToJSFunction;
|
|
Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
|
|
Procedure TestExternalClass_BracketAccessor;
|
|
Procedure TestExternalClass_BracketAccessor_Call;
|
|
Procedure TestExternalClass_BracketAccessor_2ParamsFail;
|
|
Procedure TestExternalClass_BracketAccessor_ReadOnly;
|
|
Procedure TestExternalClass_BracketAccessor_WriteOnly;
|
|
Procedure TestExternalClass_BracketAccessor_MultiType;
|
|
Procedure TestExternalClass_BracketAccessor_Index;
|
|
Procedure TestExternalClass_ForInJSObject;
|
|
Procedure TestExternalClass_ForInJSArray;
|
|
Procedure TestExternalClass_IncompatibleArgDuplicateIdentifier;
|
|
|
|
// class interfaces
|
|
Procedure TestClassInterface_Corba;
|
|
Procedure TestClassInterface_ProcExternalFail;
|
|
Procedure TestClassInterface_Overloads;
|
|
Procedure TestClassInterface_DuplicateGUIInIntfListFail;
|
|
Procedure TestClassInterface_DuplicateGUIInAncestorFail;
|
|
Procedure TestClassInterface_AncestorImpl;
|
|
Procedure TestClassInterface_ImplReintroduce;
|
|
Procedure TestClassInterface_MethodResolution;
|
|
Procedure TestClassInterface_AncestorMoreInterfaces;
|
|
Procedure TestClassInterface_MethodOverride;
|
|
Procedure TestClassInterface_Corba_Delegation;
|
|
Procedure TestClassInterface_Corba_DelegationStatic;
|
|
Procedure TestClassInterface_Corba_Operators;
|
|
Procedure TestClassInterface_Corba_Args;
|
|
Procedure TestClassInterface_Corba_ForIn;
|
|
Procedure TestClassInterface_COM_AssignVar;
|
|
Procedure TestClassInterface_COM_AssignArg;
|
|
Procedure TestClassInterface_COM_FunctionResult;
|
|
Procedure TestClassInterface_COM_InheritedFuncResult;
|
|
Procedure TestClassInterface_COM_IsAsTypeCasts;
|
|
Procedure TestClassInterface_COM_PassAsArg;
|
|
Procedure TestClassInterface_COM_PassToUntypedParam;
|
|
Procedure TestClassInterface_COM_FunctionInExpr;
|
|
Procedure TestClassInterface_COM_Property;
|
|
Procedure TestClassInterface_COM_IntfProperty;
|
|
Procedure TestClassInterface_COM_Delegation;
|
|
Procedure TestClassInterface_COM_With;
|
|
Procedure TestClassInterface_COM_ForIn;
|
|
Procedure TestClassInterface_COM_ArrayOfIntfFail;
|
|
Procedure TestClassInterface_COM_RecordIntfFail;
|
|
Procedure TestClassInterface_COM_UnitInitialization;
|
|
Procedure TestClassInterface_GUID;
|
|
Procedure TestClassInterface_GUIDProperty;
|
|
|
|
// proc types
|
|
Procedure TestProcType;
|
|
Procedure TestProcType_Arg;
|
|
Procedure TestProcType_FunctionFPC;
|
|
Procedure TestProcType_FunctionDelphi;
|
|
Procedure TestProcType_ProcedureDelphi;
|
|
Procedure TestProcType_AsParam;
|
|
Procedure TestProcType_MethodFPC;
|
|
Procedure TestProcType_MethodDelphi;
|
|
Procedure TestProcType_PropertyFPC;
|
|
Procedure TestProcType_PropertyDelphi;
|
|
Procedure TestProcType_WithClassInstDoPropertyFPC;
|
|
Procedure TestProcType_Nested;
|
|
Procedure TestProcType_NestedOfObject;
|
|
Procedure TestProcType_ReferenceToProc;
|
|
Procedure TestProcType_ReferenceToMethod;
|
|
Procedure TestProcType_Typecast;
|
|
Procedure TestProcType_PassProcToUntyped;
|
|
Procedure TestProcType_PassProcToArray;
|
|
|
|
// pointer
|
|
Procedure TestPointer;
|
|
Procedure TestPointer_Proc;
|
|
Procedure TestPointer_AssignRecordFail;
|
|
Procedure TestPointer_AssignStaticArrayFail;
|
|
Procedure TestPointer_TypeCastJSValueToPointer;
|
|
Procedure TestPointer_NonRecordFail;
|
|
Procedure TestPointer_AnonymousArgTypeFail;
|
|
Procedure TestPointer_AnonymousVarTypeFail;
|
|
Procedure TestPointer_AnonymousResultTypeFail;
|
|
Procedure TestPointer_AddrOperatorFail;
|
|
Procedure TestPointer_ArrayParamsFail;
|
|
Procedure TestPointer_PointerAddFail;
|
|
Procedure TestPointer_IncPointerFail;
|
|
Procedure TestPointer_Record;
|
|
Procedure TestPointer_RecordArg;
|
|
|
|
// jsvalue
|
|
Procedure TestJSValue_AssignToJSValue;
|
|
Procedure TestJSValue_TypeCastToBaseType;
|
|
Procedure TestJSValue_Equal;
|
|
Procedure TestJSValue_If;
|
|
Procedure TestJSValue_Not;
|
|
Procedure TestJSValue_Enum;
|
|
Procedure TestJSValue_ClassInstance;
|
|
Procedure TestJSValue_ClassOf;
|
|
Procedure TestJSValue_ArrayOfJSValue;
|
|
Procedure TestJSValue_ArrayLit;
|
|
Procedure TestJSValue_Params;
|
|
Procedure TestJSValue_UntypedParam;
|
|
Procedure TestJSValue_FuncResultType;
|
|
Procedure TestJSValue_ProcType_Assign;
|
|
Procedure TestJSValue_ProcType_Equal;
|
|
Procedure TestJSValue_ProcType_Param;
|
|
Procedure TestJSValue_AssignToPointerFail;
|
|
Procedure TestJSValue_OverloadDouble;
|
|
Procedure TestJSValue_OverloadNativeInt;
|
|
Procedure TestJSValue_OverloadWord;
|
|
Procedure TestJSValue_OverloadString;
|
|
Procedure TestJSValue_OverloadChar;
|
|
Procedure TestJSValue_OverloadPointer;
|
|
Procedure TestJSValue_ForIn;
|
|
|
|
// RTTI
|
|
Procedure TestRTTI_IntRange;
|
|
Procedure TestRTTI_Double;
|
|
Procedure TestRTTI_ProcType;
|
|
Procedure TestRTTI_ProcType_ArgFromOtherUnit;
|
|
Procedure TestRTTI_EnumAndSetType;
|
|
Procedure TestRTTI_EnumRange;
|
|
Procedure TestRTTI_AnonymousEnumType;
|
|
Procedure TestRTTI_StaticArray;
|
|
Procedure TestRTTI_DynArray;
|
|
Procedure TestRTTI_ArrayNestedAnonymous;
|
|
Procedure TestRTTI_PublishedMethodOverloadFail;
|
|
Procedure TestRTTI_PublishedMethodExternalFail;
|
|
Procedure TestRTTI_PublishedClassPropertyFail;
|
|
Procedure TestRTTI_PublishedClassFieldFail;
|
|
Procedure TestRTTI_PublishedFieldExternalFail;
|
|
Procedure TestRTTI_Class_Field;
|
|
Procedure TestRTTI_Class_Method;
|
|
Procedure TestRTTI_Class_MethodArgFlags;
|
|
Procedure TestRTTI_Class_Property;
|
|
Procedure TestRTTI_Class_PropertyParams;
|
|
Procedure TestRTTI_Class_OtherUnit_TypeAlias;
|
|
Procedure TestRTTI_IndexModifier;
|
|
Procedure TestRTTI_StoredModifier;
|
|
Procedure TestRTTI_DefaultValue;
|
|
Procedure TestRTTI_DefaultValueSet;
|
|
Procedure TestRTTI_DefaultValueRangeType;
|
|
Procedure TestRTTI_DefaultValueInherit;
|
|
Procedure TestRTTI_OverrideMethod;
|
|
Procedure TestRTTI_OverloadProperty;
|
|
// ToDo: array argument
|
|
Procedure TestRTTI_ClassForward;
|
|
Procedure TestRTTI_ClassOf;
|
|
Procedure TestRTTI_Record;
|
|
Procedure TestRTTI_RecordAnonymousArray;
|
|
Procedure TestRTTI_LocalTypes;
|
|
Procedure TestRTTI_TypeInfo_BaseTypes;
|
|
Procedure TestRTTI_TypeInfo_Type_BaseTypes;
|
|
Procedure TestRTTI_TypeInfo_LocalFail;
|
|
Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses1;
|
|
Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
|
|
Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
|
|
Procedure TestRTTI_TypeInfo_FunctionClassType;
|
|
Procedure TestRTTI_TypeInfo_MixedUnits_PointerAndClass;
|
|
Procedure TestRTTI_Interface_Corba;
|
|
Procedure TestRTTI_Interface_COM;
|
|
|
|
// Resourcestring
|
|
Procedure TestResourcestringProgram;
|
|
Procedure TestResourcestringUnit;
|
|
Procedure TestResourcestringImplementation;
|
|
|
|
// Attributes
|
|
Procedure TestAtributes_Ignore;
|
|
|
|
// Assertions, checks
|
|
procedure TestAssert;
|
|
procedure TestAssert_SysUtils;
|
|
procedure TestObjectChecks;
|
|
procedure TestRangeChecks_AssignInt;
|
|
procedure TestRangeChecks_AssignIntRange;
|
|
procedure TestRangeChecks_AssignEnum;
|
|
procedure TestRangeChecks_AssignEnumRange;
|
|
procedure TestRangeChecks_AssignChar;
|
|
procedure TestRangeChecks_AssignCharRange;
|
|
procedure TestRangeChecks_ArrayIndex;
|
|
procedure TestRangeChecks_StringIndex;
|
|
procedure TestRangeChecks_TypecastInt;
|
|
end;
|
|
|
|
function LinesToStr(Args: array of const): string;
|
|
function ExtractFileUnitName(aFilename: string): string;
|
|
function JSToStr(El: TJSElement): string;
|
|
function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
|
|
|
|
implementation
|
|
|
|
function LinesToStr(Args: array of const): string;
|
|
var
|
|
s: String;
|
|
i: Integer;
|
|
begin
|
|
s:='';
|
|
for i:=Low(Args) to High(Args) do
|
|
case Args[i].VType of
|
|
vtChar: s += Args[i].VChar+LineEnding;
|
|
vtString: s += Args[i].VString^+LineEnding;
|
|
vtPChar: s += Args[i].VPChar+LineEnding;
|
|
vtWideChar: s += AnsiString(Args[i].VWideChar)+LineEnding;
|
|
vtPWideChar: s += AnsiString(Args[i].VPWideChar)+LineEnding;
|
|
vtAnsiString: s += AnsiString(Args[i].VAnsiString)+LineEnding;
|
|
vtWidestring: s += AnsiString(WideString(Args[i].VWideString))+LineEnding;
|
|
vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString))+LineEnding;
|
|
end;
|
|
Result:=s;
|
|
end;
|
|
|
|
function ExtractFileUnitName(aFilename: string): string;
|
|
var
|
|
p: Integer;
|
|
begin
|
|
Result:=ExtractFileName(aFilename);
|
|
if Result='' then exit;
|
|
for p:=length(Result) downto 1 do
|
|
case Result[p] of
|
|
'/','\': exit;
|
|
'.':
|
|
begin
|
|
Delete(Result,p,length(Result));
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function JSToStr(El: TJSElement): string;
|
|
var
|
|
aWriter: TBufferWriter;
|
|
aJSWriter: TJSWriter;
|
|
begin
|
|
aJSWriter:=nil;
|
|
aWriter:=TBufferWriter.Create(1000);
|
|
try
|
|
aJSWriter:=TJSWriter.Create(aWriter);
|
|
aJSWriter.IndentSize:=2;
|
|
aJSWriter.WriteJS(El);
|
|
Result:=aWriter.AsString;
|
|
finally
|
|
aJSWriter.Free;
|
|
aWriter.Free;
|
|
end;
|
|
end;
|
|
|
|
function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
|
|
// search diff, ignore changes in spaces
|
|
const
|
|
SpaceChars = [#9,#10,#13,' '];
|
|
var
|
|
ExpectedP, ActualP: PChar;
|
|
|
|
function FindLineEnd(p: PChar): PChar;
|
|
begin
|
|
Result:=p;
|
|
while not (Result^ in [#0,#10,#13]) do inc(Result);
|
|
end;
|
|
|
|
function FindLineStart(p, MinP: PChar): PChar;
|
|
begin
|
|
while (p>MinP) and not (p[-1] in [#10,#13]) do dec(p);
|
|
Result:=p;
|
|
end;
|
|
|
|
procedure SkipLineEnd(var p: PChar);
|
|
begin
|
|
if p^ in [#10,#13] then
|
|
begin
|
|
if (p[1] in [#10,#13]) and (p^<>p[1]) then
|
|
inc(p,2)
|
|
else
|
|
inc(p);
|
|
end;
|
|
end;
|
|
|
|
procedure DiffFound;
|
|
var
|
|
ActLineStartP, ActLineEndP, p, StartPos: PChar;
|
|
ExpLine, ActLine: String;
|
|
i, LineNo, DiffLineNo: Integer;
|
|
begin
|
|
writeln('Diff found "',Msg,'". Lines:');
|
|
// write correct lines
|
|
p:=PChar(Expected);
|
|
LineNo:=0;
|
|
DiffLineNo:=0;
|
|
repeat
|
|
StartPos:=p;
|
|
while not (p^ in [#0,#10,#13]) do inc(p);
|
|
ExpLine:=copy(Expected,StartPos-PChar(Expected)+1,p-StartPos);
|
|
SkipLineEnd(p);
|
|
inc(LineNo);
|
|
if (p<=ExpectedP) and (p^<>#0) then
|
|
begin
|
|
writeln('= ',ExpLine);
|
|
end else begin
|
|
// diff line
|
|
if DiffLineNo=0 then DiffLineNo:=LineNo;
|
|
// write actual line
|
|
ActLineStartP:=FindLineStart(ActualP,PChar(Actual));
|
|
ActLineEndP:=FindLineEnd(ActualP);
|
|
ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
|
|
writeln('- ',ActLine);
|
|
// write expected line
|
|
writeln('+ ',ExpLine);
|
|
// write empty line with pointer ^
|
|
for i:=1 to 2+ExpectedP-StartPos do write(' ');
|
|
writeln('^');
|
|
Msg:='expected "'+ExpLine+'", but got "'+ActLine+'".';
|
|
CheckSrcDiff:=false;
|
|
// write up to three following actual lines to get some context
|
|
for i:=1 to 3 do begin
|
|
ActLineStartP:=ActLineEndP;
|
|
SkipLineEnd(ActLineStartP);
|
|
if ActLineStartP^=#0 then break;
|
|
ActLineEndP:=FindLineEnd(ActLineStartP);
|
|
ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
|
|
writeln('~ ',ActLine);
|
|
end;
|
|
exit;
|
|
end;
|
|
until p^=#0;
|
|
|
|
writeln('DiffFound Actual:-----------------------');
|
|
writeln(Actual);
|
|
writeln('DiffFound Expected:---------------------');
|
|
writeln(Expected);
|
|
writeln('DiffFound ------------------------------');
|
|
Msg:='diff found, but lines are the same, internal error';
|
|
CheckSrcDiff:=false;
|
|
end;
|
|
|
|
var
|
|
IsSpaceNeeded: Boolean;
|
|
LastChar, Quote: Char;
|
|
begin
|
|
Result:=true;
|
|
Msg:='';
|
|
if Expected='' then Expected:=' ';
|
|
if Actual='' then Actual:=' ';
|
|
ExpectedP:=PChar(Expected);
|
|
ActualP:=PChar(Actual);
|
|
repeat
|
|
//writeln('TTestModule.CheckDiff Exp="',ExpectedP^,'" Act="',ActualP^,'"');
|
|
case ExpectedP^ of
|
|
#0:
|
|
begin
|
|
// check that rest of Actual has only spaces
|
|
while ActualP^ in SpaceChars do inc(ActualP);
|
|
if ActualP^<>#0 then
|
|
begin
|
|
DiffFound;
|
|
exit;
|
|
end;
|
|
exit(true);
|
|
end;
|
|
' ',#9,#10,#13:
|
|
begin
|
|
// skip space in Expected
|
|
IsSpaceNeeded:=false;
|
|
if ExpectedP>PChar(Expected) then
|
|
LastChar:=ExpectedP[-1]
|
|
else
|
|
LastChar:=#0;
|
|
while ExpectedP^ in SpaceChars do inc(ExpectedP);
|
|
if (LastChar in ['a'..'z','A'..'Z','0'..'9','_','$'])
|
|
and (ExpectedP^ in ['a'..'z','A'..'Z','0'..'9','_','$']) then
|
|
IsSpaceNeeded:=true;
|
|
if IsSpaceNeeded and (not (ActualP^ in SpaceChars)) then
|
|
begin
|
|
DiffFound;
|
|
exit;
|
|
end;
|
|
while ActualP^ in SpaceChars do inc(ActualP);
|
|
end;
|
|
'''','"':
|
|
begin
|
|
while ActualP^ in SpaceChars do inc(ActualP);
|
|
if ExpectedP^<>ActualP^ then
|
|
begin
|
|
DiffFound;
|
|
exit;
|
|
end;
|
|
Quote:=ExpectedP^;
|
|
repeat
|
|
inc(ExpectedP);
|
|
inc(ActualP);
|
|
if ExpectedP^<>ActualP^ then
|
|
begin
|
|
DiffFound;
|
|
exit;
|
|
end;
|
|
if (ExpectedP^ in [#0,#10,#13]) then
|
|
break
|
|
else if (ExpectedP^=Quote) then
|
|
begin
|
|
inc(ExpectedP);
|
|
inc(ActualP);
|
|
break;
|
|
end;
|
|
until false;
|
|
end;
|
|
else
|
|
while ActualP^ in SpaceChars do inc(ActualP);
|
|
if ExpectedP^<>ActualP^ then
|
|
begin
|
|
DiffFound;
|
|
exit;
|
|
end;
|
|
inc(ExpectedP);
|
|
inc(ActualP);
|
|
end;
|
|
until false;
|
|
end;
|
|
|
|
{ TTestEnginePasResolver }
|
|
|
|
destructor TTestEnginePasResolver.Destroy;
|
|
begin
|
|
FreeAndNil(FStreamResolver);
|
|
FreeAndNil(FParser);
|
|
FreeAndNil(FScanner);
|
|
FreeAndNil(FStreamResolver);
|
|
if Module<>nil then
|
|
begin
|
|
Module.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
|
|
FModule:=nil;
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TTestEnginePasResolver.FindUnit(const AName, InFilename: String;
|
|
NameExpr, InFileExpr: TPasExpr): TPasModule;
|
|
begin
|
|
Result:=nil;
|
|
if InFilename<>'' then
|
|
RaiseNotYetImplemented(20180224101926,InFileExpr,'Use testcase tcunitsearch instead');
|
|
if Assigned(OnFindUnit) then
|
|
Result:=OnFindUnit(AName);
|
|
if NameExpr=nil then ;
|
|
end;
|
|
|
|
procedure TTestEnginePasResolver.UsedInterfacesFinished(Section: TPasSection);
|
|
begin
|
|
// do not parse recursively
|
|
// parse via the queue
|
|
if Section=nil then ;
|
|
end;
|
|
|
|
{ TCustomTestModule }
|
|
|
|
function TCustomTestModule.GetMsgCount: integer;
|
|
begin
|
|
Result:=FHintMsgs.Count;
|
|
end;
|
|
|
|
function TCustomTestModule.GetMsgs(Index: integer): TTestHintMessage;
|
|
begin
|
|
Result:=TTestHintMessage(FHintMsgs[Index]);
|
|
end;
|
|
|
|
function TCustomTestModule.GetResolverCount: integer;
|
|
begin
|
|
Result:=FModules.Count;
|
|
end;
|
|
|
|
function TCustomTestModule.GetResolvers(Index: integer
|
|
): TTestEnginePasResolver;
|
|
begin
|
|
Result:=TTestEnginePasResolver(FModules[Index]);
|
|
end;
|
|
|
|
function TCustomTestModule.OnPasResolverFindUnit(const aUnitName: String
|
|
): TPasModule;
|
|
var
|
|
DefNamespace: String;
|
|
begin
|
|
//writeln('TTestModule.OnPasResolverFindUnit START Unit="',aUnitName,'"');
|
|
if (Pos('.',aUnitName)<1) then
|
|
begin
|
|
DefNamespace:=GetDefaultNamespace;
|
|
if DefNamespace<>'' then
|
|
begin
|
|
Result:=LoadUnit(DefNamespace+'.'+aUnitName);
|
|
if Result<>nil then exit;
|
|
end;
|
|
end;
|
|
Result:=LoadUnit(aUnitName);
|
|
if Result<>nil then exit;
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('TTestModule.OnPasResolverFindUnit missing unit "',aUnitName,'"');
|
|
{$ENDIF}
|
|
Fail('can''t find unit "'+aUnitName+'"');
|
|
end;
|
|
|
|
procedure TCustomTestModule.OnParserLog(Sender: TObject; const Msg: String);
|
|
var
|
|
aParser: TPasParser;
|
|
Item: TTestHintMessage;
|
|
begin
|
|
aParser:=Sender as TPasParser;
|
|
Item:=TTestHintMessage.Create;
|
|
Item.Id:=aParser.LastMsgNumber;
|
|
Item.MsgType:=aParser.LastMsgType;
|
|
Item.MsgNumber:=aParser.LastMsgNumber;
|
|
Item.Msg:=Msg;
|
|
Item.SourcePos:=aParser.Scanner.CurSourcePos;
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('TCustomTestModule.OnParserLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
|
|
{$ENDIF}
|
|
FHintMsgs.Add(Item);
|
|
end;
|
|
|
|
procedure TCustomTestModule.OnPasResolverLog(Sender: TObject; const Msg: String
|
|
);
|
|
var
|
|
aResolver: TTestEnginePasResolver;
|
|
Item: TTestHintMessage;
|
|
begin
|
|
aResolver:=Sender as TTestEnginePasResolver;
|
|
Item:=TTestHintMessage.Create;
|
|
Item.Id:=aResolver.LastMsgId;
|
|
Item.MsgType:=aResolver.LastMsgType;
|
|
Item.MsgNumber:=aResolver.LastMsgNumber;
|
|
Item.Msg:=Msg;
|
|
Item.SourcePos:=aResolver.LastSourcePos;
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('TCustomTestModule.OnPasResolverLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
|
|
{$ENDIF}
|
|
FHintMsgs.Add(Item);
|
|
end;
|
|
|
|
procedure TCustomTestModule.OnScannerLog(Sender: TObject; const Msg: String);
|
|
var
|
|
Item: TTestHintMessage;
|
|
aScanner: TPas2jsPasScanner;
|
|
begin
|
|
aScanner:=Sender as TPas2jsPasScanner;
|
|
Item:=TTestHintMessage.Create;
|
|
Item.Id:=aScanner.LastMsgNumber;
|
|
Item.MsgType:=aScanner.LastMsgType;
|
|
Item.MsgNumber:=aScanner.LastMsgNumber;
|
|
Item.Msg:=Msg;
|
|
Item.SourcePos:=aScanner.CurSourcePos;
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('TCustomTestModule.OnScannerLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
|
|
{$ENDIF}
|
|
FHintMsgs.Add(Item);
|
|
end;
|
|
|
|
function TCustomTestModule.LoadUnit(const aUnitName: String): TPasModule;
|
|
var
|
|
i: Integer;
|
|
CurEngine: TTestEnginePasResolver;
|
|
CurUnitName: String;
|
|
begin
|
|
//writeln('TTestModule.FindUnit START Unit="',aUnitName,'"');
|
|
Result:=nil;
|
|
if (Module.ClassType=TPasModule)
|
|
and (CompareText(Module.Name,aUnitName)=0) then
|
|
exit(Module);
|
|
|
|
for i:=0 to ResolverCount-1 do
|
|
begin
|
|
CurEngine:=Resolvers[i];
|
|
CurUnitName:=ExtractFileUnitName(CurEngine.Filename);
|
|
//writeln('TTestModule.FindUnit Checking ',i,'/',ResolverCount,' ',CurEngine.Filename,' ',CurUnitName);
|
|
if CompareText(aUnitName,CurUnitName)=0 then
|
|
begin
|
|
Result:=CurEngine.Module;
|
|
if Result<>nil then exit;
|
|
//writeln('TTestModule.FindUnit PARSING unit "',CurEngine.Filename,'"');
|
|
FileResolver.FindSourceFile(aUnitName);
|
|
|
|
CurEngine.StreamResolver:=TStreamResolver.Create;
|
|
CurEngine.StreamResolver.OwnsStreams:=True;
|
|
//writeln('TTestModule.FindUnit SOURCE=',CurEngine.Source);
|
|
CurEngine.StreamResolver.AddStream(CurEngine.FileName,TStringStream.Create(CurEngine.Source));
|
|
CurEngine.Scanner:=TPas2jsPasScanner.Create(CurEngine.StreamResolver);
|
|
InitScanner(CurEngine.Scanner);
|
|
CurEngine.Parser:=TTestPasParser.Create(CurEngine.Scanner,CurEngine.StreamResolver,CurEngine);
|
|
CurEngine.Parser.Options:=po_tcmodules;
|
|
if CompareText(CurUnitName,'System')=0 then
|
|
CurEngine.Parser.ImplicitUses.Clear;
|
|
CurEngine.Scanner.OpenFile(CurEngine.Filename);
|
|
try
|
|
CurEngine.Parser.NextToken;
|
|
CurEngine.Parser.ParseUnit(CurEngine.FModule);
|
|
except
|
|
on E: Exception do
|
|
HandleException(E);
|
|
end;
|
|
//writeln('TTestModule.FindUnit END ',CurUnitName);
|
|
Result:=CurEngine.Module;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestModule.SetUp;
|
|
begin
|
|
{$IFDEF EnablePasTreeGlobalRefCount}
|
|
FElementRefCountAtSetup:=TPasElement.GlobalRefCount;
|
|
{$ENDIF}
|
|
|
|
if FModules<>nil then
|
|
begin
|
|
writeln('TCustomTestModule.SetUp FModules<>nil');
|
|
Halt;
|
|
end;
|
|
|
|
inherited SetUp;
|
|
FSkipTests:=false;
|
|
FSource:=TStringList.Create;
|
|
FModules:=TObjectList.Create(true);
|
|
|
|
FFilename:='test1.pp';
|
|
FFileResolver:=TStreamResolver.Create;
|
|
FFileResolver.OwnsStreams:=True;
|
|
|
|
FScanner:=TPas2jsPasScanner.Create(FFileResolver);
|
|
InitScanner(FScanner);
|
|
|
|
FEngine:=AddModule(Filename);
|
|
FEngine.Scanner:=FScanner;
|
|
FScanner.Resolver:=FEngine;
|
|
|
|
FParser:=TTestPasParser.Create(FScanner,FFileResolver,FEngine);
|
|
FParser.OnLog:=@OnParserLog;
|
|
FEngine.Parser:=FParser;
|
|
Parser.Options:=po_tcmodules;
|
|
|
|
FModule:=Nil;
|
|
FConverter:=CreateConverter;
|
|
|
|
FExpectedErrorClass:=nil;
|
|
end;
|
|
|
|
function TCustomTestModule.CreateConverter: TPasToJSConverter;
|
|
begin
|
|
Result:=TPasToJSConverter.Create;
|
|
Result.Options:=co_tcmodules;
|
|
end;
|
|
|
|
procedure TCustomTestModule.InitScanner(aScanner: TPas2jsPasScanner);
|
|
begin
|
|
aScanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
|
|
aScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
|
|
aScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
|
|
|
|
aScanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
|
|
aScanner.ReadOnlyBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly;
|
|
aScanner.CurrentBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly+[bsHints,bsNotes,bsWarnings,bsWriteableConst];
|
|
|
|
aScanner.OnLog:=@OnScannerLog;
|
|
|
|
aScanner.CompilerVersion:='Comp.Ver.tcmodules';
|
|
end;
|
|
|
|
procedure TCustomTestModule.TearDown;
|
|
{$IFDEF CheckPasTreeRefCount}
|
|
var
|
|
El: TPasElement;
|
|
{$ENDIF}
|
|
var
|
|
i: Integer;
|
|
CurModule: TPasModule;
|
|
begin
|
|
FHintMsgs.Clear;
|
|
FHintMsgsGood.Clear;
|
|
FSkipTests:=false;
|
|
FJSRegModuleCall:=nil;
|
|
FJSModuleCallArgs:=nil;
|
|
FJSImplentationUses:=nil;
|
|
FJSInterfaceUses:=nil;
|
|
FJSModuleSrc:=nil;
|
|
FJSInitBody:=nil;
|
|
FreeAndNil(FJSSource);
|
|
FreeAndNil(FJSModule);
|
|
FreeAndNil(FConverter);
|
|
Engine.Clear;
|
|
FreeAndNil(FSource);
|
|
FreeAndNil(FFileResolver);
|
|
if FModules<>nil then
|
|
begin
|
|
for i:=0 to FModules.Count-1 do
|
|
begin
|
|
CurModule:=TTestEnginePasResolver(FModules[i]).Module;
|
|
if CurModule=nil then continue;
|
|
//writeln('TCustomTestModule.TearDown ReleaseUsedUnits ',CurModule.Name,' ',CurModule.RefCount,' ',CurModule.RefIds.Text);
|
|
CurModule.ReleaseUsedUnits;
|
|
end;
|
|
if FModule<>nil then
|
|
FModule.ReleaseUsedUnits;
|
|
for i:=0 to FModules.Count-1 do
|
|
begin
|
|
CurModule:=TTestEnginePasResolver(FModules[i]).Module;
|
|
if CurModule=nil then continue;
|
|
//writeln('TCustomTestModule.TearDown UsesReleased ',CurModule.Name,' ',CurModule.RefCount,' ',CurModule.RefIds.Text);
|
|
end;
|
|
FreeAndNil(FModules);
|
|
ReleaseAndNil(TPasElement(FModule){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
|
|
FEngine:=nil;
|
|
end;
|
|
|
|
inherited TearDown;
|
|
{$IFDEF EnablePasTreeGlobalRefCount}
|
|
if FElementRefCountAtSetup<>TPasElement.GlobalRefCount then
|
|
begin
|
|
writeln('TCustomTestModule.TearDown GlobalRefCount Was='+IntToStr(FElementRefCountAtSetup)+' Now='+IntToStr(TPasElement.GlobalRefCount));
|
|
{$IFDEF CheckPasTreeRefCount}
|
|
El:=TPasElement.FirstRefEl;
|
|
while El<>nil do
|
|
begin
|
|
writeln(' ',GetObjName(El),' RefIds.Count=',El.RefIds.Count,':');
|
|
for i:=0 to El.RefIds.Count-1 do
|
|
writeln(' ',El.RefIds[i]);
|
|
El:=El.NextRefEl;
|
|
end;
|
|
{$ENDIF}
|
|
Halt;
|
|
Fail('TCustomTestModule.TearDown Was='+IntToStr(FElementRefCountAtSetup)+' Now='+IntToStr(TPasElement.GlobalRefCount));
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TCustomTestModule.Add(Line: string);
|
|
begin
|
|
Source.Add(Line);
|
|
end;
|
|
|
|
procedure TCustomTestModule.Add(const Lines: array of string);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i:=low(Lines) to high(Lines) do
|
|
Add(Lines[i]);
|
|
end;
|
|
|
|
procedure TCustomTestModule.StartParsing;
|
|
var
|
|
Src: String;
|
|
begin
|
|
Src:=Source.Text;
|
|
FEngine.Source:=Src;
|
|
FileResolver.AddStream(FileName,TStringStream.Create(Src));
|
|
Scanner.OpenFile(FileName);
|
|
Writeln('// Test : ',Self.TestName);
|
|
Writeln(Src);
|
|
end;
|
|
|
|
procedure TCustomTestModule.ParseModuleQueue;
|
|
var
|
|
i: Integer;
|
|
CurResolver: TTestEnginePasResolver;
|
|
Found: Boolean;
|
|
Section: TPasSection;
|
|
begin
|
|
// parse til exception or all modules finished
|
|
while not SkipTests do
|
|
begin
|
|
Found:=false;
|
|
for i:=0 to ResolverCount-1 do
|
|
begin
|
|
CurResolver:=Resolvers[i];
|
|
if CurResolver.CurrentParser=nil then continue;
|
|
if not CurResolver.CurrentParser.CanParseContinue(Section) then
|
|
continue;
|
|
CurResolver.Parser.ParseContinue;
|
|
Found:=true;
|
|
break;
|
|
end;
|
|
if not Found then break;
|
|
end;
|
|
|
|
for i:=0 to ResolverCount-1 do
|
|
begin
|
|
CurResolver:=Resolvers[i];
|
|
if CurResolver.Parser=nil then
|
|
begin
|
|
if CurResolver.CurrentParser<>nil then
|
|
Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' '+GetObjName(CurResolver.Parser)+'=Parser<>CurrentParser='+GetObjName(CurResolver.CurrentParser));
|
|
continue;
|
|
end;
|
|
if CurResolver.Parser.CurModule<>nil then
|
|
Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' NOT FINISHED CurModule='+GetObjName(CurResolver.Parser.CurModule));
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestModule.ParseModule;
|
|
begin
|
|
if SkipTests then exit;
|
|
FFirstPasStatement:=nil;
|
|
try
|
|
StartParsing;
|
|
Parser.ParseMain(FModule);
|
|
ParseModuleQueue;
|
|
except
|
|
on E: Exception do
|
|
HandleException(E);
|
|
end;
|
|
if SkipTests then exit;
|
|
|
|
AssertNotNull('Module resulted in Module',Module);
|
|
AssertEquals('modulename',lowercase(ChangeFileExt(FFileName,'')),lowercase(Module.Name));
|
|
TAssert.AssertSame('Has resolver',Engine,Parser.Engine);
|
|
end;
|
|
|
|
procedure TCustomTestModule.ParseProgram;
|
|
begin
|
|
if SkipTests then exit;
|
|
ParseModule;
|
|
if SkipTests then exit;
|
|
AssertEquals('Has program',TPasProgram,Module.ClassType);
|
|
FPasProgram:=TPasProgram(Module);
|
|
AssertNotNull('Has program section',PasProgram.ProgramSection);
|
|
AssertNotNull('Has initialization section',PasProgram.InitializationSection);
|
|
if (PasProgram.InitializationSection.Elements.Count>0) then
|
|
if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
|
|
FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
|
|
end;
|
|
|
|
procedure TCustomTestModule.ParseUnit;
|
|
begin
|
|
if SkipTests then exit;
|
|
ParseModule;
|
|
if SkipTests then exit;
|
|
AssertEquals('Has unit (TPasModule)',TPasModule,Module.ClassType);
|
|
AssertNotNull('Has interface section',Module.InterfaceSection);
|
|
AssertNotNull('Has implementation section',Module.ImplementationSection);
|
|
if (Module.InitializationSection<>nil)
|
|
and (Module.InitializationSection.Elements.Count>0)
|
|
and (TObject(Module.InitializationSection.Elements[0]) is TPasImplBlock) then
|
|
FFirstPasStatement:=TPasImplBlock(Module.InitializationSection.Elements[0]);
|
|
end;
|
|
|
|
function TCustomTestModule.FindModuleWithFilename(aFilename: string
|
|
): TTestEnginePasResolver;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i:=0 to ResolverCount-1 do
|
|
if CompareText(Resolvers[i].Filename,aFilename)=0 then
|
|
exit(Resolvers[i]);
|
|
Result:=nil;
|
|
end;
|
|
|
|
function TCustomTestModule.AddModule(aFilename: string
|
|
): TTestEnginePasResolver;
|
|
begin
|
|
//writeln('TTestModuleConverter.AddModule ',aFilename);
|
|
if FindModuleWithFilename(aFilename)<>nil then
|
|
Fail('TTestModuleConverter.AddModule: file "'+aFilename+'" already exists');
|
|
Result:=TTestEnginePasResolver.Create;
|
|
Result.Filename:=aFilename;
|
|
Result.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
|
|
Result.OnFindUnit:=@OnPasResolverFindUnit;
|
|
Result.OnLog:=@OnPasResolverLog;
|
|
FModules.Add(Result);
|
|
end;
|
|
|
|
function TCustomTestModule.AddModuleWithSrc(aFilename, Src: string
|
|
): TTestEnginePasResolver;
|
|
begin
|
|
Result:=AddModule(aFilename);
|
|
Result.Source:=Src;
|
|
end;
|
|
|
|
function TCustomTestModule.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
|
|
ImplementationSrc: string): TTestEnginePasResolver;
|
|
var
|
|
Src: String;
|
|
begin
|
|
Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding;
|
|
Src+=LineEnding;
|
|
Src+='interface'+LineEnding;
|
|
Src+=LineEnding;
|
|
Src+=InterfaceSrc;
|
|
Src+='implementation'+LineEnding;
|
|
Src+=LineEnding;
|
|
Src+=ImplementationSrc;
|
|
Src+='end.'+LineEnding;
|
|
Result:=AddModuleWithSrc(aFilename,Src);
|
|
end;
|
|
|
|
procedure TCustomTestModule.AddSystemUnit;
|
|
begin
|
|
AddModuleWithIntfImplSrc('system.pp',
|
|
// interface
|
|
LinesToStr([
|
|
'type',
|
|
' integer=longint;',
|
|
'var',
|
|
' ExitCode: Longint;',
|
|
''
|
|
// implementation
|
|
]),LinesToStr([
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TCustomTestModule.StartProgram(NeedSystemUnit: boolean);
|
|
begin
|
|
if NeedSystemUnit then
|
|
AddSystemUnit
|
|
else
|
|
Parser.ImplicitUses.Clear;
|
|
Add('program '+ExtractFileUnitName(Filename)+';');
|
|
Add('');
|
|
end;
|
|
|
|
procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean);
|
|
begin
|
|
if NeedSystemUnit then
|
|
AddSystemUnit
|
|
else
|
|
Parser.ImplicitUses.Clear;
|
|
Add('unit Test1;');
|
|
Add('');
|
|
end;
|
|
|
|
procedure TCustomTestModule.ConvertModule;
|
|
|
|
procedure CheckUsesList(UsesName: String; Arg: TJSArrayLiteralElement;
|
|
out UsesLit: TJSArrayLiteral);
|
|
var
|
|
i: Integer;
|
|
Item: TJSElement;
|
|
Lit: TJSLiteral;
|
|
begin
|
|
UsesLit:=nil;
|
|
AssertNotNull(UsesName+' uses section',Arg.Expr);
|
|
if (Arg.Expr.ClassType=TJSLiteral) and TJSLiteral(Arg.Expr).Value.IsNull then
|
|
exit; // null is ok
|
|
AssertEquals(UsesName+' uses section param is array',TJSArrayLiteral,Arg.Expr.ClassType);
|
|
FJSInterfaceUses:=TJSArrayLiteral(Arg.Expr);
|
|
for i:=0 to FJSInterfaceUses.Elements.Count-1 do
|
|
begin
|
|
Item:=FJSInterfaceUses.Elements.Elements[i].Expr;
|
|
AssertNotNull(UsesName+' uses section item['+IntToStr(i)+'].Expr',Item);
|
|
AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is lit',TJSLiteral,Item.ClassType);
|
|
Lit:=TJSLiteral(Item);
|
|
AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is string lit',
|
|
ord(jsbase.jstString),ord(Lit.Value.ValueType));
|
|
end;
|
|
end;
|
|
|
|
procedure CheckFunctionParam(ParamName: string; Arg: TJSArrayLiteralElement;
|
|
out Src: TJSSourceElements);
|
|
var
|
|
FunDecl: TJSFunctionDeclarationStatement;
|
|
FunDef: TJSFuncDef;
|
|
FunBody: TJSFunctionBody;
|
|
begin
|
|
Src:=nil;
|
|
AssertNotNull(ParamName,Arg.Expr);
|
|
AssertEquals(ParamName+' Arg.Expr type',TJSFunctionDeclarationStatement,Arg.Expr.ClassType);
|
|
FunDecl:=Arg.Expr as TJSFunctionDeclarationStatement;
|
|
AssertNotNull(ParamName+' FunDecl.AFunction',FunDecl.AFunction);
|
|
AssertEquals(ParamName+' FunDecl.AFunction type',TJSFuncDef,FunDecl.AFunction.ClassType);
|
|
FunDef:=FunDecl.AFunction as TJSFuncDef;
|
|
AssertEquals(ParamName+' name empty','',String(FunDef.Name));
|
|
AssertNotNull(ParamName+' body',FunDef.Body);
|
|
AssertEquals(ParamName+' body type',TJSFunctionBody,FunDef.Body.ClassType);
|
|
FunBody:=FunDef.Body as TJSFunctionBody;
|
|
AssertNotNull(ParamName+' body.A',FunBody.A);
|
|
AssertEquals(ParamName+' body.A type',TJSSourceElements,FunBody.A.ClassType);
|
|
Src:=FunBody.A as TJSSourceElements;
|
|
end;
|
|
|
|
var
|
|
ModuleNameExpr: TJSLiteral;
|
|
InitFunction: TJSFunctionDeclarationStatement;
|
|
InitAssign: TJSSimpleAssignStatement;
|
|
InitName: String;
|
|
LastNode: TJSElement;
|
|
Arg: TJSArrayLiteralElement;
|
|
begin
|
|
if SkipTests then exit;
|
|
try
|
|
FJSModule:=FConverter.ConvertPasElement(Module,Engine) as TJSSourceElements;
|
|
except
|
|
on E: Exception do
|
|
HandleException(E);
|
|
end;
|
|
if SkipTests then exit;
|
|
if ExpectedErrorClass<>nil then
|
|
Fail('Missing '+ExpectedErrorClass.ClassName+' error {'+ExpectedErrorMsg+'} ('+IntToStr(ExpectedErrorNumber)+')');
|
|
|
|
FJSSource:=TStringList.Create;
|
|
FJSSource.Text:=ConvertJSModuleToString(JSModule);
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('TTestModule.ConvertModule JS:');
|
|
write(FJSSource.Text);
|
|
{$ENDIF}
|
|
|
|
// rtl.module(...
|
|
AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
|
|
AssertNotNull('register module call',JSModule.Statements.Nodes[0].Node);
|
|
AssertEquals('register module call',TJSCallExpression,JSModule.Statements.Nodes[0].Node.ClassType);
|
|
FJSRegModuleCall:=JSModule.Statements.Nodes[0].Node as TJSCallExpression;
|
|
AssertNotNull('register module rtl.module expr',JSRegModuleCall.Expr);
|
|
AssertNotNull('register module rtl.module args',JSRegModuleCall.Args);
|
|
AssertEquals('rtl.module args',TJSArguments,JSRegModuleCall.Args.ClassType);
|
|
FJSModuleCallArgs:=JSRegModuleCall.Args as TJSArguments;
|
|
|
|
// parameter 'unitname'
|
|
if JSModuleCallArgs.Elements.Count<1 then
|
|
Fail('rtl.module first param unit missing');
|
|
Arg:=JSModuleCallArgs.Elements.Elements[0];
|
|
AssertNotNull('module name param',Arg.Expr);
|
|
ModuleNameExpr:=Arg.Expr as TJSLiteral;
|
|
AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType));
|
|
if Module is TPasProgram then
|
|
AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString))
|
|
else
|
|
AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString));
|
|
|
|
// main uses section
|
|
if JSModuleCallArgs.Elements.Count<2 then
|
|
Fail('rtl.module second param main uses missing');
|
|
Arg:=JSModuleCallArgs.Elements.Elements[1];
|
|
CheckUsesList('interface',Arg,FJSInterfaceUses);
|
|
|
|
// program/library/interface function()
|
|
if JSModuleCallArgs.Elements.Count<3 then
|
|
Fail('rtl.module third param intf-function missing');
|
|
Arg:=JSModuleCallArgs.Elements.Elements[2];
|
|
CheckFunctionParam('module intf-function',Arg,FJSModuleSrc);
|
|
|
|
// search for $mod.$init or $mod.$main - the last statement
|
|
if Module is TPasProgram then
|
|
begin
|
|
InitName:='$main';
|
|
AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0);
|
|
end
|
|
else
|
|
InitName:='$init';
|
|
FJSInitBody:=nil;
|
|
if JSModuleSrc.Statements.Count>0 then
|
|
begin
|
|
LastNode:=JSModuleSrc.Statements.Nodes[JSModuleSrc.Statements.Count-1].Node;
|
|
if LastNode is TJSSimpleAssignStatement then
|
|
begin
|
|
InitAssign:=LastNode as TJSSimpleAssignStatement;
|
|
if GetDottedIdentifier(InitAssign.LHS)='$mod.'+InitName then
|
|
begin
|
|
InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement;
|
|
FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody;
|
|
end
|
|
else if Module is TPasProgram then
|
|
CheckDottedIdentifier('init function',InitAssign.LHS,'$mod.'+InitName);
|
|
end;
|
|
end;
|
|
|
|
// optional: implementation uses section
|
|
if JSModuleCallArgs.Elements.Count<4 then
|
|
exit;
|
|
Arg:=JSModuleCallArgs.Elements.Elements[3];
|
|
CheckUsesList('implementation',Arg,FJSImplentationUses);
|
|
|
|
// optional: implementation function()
|
|
if JSModuleCallArgs.Elements.Count<5 then
|
|
exit;
|
|
Arg:=JSModuleCallArgs.Elements.Elements[4];
|
|
CheckFunctionParam('module impl-function',Arg,FJSImplementationSrc);
|
|
end;
|
|
|
|
procedure TCustomTestModule.ConvertProgram;
|
|
begin
|
|
Add('end.');
|
|
ParseProgram;
|
|
ConvertModule;
|
|
end;
|
|
|
|
procedure TCustomTestModule.ConvertUnit;
|
|
begin
|
|
Add('end.');
|
|
ParseUnit;
|
|
ConvertModule;
|
|
end;
|
|
|
|
function TCustomTestModule.ConvertJSModuleToString(El: TJSElement): string;
|
|
begin
|
|
Result:=tcmodules.JSToStr(El);
|
|
end;
|
|
|
|
procedure TCustomTestModule.CheckDottedIdentifier(Msg: string; El: TJSElement;
|
|
DottedName: string);
|
|
begin
|
|
if DottedName='' then
|
|
begin
|
|
AssertNull(Msg,El);
|
|
end
|
|
else
|
|
begin
|
|
AssertNotNull(Msg,El);
|
|
AssertEquals(Msg,DottedName,GetDottedIdentifier(El));
|
|
end;
|
|
end;
|
|
|
|
function TCustomTestModule.GetDottedIdentifier(El: TJSElement): string;
|
|
begin
|
|
if El=nil then
|
|
Result:=''
|
|
else if El is TJSPrimaryExpressionIdent then
|
|
Result:=String(TJSPrimaryExpressionIdent(El).Name)
|
|
else if El is TJSDotMemberExpression then
|
|
Result:=GetDottedIdentifier(TJSDotMemberExpression(El).MExpr)+'.'+String(TJSDotMemberExpression(El).Name)
|
|
else
|
|
AssertEquals('GetDottedIdentifier',TJSPrimaryExpressionIdent,El.ClassType);
|
|
end;
|
|
|
|
procedure TCustomTestModule.CheckSource(Msg, Statements: String;
|
|
InitStatements: string; ImplStatements: string);
|
|
var
|
|
ActualSrc, ExpectedSrc, InitName: String;
|
|
begin
|
|
ActualSrc:=JSToStr(JSModuleSrc);
|
|
ExpectedSrc:=
|
|
'var $mod = this;'+LineEnding
|
|
+Statements;
|
|
if coUseStrict in Converter.Options then
|
|
ExpectedSrc:='"use strict";'+LineEnding+ExpectedSrc;
|
|
if Module is TPasProgram then
|
|
InitName:='$main'
|
|
else
|
|
InitName:='$init';
|
|
if (Module is TPasProgram) or (Trim(InitStatements)<>'') then
|
|
ExpectedSrc:=ExpectedSrc+LineEnding
|
|
+'$mod.'+InitName+' = function () {'+LineEnding
|
|
+InitStatements
|
|
+'};'+LineEnding;
|
|
//writeln('TCustomTestModule.CheckSource ExpectedIntf="',ExpectedSrc,'"');
|
|
//writeln('TTestModule.CheckSource InitStatements="',Trim(InitStatements),'"');
|
|
CheckDiff(Msg,ExpectedSrc,ActualSrc);
|
|
|
|
if (JSImplementationSrc<>nil) then
|
|
begin
|
|
ActualSrc:=JSToStr(JSImplementationSrc);
|
|
ExpectedSrc:=
|
|
'var $mod = this;'+LineEnding
|
|
+'var $impl = $mod.$impl;'+LineEnding
|
|
+ImplStatements;
|
|
end
|
|
else
|
|
begin
|
|
ActualSrc:='';
|
|
ExpectedSrc:=ImplStatements;
|
|
end;
|
|
//writeln('TTestModule.CheckSource InitStatements="',InitStatements,'"');
|
|
//writeln('TCustomTestModule.CheckSource Expected: ',ExpectedSrc);
|
|
|
|
CheckDiff(Msg,ExpectedSrc,ActualSrc);
|
|
end;
|
|
|
|
procedure TCustomTestModule.CheckDiff(Msg, Expected, Actual: string);
|
|
// search diff, ignore changes in spaces
|
|
var
|
|
s: string;
|
|
begin
|
|
if CheckSrcDiff(Expected,Actual,s) then exit;
|
|
Fail(Msg+': '+s);
|
|
end;
|
|
|
|
procedure TCustomTestModule.CheckUnit(Filename, ExpectedSrc: string);
|
|
var
|
|
aResolver: TTestEnginePasResolver;
|
|
aConverter: TPasToJSConverter;
|
|
aJSModule: TJSSourceElements;
|
|
ActualSrc: String;
|
|
begin
|
|
aResolver:=GetResolver(Filename);
|
|
AssertNotNull('missing resolver of unit '+Filename,aResolver);
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('CheckUnit '+Filename+' converting ...');
|
|
{$ENDIF}
|
|
aConverter:=CreateConverter;
|
|
aJSModule:=nil;
|
|
try
|
|
try
|
|
aJSModule:=aConverter.ConvertPasElement(aResolver.Module,aResolver) as TJSSourceElements;
|
|
except
|
|
on E: Exception do
|
|
HandleException(E);
|
|
end;
|
|
ActualSrc:=ConvertJSModuleToString(aJSModule);
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('TTestModule.CheckUnit ',Filename,' Pas:');
|
|
write(aResolver.Source);
|
|
writeln('TTestModule.CheckUnit ',Filename,' JS:');
|
|
write(ActualSrc);
|
|
{$ENDIF}
|
|
CheckDiff('Converted unit: "'+ChangeFileExt(Filename,'.js')+'"',ExpectedSrc,ActualSrc);
|
|
finally
|
|
aJSModule.Free;
|
|
aConverter.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestModule.CheckHint(MsgType: TMessageType;
|
|
MsgNumber: integer; Msg: string; Marker: PSrcMarker);
|
|
var
|
|
i: Integer;
|
|
Item: TTestHintMessage;
|
|
Expected,Actual: string;
|
|
begin
|
|
//writeln('TCustomTestModule.CheckHint MsgCount=',MsgCount);
|
|
for i:=0 to MsgCount-1 do
|
|
begin
|
|
Item:=Msgs[i];
|
|
if (Item.MsgNumber<>MsgNumber) or (Item.Msg<>Msg) then continue;
|
|
if (Marker<>nil) then
|
|
begin
|
|
if Item.SourcePos.Row<>Marker^.Row then continue;
|
|
if (Item.SourcePos.Column<Marker^.StartCol)
|
|
or (Item.SourcePos.Column>Marker^.EndCol) then continue;
|
|
end;
|
|
// found
|
|
FHintMsgsGood.Add(Item);
|
|
str(Item.MsgType,Actual);
|
|
str(MsgType,Expected);
|
|
AssertEquals('MsgType',Expected,Actual);
|
|
exit;
|
|
end;
|
|
|
|
// needed message missing -> show emitted messages
|
|
WriteSources('',0,0);
|
|
for i:=0 to MsgCount-1 do
|
|
begin
|
|
Item:=Msgs[i];
|
|
write('TCustomTestModule.CheckHint ',i,'/',MsgCount,' ',Item.MsgType,
|
|
' ('+IntToStr(Item.MsgNumber),')');
|
|
if Marker<>nil then
|
|
write(' '+ExtractFileName(Item.SourcePos.FileName),'(',Item.SourcePos.Row,',',Item.SourcePos.Column,')');
|
|
writeln(' {',Item.Msg,'}');
|
|
end;
|
|
str(MsgType,Expected);
|
|
Actual:='Missing '+Expected+' ('+IntToStr(MsgNumber)+')';
|
|
if Marker<>nil then
|
|
Actual:=Actual+' '+ExtractFileName(Marker^.Filename)+'('+IntToStr(Marker^.Row)+','+IntToStr(Marker^.StartCol)+'..'+IntToStr(Marker^.EndCol)+')';
|
|
Actual:=Actual+' '+Msg;
|
|
Fail(Actual);
|
|
end;
|
|
|
|
procedure TCustomTestModule.CheckResolverUnexpectedHints(WithSourcePos: boolean
|
|
);
|
|
var
|
|
i: Integer;
|
|
s, Txt: String;
|
|
Msg: TTestHintMessage;
|
|
begin
|
|
for i:=0 to MsgCount-1 do
|
|
begin
|
|
Msg:=Msgs[i];
|
|
if FHintMsgsGood.IndexOf(Msg)>=0 then continue;
|
|
s:='';
|
|
str(Msg.MsgType,s);
|
|
Txt:='Unexpected resolver message found ['+IntToStr(Msg.Id)+'] '
|
|
+s+': ('+IntToStr(Msg.MsgNumber)+')';
|
|
if WithSourcePos then
|
|
Txt:=Txt+' '+ExtractFileName(Msg.SourcePos.FileName)+'('+IntToStr(Msg.SourcePos.Row)+','+IntToStr(Msg.SourcePos.Column)+')';
|
|
Txt:=Txt+' {'+Msg.Msg+'}';
|
|
Fail(Txt);
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestModule.SetExpectedScannerError(Msg: string;
|
|
MsgNumber: integer);
|
|
begin
|
|
ExpectedErrorClass:=EScannerError;
|
|
ExpectedErrorMsg:=Msg;
|
|
ExpectedErrorNumber:=MsgNumber;
|
|
end;
|
|
|
|
procedure TCustomTestModule.SetExpectedParserError(Msg: string;
|
|
MsgNumber: integer);
|
|
begin
|
|
ExpectedErrorClass:=EParserError;
|
|
ExpectedErrorMsg:=Msg;
|
|
ExpectedErrorNumber:=MsgNumber;
|
|
end;
|
|
|
|
procedure TCustomTestModule.SetExpectedPasResolverError(Msg: string;
|
|
MsgNumber: integer);
|
|
begin
|
|
ExpectedErrorClass:=EPasResolve;
|
|
ExpectedErrorMsg:=Msg;
|
|
ExpectedErrorNumber:=MsgNumber;
|
|
end;
|
|
|
|
procedure TCustomTestModule.SetExpectedConverterError(Msg: string;
|
|
MsgNumber: integer);
|
|
begin
|
|
ExpectedErrorClass:=EPas2JS;
|
|
ExpectedErrorMsg:=Msg;
|
|
ExpectedErrorNumber:=MsgNumber;
|
|
end;
|
|
|
|
function TCustomTestModule.IsErrorExpected(E: Exception): boolean;
|
|
var
|
|
MsgNumber: Integer;
|
|
Msg: String;
|
|
begin
|
|
Result:=false;
|
|
if (ExpectedErrorClass=nil) or (ExpectedErrorClass<>E.ClassType) then exit;
|
|
Msg:=E.Message;
|
|
if E is EPas2JS then
|
|
MsgNumber:=EPas2JS(E).MsgNumber
|
|
else if E is EPasResolve then
|
|
MsgNumber:=EPasResolve(E).MsgNumber
|
|
else if E is EParserError then
|
|
MsgNumber:=Parser.LastMsgNumber
|
|
else if E is EScannerError then
|
|
begin
|
|
MsgNumber:=Scanner.LastMsgNumber;
|
|
Msg:=Scanner.LastMsg;
|
|
end
|
|
else
|
|
MsgNumber:=0;
|
|
Result:=(MsgNumber=ExpectedErrorNumber) and (Msg=ExpectedErrorMsg);
|
|
if Result then
|
|
SkipTests:=true;
|
|
end;
|
|
|
|
procedure TCustomTestModule.HandleScannerError(E: EScannerError);
|
|
begin
|
|
if IsErrorExpected(E) then exit;
|
|
WriteSources(Scanner.CurFilename,Scanner.CurRow,Scanner.CurColumn);
|
|
writeln('ERROR: TCustomTestModule.HandleScannerError '+E.ClassName+':'+E.Message
|
|
+' '+Scanner.CurFilename
|
|
+'('+IntToStr(Scanner.CurRow)+','+IntToStr(Scanner.CurColumn)+')');
|
|
FailException(E);
|
|
end;
|
|
|
|
procedure TCustomTestModule.HandleParserError(E: EParserError);
|
|
begin
|
|
if IsErrorExpected(E) then exit;
|
|
WriteSources(E.Filename,E.Row,E.Column);
|
|
writeln('ERROR: TCustomTestModule.HandleParserError '+E.ClassName+':'+E.Message
|
|
+' '+E.Filename+'('+IntToStr(E.Row)+','+IntToStr(E.Column)+')'
|
|
+' MainModuleScannerLine="'+Scanner.CurLine+'"'
|
|
);
|
|
FailException(E);
|
|
end;
|
|
|
|
procedure TCustomTestModule.HandlePasResolveError(E: EPasResolve);
|
|
var
|
|
P: TPasSourcePos;
|
|
begin
|
|
if IsErrorExpected(E) then exit;
|
|
P:=E.SourcePos;
|
|
WriteSources(P.FileName,P.Row,P.Column);
|
|
writeln('ERROR: TCustomTestModule.HandlePasResolveError '+E.ClassName+':'+E.Message
|
|
+' '+P.FileName+'('+IntToStr(P.Row)+','+IntToStr(P.Column)+')');
|
|
FailException(E);
|
|
end;
|
|
|
|
procedure TCustomTestModule.HandlePas2JSError(E: EPas2JS);
|
|
var
|
|
Row, Col: integer;
|
|
begin
|
|
if IsErrorExpected(E) then exit;
|
|
Engine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,Row,Col);
|
|
WriteSources(E.PasElement.SourceFilename,Row,Col);
|
|
writeln('ERROR: TCustomTestModule.HandlePas2JSError '+E.ClassName+':'+E.Message
|
|
+' '+E.PasElement.SourceFilename
|
|
+'('+IntToStr(Row)+','+IntToStr(Col)+')');
|
|
FailException(E);
|
|
end;
|
|
|
|
procedure TCustomTestModule.HandleException(E: Exception);
|
|
begin
|
|
if E is EScannerError then
|
|
HandleScannerError(EScannerError(E))
|
|
else if E is EParserError then
|
|
HandleParserError(EParserError(E))
|
|
else if E is EPasResolve then
|
|
HandlePasResolveError(EPasResolve(E))
|
|
else if E is EPas2JS then
|
|
HandlePas2JSError(EPas2JS(E))
|
|
else
|
|
begin
|
|
if IsErrorExpected(E) then exit;
|
|
if not (E is EAssertionFailedError) then
|
|
begin
|
|
WriteSources('',0,0);
|
|
writeln('ERROR: TCustomTestModule.HandleException '+E.ClassName+':'+E.Message);
|
|
end;
|
|
FailException(E);
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestModule.FailException(E: Exception);
|
|
var
|
|
MsgNumber: Integer;
|
|
begin
|
|
if ExpectedErrorClass<>nil then
|
|
begin
|
|
if FExpectedErrorClass=E.ClassType then
|
|
begin
|
|
if E is EPas2JS then
|
|
MsgNumber:=EPas2JS(E).MsgNumber
|
|
else if E is EPasResolve then
|
|
MsgNumber:=EPasResolve(E).MsgNumber
|
|
else if E is EParserError then
|
|
MsgNumber:=Parser.LastMsgNumber
|
|
else if E is EScannerError then
|
|
MsgNumber:=Scanner.LastMsgNumber
|
|
else
|
|
MsgNumber:=0;
|
|
AssertEquals('Expected error message ('+IntToStr(ExpectedErrorNumber)+')','{'+ExpectedErrorMsg+'}','{'+E.Message+'}');
|
|
AssertEquals('Expected {'+ExpectedErrorMsg+'}, but got msg {'+E.Message+'} number',
|
|
ExpectedErrorNumber,MsgNumber);
|
|
end else begin
|
|
AssertEquals('Wrong exception class',ExpectedErrorClass.ClassName,E.ClassName);
|
|
end;
|
|
end;
|
|
Fail(E.Message);
|
|
end;
|
|
|
|
procedure TCustomTestModule.WriteSources(const aFilename: string; aRow,
|
|
aCol: integer);
|
|
var
|
|
IsSrc: Boolean;
|
|
i, j: Integer;
|
|
SrcLines: TStringList;
|
|
Line: string;
|
|
aModule: TTestEnginePasResolver;
|
|
begin
|
|
writeln('TCustomTestModule.WriteSources File="',aFilename,'" Row=',aRow,' Col=',aCol);
|
|
for i:=0 to ResolverCount-1 do
|
|
begin
|
|
aModule:=Resolvers[i];
|
|
SrcLines:=TStringList.Create;
|
|
try
|
|
SrcLines.Text:=aModule.Source;
|
|
IsSrc:=ExtractFilename(aModule.Filename)=ExtractFileName(aFilename);
|
|
writeln('Testcode:-File="',aModule.Filename,'"----------------------------------:');
|
|
for j:=1 to SrcLines.Count do
|
|
begin
|
|
Line:=SrcLines[j-1];
|
|
if IsSrc and (j=aRow) then
|
|
begin
|
|
write('*');
|
|
Line:=LeftStr(Line,aCol-1)+'|'+copy(Line,aCol,length(Line));
|
|
end;
|
|
writeln(Format('%:4d: ',[j]),Line);
|
|
end;
|
|
finally
|
|
SrcLines.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TCustomTestModule.IndexOfResolver(const Filename: string): integer;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i:=0 to ResolverCount-1 do
|
|
if Filename=Resolvers[i].Filename then exit(i);
|
|
Result:=-1;
|
|
end;
|
|
|
|
function TCustomTestModule.GetResolver(const Filename: string
|
|
): TTestEnginePasResolver;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i:=IndexOfResolver(Filename);
|
|
if i<0 then exit(nil);
|
|
Result:=Resolvers[i];
|
|
end;
|
|
|
|
function TCustomTestModule.GetDefaultNamespace: string;
|
|
var
|
|
C: TClass;
|
|
begin
|
|
Result:='';
|
|
if FModule=nil then exit;
|
|
C:=FModule.ClassType;
|
|
if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
|
|
Result:=Engine.DefaultNameSpace;
|
|
end;
|
|
|
|
constructor TCustomTestModule.Create;
|
|
begin
|
|
inherited Create;
|
|
FHintMsgs:=TObjectList.Create(true);
|
|
FHintMsgsGood:=TFPList.Create;
|
|
end;
|
|
|
|
destructor TCustomTestModule.Destroy;
|
|
begin
|
|
FreeAndNil(FHintMsgs);
|
|
FreeAndNil(FHintMsgsGood);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TTestModule }
|
|
|
|
procedure TTestModule.TestEmptyProgram;
|
|
begin
|
|
StartProgram(false);
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestEmptyProgram','','');
|
|
end;
|
|
|
|
procedure TTestModule.TestEmptyProgramUseStrict;
|
|
begin
|
|
Converter.Options:=Converter.Options+[coUseStrict];
|
|
StartProgram(false);
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestEmptyProgramUseStrict','','');
|
|
end;
|
|
|
|
procedure TTestModule.TestEmptyUnit;
|
|
begin
|
|
StartUnit(false);
|
|
Add('interface');
|
|
Add('implementation');
|
|
ConvertUnit;
|
|
CheckSource('TestEmptyUnit',
|
|
LinesToStr([
|
|
]),
|
|
'');
|
|
end;
|
|
|
|
procedure TTestModule.TestEmptyUnitUseStrict;
|
|
begin
|
|
Converter.Options:=Converter.Options+[coUseStrict];
|
|
StartUnit(false);
|
|
Add('interface');
|
|
Add('implementation');
|
|
ConvertUnit;
|
|
CheckSource('TestEmptyUnitUseStrict',
|
|
LinesToStr([
|
|
''
|
|
]),
|
|
'');
|
|
end;
|
|
|
|
procedure TTestModule.TestDottedUnitNames;
|
|
begin
|
|
AddModuleWithIntfImplSrc('NS1.Unit2.pas',
|
|
LinesToStr([
|
|
'var iV: longint;'
|
|
]),
|
|
'');
|
|
|
|
FFilename:='ns1.test1.pp';
|
|
StartProgram(true);
|
|
Add('uses unIt2;');
|
|
Add('implementation');
|
|
Add('var');
|
|
Add(' i: longint;');
|
|
Add('begin');
|
|
Add(' i:=iv;');
|
|
Add(' i:=uNit2.iv;');
|
|
Add(' i:=Ns1.TEst1.i;');
|
|
ConvertProgram;
|
|
CheckSource('TestDottedUnitNames',
|
|
LinesToStr([
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([ // this.$init
|
|
'$mod.i = pas["NS1.Unit2"].iV;',
|
|
'$mod.i = pas["NS1.Unit2"].iV;',
|
|
'$mod.i = $mod.i;',
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestDottedUnitNameImpl;
|
|
begin
|
|
AddModuleWithIntfImplSrc('TEST.UnitA.pas',
|
|
LinesToStr([
|
|
'type',
|
|
' TObject = class end;',
|
|
' TTestA = class',
|
|
' end;'
|
|
]),
|
|
LinesToStr(['uses TEST.UnitB;'])
|
|
);
|
|
AddModuleWithIntfImplSrc('TEST.UnitB.pas',
|
|
LinesToStr([
|
|
'uses TEST.UnitA;',
|
|
'type TTestB = class(TTestA);'
|
|
]),
|
|
''
|
|
);
|
|
StartProgram(true);
|
|
Add('uses TEST.UnitA;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestDottedUnitNameImpl',
|
|
LinesToStr([
|
|
'']),
|
|
LinesToStr([ // this.$init
|
|
'']) );
|
|
CheckUnit('TEST.UnitA.pas',
|
|
LinesToStr([
|
|
'rtl.module("TEST.UnitA", ["system"], function () {',
|
|
' var $mod = this;',
|
|
' rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' });',
|
|
' rtl.createClass($mod, "TTestA", $mod.TObject, function () {',
|
|
' });',
|
|
'}, ["TEST.UnitB"]);'
|
|
]));
|
|
CheckUnit('TEST.UnitB.pas',
|
|
LinesToStr([
|
|
'rtl.module("TEST.UnitB", ["system","TEST.UnitA"], function () {',
|
|
' var $mod = this;',
|
|
' rtl.createClass($mod, "TTestB", pas["TEST.UnitA"].TTestA, function () {',
|
|
' });',
|
|
'});'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestDottedUnitExpr;
|
|
begin
|
|
AddModuleWithIntfImplSrc('NS2.SubNs2.Unit2.pas',
|
|
LinesToStr([
|
|
'procedure DoIt;'
|
|
]),
|
|
'procedure DoIt; begin end;');
|
|
|
|
FFilename:='Ns1.SubNs1.Test1.pp';
|
|
StartProgram(true);
|
|
Add('uses Ns2.sUbnS2.unIt2;');
|
|
Add('implementation');
|
|
Add('var');
|
|
Add(' i: longint;');
|
|
Add('begin');
|
|
Add(' ns2.subns2.unit2.doit;');
|
|
Add(' i:=Ns1.SubNS1.TEst1.i;');
|
|
ConvertProgram;
|
|
CheckSource('TestDottedUnitExpr',
|
|
LinesToStr([
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([ // this.$init
|
|
'pas["NS2.SubNs2.Unit2"].DoIt();',
|
|
'$mod.i = $mod.i;',
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.Test_ModeFPCFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$mode FPC}');
|
|
Add('begin');
|
|
SetExpectedScannerError('Invalid mode: "FPC"',nErrInvalidMode);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.Test_ModeSwitchCBlocksFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch cblocks-}');
|
|
Add('begin');
|
|
SetExpectedScannerError('Invalid mode switch: "cblocks-"',nErrInvalidModeSwitch);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestUnit_UseSystem;
|
|
begin
|
|
StartUnit(true);
|
|
Add([
|
|
'interface',
|
|
'var i: integer;',
|
|
'implementation']);
|
|
ConvertUnit;
|
|
CheckSource('TestUnit_UseSystem',
|
|
LinesToStr([
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestUnit_Intf1Impl2Intf1;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit1.pp',
|
|
LinesToStr([
|
|
'type number = longint;']),
|
|
LinesToStr([
|
|
'uses test1;',
|
|
'procedure DoIt;',
|
|
'begin',
|
|
' i:=3;',
|
|
'end;']));
|
|
|
|
StartUnit(true);
|
|
Add([
|
|
'interface',
|
|
'uses unit1;',
|
|
'var i: number;',
|
|
'implementation']);
|
|
ConvertUnit;
|
|
CheckSource('TestUnit_Intf1Impl2Intf1',
|
|
LinesToStr([
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestIncludeVersion;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var s: string;',
|
|
'begin',
|
|
' s:={$I %line%};',
|
|
' s:={$I %currentroutine%};',
|
|
' s:={$I %pas2jsversion%};',
|
|
' s:={$I %pas2jstarget%};',
|
|
' s:={$I %pas2jstargetos%};',
|
|
' s:={$I %pas2jstargetcpu%};',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestIncludeVersion',
|
|
'this.s="";',
|
|
LinesToStr([
|
|
'$mod.s = "5";',
|
|
'$mod.s = "<anonymous>";',
|
|
'$mod.s = "Comp.Ver.tcmodules";',
|
|
'$mod.s = "Browser";',
|
|
'$mod.s = "Browser";',
|
|
'$mod.s = "ECMAScript5";',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestVarInt;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var MyI: longint;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestVarInt','this.MyI=0;','');
|
|
end;
|
|
|
|
procedure TTestModule.TestVarBaseTypes;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' i: longint;');
|
|
Add(' s: string;');
|
|
Add(' c: char;');
|
|
Add(' b: boolean;');
|
|
Add(' d: double;');
|
|
Add(' i2: longint = 3;');
|
|
Add(' s2: string = ''foo'';');
|
|
Add(' c2: char = ''4'';');
|
|
Add(' b2: boolean = true;');
|
|
Add(' d2: double = 5.6;');
|
|
Add(' i3: longint = $707;');
|
|
Add(' i4: nativeint = 4503599627370495;');
|
|
Add(' i5: nativeint = -4503599627370496;');
|
|
Add(' i6: nativeint = $fffffffffffff;');
|
|
Add(' i7: nativeint = -$10000000000000;');
|
|
Add(' i8: byte = 00;');
|
|
Add(' u8: nativeuint = $fffffffffffff;');
|
|
Add(' u9: nativeuint = $0000000000000;');
|
|
Add(' u10: nativeuint = $00ff00;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestVarBaseTypes',
|
|
LinesToStr([
|
|
'this.i = 0;',
|
|
'this.s = "";',
|
|
'this.c = "";',
|
|
'this.b = false;',
|
|
'this.d = 0.0;',
|
|
'this.i2 = 3;',
|
|
'this.s2 = "foo";',
|
|
'this.c2 = "4";',
|
|
'this.b2 = true;',
|
|
'this.d2 = 5.6;',
|
|
'this.i3 = 0x707;',
|
|
'this.i4 = 4503599627370495;',
|
|
'this.i5 = -4503599627370496;',
|
|
'this.i6 = 0xfffffffffffff;',
|
|
'this.i7 =-0x10000000000000;',
|
|
'this.i8 = 0;',
|
|
'this.u8 = 0xfffffffffffff;',
|
|
'this.u9 = 0x0;',
|
|
'this.u10 = 0xff00;'
|
|
]),
|
|
'');
|
|
end;
|
|
|
|
procedure TTestModule.TestBaseTypeSingleFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var s: single;');
|
|
SetExpectedPasResolverError('identifier not found "single"',PasResolveEval.nIdentifierNotFound);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestBaseTypeExtendedFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var e: extended;');
|
|
SetExpectedPasResolverError('identifier not found "extended"',PasResolveEval.nIdentifierNotFound);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestConstBaseTypes;
|
|
begin
|
|
StartProgram(false);
|
|
Add('const');
|
|
Add(' i: longint = 3;');
|
|
Add(' s: string = ''foo'';');
|
|
Add(' c: char = ''4'';');
|
|
Add(' b: boolean = true;');
|
|
Add(' d: double = 5.6;');
|
|
Add(' e = low(word);');
|
|
Add(' f = high(word);');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestVarBaseTypes',
|
|
LinesToStr([
|
|
'this.i=3;',
|
|
'this.s="foo";',
|
|
'this.c="4";',
|
|
'this.b=true;',
|
|
'this.d=5.6;',
|
|
'this.e = 0;',
|
|
'this.f = 65535;'
|
|
]),
|
|
'');
|
|
end;
|
|
|
|
procedure TTestModule.TestAliasTypeRef;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' a=longint;');
|
|
Add(' b=a;');
|
|
Add('var');
|
|
Add(' c: A;');
|
|
Add(' d: B;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestAliasTypeRef',
|
|
LinesToStr([ // statements
|
|
'this.c = 0;',
|
|
'this.d = 0;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestTypeCast_BaseTypes;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' i: longint;',
|
|
' b: boolean;',
|
|
' d: double;',
|
|
' s: string;',
|
|
' c: char;',
|
|
'begin',
|
|
' i:=longint(i);',
|
|
' i:=longint(b);',
|
|
' b:=boolean(b);',
|
|
' b:=boolean(i);',
|
|
' d:=double(d);',
|
|
' d:=double(i);',
|
|
' s:=string(s);',
|
|
' s:=string(c);',
|
|
' c:=char(c);',
|
|
' c:=char(i);',
|
|
' c:=char(65);',
|
|
' c:=char(#10);',
|
|
' c:=char(#$E000);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestAliasTypeRef',
|
|
LinesToStr([ // statements
|
|
'this.i = 0;',
|
|
'this.b = false;',
|
|
'this.d = 0.0;',
|
|
'this.s = "";',
|
|
'this.c = "";',
|
|
'']),
|
|
LinesToStr([ // this.$main
|
|
'$mod.i = $mod.i;',
|
|
'$mod.i = ($mod.b ? 1 : 0);',
|
|
'$mod.b = $mod.b;',
|
|
'$mod.b = $mod.i != 0;',
|
|
'$mod.d = $mod.d;',
|
|
'$mod.d = $mod.i;',
|
|
'$mod.s = $mod.s;',
|
|
'$mod.s = $mod.c;',
|
|
'$mod.c = $mod.c;',
|
|
'$mod.c = String.fromCharCode($mod.i);',
|
|
'$mod.c = "A";',
|
|
'$mod.c = "\n";',
|
|
'$mod.c = "";',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestTypeCast_AliasBaseTypes;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TYesNo = boolean;');
|
|
Add(' TFloat = double;');
|
|
Add(' TCaption = string;');
|
|
Add(' TChar = char;');
|
|
Add('var');
|
|
Add(' i: integer;');
|
|
Add(' b: TYesNo;');
|
|
Add(' d: TFloat;');
|
|
Add(' s: TCaption;');
|
|
Add(' c: TChar;');
|
|
Add('begin');
|
|
Add(' i:=integer(i);');
|
|
Add(' i:=integer(b);');
|
|
Add(' b:=TYesNo(b);');
|
|
Add(' b:=TYesNo(i);');
|
|
Add(' d:=TFloat(d);');
|
|
Add(' d:=TFloat(i);');
|
|
Add(' s:=TCaption(s);');
|
|
Add(' s:=TCaption(c);');
|
|
Add(' c:=TChar(c);');
|
|
ConvertProgram;
|
|
CheckSource('TestAliasTypeRef',
|
|
LinesToStr([ // statements
|
|
'this.i = 0;',
|
|
'this.b = false;',
|
|
'this.d = 0.0;',
|
|
'this.s = "";',
|
|
'this.c = "";',
|
|
'']),
|
|
LinesToStr([ // this.$main
|
|
'$mod.i = $mod.i;',
|
|
'$mod.i = ($mod.b ? 1 : 0);',
|
|
'$mod.b = $mod.b;',
|
|
'$mod.b = $mod.i != 0;',
|
|
'$mod.d = $mod.d;',
|
|
'$mod.d = $mod.i;',
|
|
'$mod.s = $mod.s;',
|
|
'$mod.s = $mod.c;',
|
|
'$mod.c = $mod.c;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestEmptyProc;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure Test;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestEmptyProc',
|
|
LinesToStr([ // statements
|
|
'this.Test = function () {',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcOneParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure ProcA(i: longint);');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('begin');
|
|
Add(' PROCA(3);');
|
|
ConvertProgram;
|
|
CheckSource('TestProcOneParam',
|
|
LinesToStr([ // statements
|
|
'this.ProcA = function (i) {',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
'$mod.ProcA(3);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestFunctionWithoutParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('function FuncA: longint;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('var i: longint;');
|
|
Add('begin');
|
|
Add(' I:=FUNCA();');
|
|
Add(' I:=FUNCA;');
|
|
Add(' FUNCA();');
|
|
Add(' FUNCA;');
|
|
ConvertProgram;
|
|
CheckSource('TestProcWithoutParams',
|
|
LinesToStr([ // statements
|
|
'this.FuncA = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
'};',
|
|
'this.i=0;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
'$mod.i=$mod.FuncA();',
|
|
'$mod.i=$mod.FuncA();',
|
|
'$mod.FuncA();',
|
|
'$mod.FuncA();'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcedureWithoutParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure ProcA;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('begin');
|
|
Add(' PROCA();');
|
|
Add(' PROCA;');
|
|
ConvertProgram;
|
|
CheckSource('TestProcWithoutParams',
|
|
LinesToStr([ // statements
|
|
'this.ProcA = function () {',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
'$mod.ProcA();',
|
|
'$mod.ProcA();'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestIncDec;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure DoIt(var i: longint);',
|
|
'begin',
|
|
' inc(i);',
|
|
' inc(i,2);',
|
|
'end;',
|
|
'var',
|
|
' Bar: longint;',
|
|
'begin',
|
|
' inc(bar);',
|
|
' inc(bar,2);',
|
|
' dec(bar);',
|
|
' dec(bar,3);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestIncDec',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (i) {',
|
|
' i.set(i.get()+1);',
|
|
' i.set(i.get()+2);',
|
|
'};',
|
|
'this.Bar = 0;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
'$mod.Bar+=1;',
|
|
'$mod.Bar+=2;',
|
|
'$mod.Bar-=1;',
|
|
'$mod.Bar-=3;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestAssignments;
|
|
begin
|
|
StartProgram(false);
|
|
Parser.Options:=Parser.Options+[po_cassignments];
|
|
Add('var');
|
|
Add(' Bar:longint;');
|
|
Add('begin');
|
|
Add(' bar:=3;');
|
|
Add(' bar+=4;');
|
|
Add(' bar-=5;');
|
|
Add(' bar*=6;');
|
|
ConvertProgram;
|
|
CheckSource('TestAssignments',
|
|
LinesToStr([ // statements
|
|
'this.Bar = 0;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
'$mod.Bar=3;',
|
|
'$mod.Bar+=4;',
|
|
'$mod.Bar-=5;',
|
|
'$mod.Bar*=6;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestArithmeticOperators1;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' vA,vB,vC:longint;');
|
|
Add('begin');
|
|
Add(' va:=1;');
|
|
Add(' vb:=va+va;');
|
|
Add(' vb:=va div vb;');
|
|
Add(' vb:=va mod vb;');
|
|
Add(' vb:=va+va*vb+va div vb;');
|
|
Add(' vc:=-va;');
|
|
Add(' va:=va-vb;');
|
|
Add(' vb:=va;');
|
|
Add(' if va<vb then vc:=va else vc:=vb;');
|
|
ConvertProgram;
|
|
CheckSource('TestArithmeticOperators1',
|
|
LinesToStr([ // statements
|
|
'this.vA = 0;',
|
|
'this.vB = 0;',
|
|
'this.vC = 0;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
'$mod.vA = 1;',
|
|
'$mod.vB = $mod.vA + $mod.vA;',
|
|
'$mod.vB = Math.floor($mod.vA / $mod.vB);',
|
|
'$mod.vB = $mod.vA % $mod.vB;',
|
|
'$mod.vB = ($mod.vA + ($mod.vA * $mod.vB)) + Math.floor($mod.vA / $mod.vB);',
|
|
'$mod.vC = -$mod.vA;',
|
|
'$mod.vA = $mod.vA - $mod.vB;',
|
|
'$mod.vB = $mod.vA;',
|
|
'if ($mod.vA < $mod.vB){ $mod.vC = $mod.vA } else $mod.vC = $mod.vB;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestLogicalOperators;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' vA,vB,vC:boolean;');
|
|
Add('begin');
|
|
Add(' va:=vb and vc;');
|
|
Add(' va:=vb or vc;');
|
|
Add(' va:=vb xor vc;');
|
|
Add(' va:=true and vc;');
|
|
Add(' va:=(vb and vc) or (va and vb);');
|
|
Add(' va:=not vb;');
|
|
ConvertProgram;
|
|
CheckSource('TestLogicalOperators',
|
|
LinesToStr([ // statements
|
|
'this.vA = false;',
|
|
'this.vB = false;',
|
|
'this.vC = false;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
'$mod.vA = $mod.vB && $mod.vC;',
|
|
'$mod.vA = $mod.vB || $mod.vC;',
|
|
'$mod.vA = $mod.vB ^ $mod.vC;',
|
|
'$mod.vA = true && $mod.vC;',
|
|
'$mod.vA = ($mod.vB && $mod.vC) || ($mod.vA && $mod.vB);',
|
|
'$mod.vA = !$mod.vB;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestBitwiseOperators;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' vA,vB,vC:longint;');
|
|
Add('begin');
|
|
Add(' va:=vb and vc;');
|
|
Add(' va:=vb or vc;');
|
|
Add(' va:=vb xor vc;');
|
|
Add(' va:=vb shl vc;');
|
|
Add(' va:=vb shr vc;');
|
|
Add(' va:=3 and vc;');
|
|
Add(' va:=(vb and vc) or (va and vb);');
|
|
Add(' va:=not vb;');
|
|
ConvertProgram;
|
|
CheckSource('TestBitwiseOperators',
|
|
LinesToStr([ // statements
|
|
'this.vA = 0;',
|
|
'this.vB = 0;',
|
|
'this.vC = 0;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
'$mod.vA = $mod.vB & $mod.vC;',
|
|
'$mod.vA = $mod.vB | $mod.vC;',
|
|
'$mod.vA = $mod.vB ^ $mod.vC;',
|
|
'$mod.vA = $mod.vB << $mod.vC;',
|
|
'$mod.vA = $mod.vB >>> $mod.vC;',
|
|
'$mod.vA = 3 & $mod.vC;',
|
|
'$mod.vA = ($mod.vB & $mod.vC) | ($mod.vA & $mod.vB);',
|
|
'$mod.vA = ~$mod.vB;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestPrgProcVar;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure Proc1;');
|
|
Add('type');
|
|
Add(' t1=longint;');
|
|
Add('var');
|
|
Add(' vA:t1;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestPrgProcVar',
|
|
LinesToStr([ // statements
|
|
'this.Proc1 = function () {',
|
|
' var vA=0;',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestUnitProcVar;
|
|
begin
|
|
StartUnit(false);
|
|
Add('interface');
|
|
Add('');
|
|
Add('type tA=string; // unit scope');
|
|
Add('procedure Proc1;');
|
|
Add('');
|
|
Add('implementation');
|
|
Add('');
|
|
Add('procedure Proc1;');
|
|
Add('type tA=longint; // local proc scope');
|
|
Add('var v1:tA; // using local tA');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('var v2:tA; // using interface tA');
|
|
ConvertUnit;
|
|
CheckSource('TestUnitProcVar',
|
|
LinesToStr([ // statements
|
|
'var $impl = $mod.$impl;',
|
|
'this.Proc1 = function () {',
|
|
' var v1 = 0;',
|
|
'};',
|
|
'']),
|
|
// this.$init
|
|
'',
|
|
// implementation
|
|
LinesToStr([
|
|
'$impl.v2 = "";',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestImplProc;
|
|
begin
|
|
StartUnit(false);
|
|
Add('interface');
|
|
Add('');
|
|
Add('procedure Proc1;');
|
|
Add('');
|
|
Add('implementation');
|
|
Add('');
|
|
Add('procedure Proc1; begin end;');
|
|
Add('procedure Proc2; begin end;');
|
|
Add('initialization');
|
|
Add(' Proc1;');
|
|
Add(' Proc2;');
|
|
ConvertUnit;
|
|
CheckSource('TestImplProc',
|
|
LinesToStr([ // statements
|
|
'var $impl = $mod.$impl;',
|
|
'this.Proc1 = function () {',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // this.$init
|
|
'$mod.Proc1();',
|
|
'$impl.Proc2();',
|
|
'']),
|
|
LinesToStr([ // implementation
|
|
'$impl.Proc2 = function () {',
|
|
'};',
|
|
''])
|
|
);
|
|
end;
|
|
|
|
procedure TTestModule.TestFunctionResult;
|
|
begin
|
|
StartProgram(false);
|
|
Add('function Func1: longint;');
|
|
Add('begin');
|
|
Add(' Result:=3;');
|
|
Add(' Func1:=4;');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestFunctionResult',
|
|
LinesToStr([ // statements
|
|
'this.Func1 = function () {',
|
|
' var Result = 0;',
|
|
' Result = 3;',
|
|
' Result = 4;',
|
|
' return Result;',
|
|
'};'
|
|
]),
|
|
'');
|
|
end;
|
|
|
|
procedure TTestModule.TestNestedProc;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var vInUnit: longint;',
|
|
'function DoIt(pA,pD: longint): longint;',
|
|
'var',
|
|
' vB: longint;',
|
|
' vC: longint;',
|
|
' function Nesty(pA: longint): longint; ',
|
|
' var vB: longint;',
|
|
' begin',
|
|
' Result:=pa+vb+vc+pd+vInUnit;',
|
|
' nesty:=3;',
|
|
' doit:=4;',
|
|
' exit;',
|
|
' end;',
|
|
'begin',
|
|
' Result:=pa+vb+vc;',
|
|
' doit:=6;',
|
|
' exit;',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestNestedProc',
|
|
LinesToStr([ // statements
|
|
'this.vInUnit = 0;',
|
|
'this.DoIt = function (pA, pD) {',
|
|
' var Result = 0;',
|
|
' var vB = 0;',
|
|
' var vC = 0;',
|
|
' function Nesty(pA) {',
|
|
' var Result$1 = 0;',
|
|
' var vB = 0;',
|
|
' Result$1 = (((pA + vB) + vC) + pD) + $mod.vInUnit;',
|
|
' Result$1 = 3;',
|
|
' Result = 4;',
|
|
' return Result$1;',
|
|
' return Result$1;',
|
|
' };',
|
|
' Result = (pA + vB) + vC;',
|
|
' Result = 6;',
|
|
' return Result;',
|
|
' return Result;',
|
|
'};'
|
|
]),
|
|
'');
|
|
end;
|
|
|
|
procedure TTestModule.TestNestedProc_ResultString;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'function DoIt: string;',
|
|
' function Nesty: string; ',
|
|
' begin',
|
|
' nesty:=#65#66;',
|
|
' nesty[1]:=#67;',
|
|
' doit:=#68;',
|
|
' doit[2]:=#69;',
|
|
' end;',
|
|
'begin',
|
|
' doit:=#70;',
|
|
' doit[3]:=#71;',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestNestedProc_ResultString',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function () {',
|
|
' var Result = "";',
|
|
' function Nesty() {',
|
|
' var Result$1 = "";',
|
|
' Result$1 = "AB";',
|
|
' Result$1 = rtl.setCharAt(Result$1, 0, "C");',
|
|
' Result = "D";',
|
|
' Result = rtl.setCharAt(Result, 1, "E");',
|
|
' return Result$1;',
|
|
' };',
|
|
' Result = "F";',
|
|
' Result = rtl.setCharAt(Result, 2, "G");',
|
|
' return Result;',
|
|
'};'
|
|
]),
|
|
'');
|
|
end;
|
|
|
|
procedure TTestModule.TestForwardProc;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure FuncA(Bar: longint); forward;');
|
|
Add('procedure FuncB(Bar: longint);');
|
|
Add('begin');
|
|
Add(' funca(bar);');
|
|
Add('end;');
|
|
Add('procedure funca(bar: longint);');
|
|
Add('begin');
|
|
Add(' if bar=3 then ;');
|
|
Add('end;');
|
|
Add('begin');
|
|
Add(' funca(4);');
|
|
Add(' funcb(5);');
|
|
ConvertProgram;
|
|
CheckSource('TestForwardProc',
|
|
LinesToStr([ // statements'
|
|
'this.FuncB = function (Bar) {',
|
|
' $mod.FuncA(Bar);',
|
|
'};',
|
|
'this.FuncA = function (Bar) {',
|
|
' if (Bar === 3);',
|
|
'};'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.FuncA(4);',
|
|
'$mod.FuncB(5);'
|
|
])
|
|
);
|
|
end;
|
|
|
|
procedure TTestModule.TestNestedForwardProc;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure FuncA;');
|
|
Add(' procedure FuncB(i: longint); forward;');
|
|
Add(' procedure FuncC(i: longint);');
|
|
Add(' begin');
|
|
Add(' funcb(i);');
|
|
Add(' end;');
|
|
Add(' procedure FuncB(i: longint);');
|
|
Add(' begin');
|
|
Add(' if i=3 then ;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
Add(' funcc(4)');
|
|
Add('end;');
|
|
Add('begin');
|
|
Add(' funca;');
|
|
ConvertProgram;
|
|
CheckSource('TestNestedForwardProc',
|
|
LinesToStr([ // statements'
|
|
'this.FuncA = function () {',
|
|
' function FuncC(i) {',
|
|
' FuncB(i);',
|
|
' };',
|
|
' function FuncB(i) {',
|
|
' if (i === 3);',
|
|
' };',
|
|
' FuncC(4);',
|
|
'};'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.FuncA();'
|
|
])
|
|
);
|
|
end;
|
|
|
|
procedure TTestModule.TestAssignFunctionResult;
|
|
begin
|
|
StartProgram(false);
|
|
Add('function Func1: longint;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('var i: longint;');
|
|
Add('begin');
|
|
Add(' i:=func1();');
|
|
Add(' i:=func1()+func1();');
|
|
ConvertProgram;
|
|
CheckSource('TestAssignFunctionResult',
|
|
LinesToStr([ // statements
|
|
'this.Func1 = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
'};',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.i = $mod.Func1();',
|
|
'$mod.i = $mod.Func1() + $mod.Func1();'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestFunctionResultInCondition;
|
|
begin
|
|
StartProgram(false);
|
|
Add('function Func1: longint;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('function Func2: boolean;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('var i: longint;');
|
|
Add('begin');
|
|
Add(' if func2 then ;');
|
|
Add(' if i=func1() then ;');
|
|
Add(' if i=func1 then ;');
|
|
ConvertProgram;
|
|
CheckSource('TestFunctionResultInCondition',
|
|
LinesToStr([ // statements
|
|
'this.Func1 = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
'};',
|
|
'this.Func2 = function () {',
|
|
' var Result = false;',
|
|
' return Result;',
|
|
'};',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([
|
|
'if ($mod.Func2());',
|
|
'if ($mod.i === $mod.Func1());',
|
|
'if ($mod.i === $mod.Func1());'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestFunctionResultInForLoop;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'function Func1(a: array of longint): longint;',
|
|
'begin',
|
|
' for Result:=High(a) downto Low(a) do if a[Result]=0 then exit;',
|
|
' for Result in a do if a[Result]=0 then exit;',
|
|
'end;',
|
|
'begin',
|
|
' Func1([1,2,3])']);
|
|
ConvertProgram;
|
|
CheckSource('TestFunctionResultInForLoop',
|
|
LinesToStr([ // statements
|
|
'this.Func1 = function (a) {',
|
|
' var Result = 0;',
|
|
' for (var $l1 = rtl.length(a) - 1; $l1 >= 0; $l1--) {',
|
|
' Result = $l1;',
|
|
' if (a[Result] === 0) return Result;',
|
|
' };',
|
|
' for (var $in2 = a, $l3 = 0, $end4 = rtl.length($in2) - 1; $l3 <= $end4; $l3++) {',
|
|
' Result = $in2[$l3];',
|
|
' if (a[Result] === 0) return Result;',
|
|
' };',
|
|
' return Result;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.Func1([1, 2, 3]);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestFunctionResultInTypeCast;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'function GetInt: longint;',
|
|
'begin',
|
|
'end;',
|
|
'begin',
|
|
' if Byte(GetInt)=0 then ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestFunctionResultInTypeCast',
|
|
LinesToStr([ // statements
|
|
'this.GetInt = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'if (($mod.GetInt() & 255) === 0) ;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestExit;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure ProcA;');
|
|
Add('begin');
|
|
Add(' exit;');
|
|
Add('end;');
|
|
Add('function FuncB: longint;');
|
|
Add('begin');
|
|
Add(' exit;');
|
|
Add(' exit(3);');
|
|
Add('end;');
|
|
Add('function FuncC: string;');
|
|
Add('begin');
|
|
Add(' exit;');
|
|
Add(' exit(''a'');');
|
|
Add(' exit(''abc'');');
|
|
Add('end;');
|
|
Add('begin');
|
|
Add(' exit;');
|
|
Add(' exit(1);');
|
|
ConvertProgram;
|
|
CheckSource('TestExit',
|
|
LinesToStr([ // statements
|
|
'this.ProcA = function () {',
|
|
' return;',
|
|
'};',
|
|
'this.FuncB = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' return 3;',
|
|
' return Result;',
|
|
'};',
|
|
'this.FuncC = function () {',
|
|
' var Result = "";',
|
|
' return Result;',
|
|
' return "a";',
|
|
' return "abc";',
|
|
' return Result;',
|
|
'};'
|
|
]),
|
|
LinesToStr([
|
|
'return;',
|
|
'return 1;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestBreak;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' i: longint;',
|
|
'begin',
|
|
' repeat',
|
|
' break;',
|
|
' until true;',
|
|
' while true do',
|
|
' break;',
|
|
' for i:=1 to 2 do',
|
|
' break;']);
|
|
ConvertProgram;
|
|
CheckSource('TestBreak',
|
|
LinesToStr([ // statements
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([
|
|
'do {',
|
|
' break;',
|
|
'} while (!true);',
|
|
'while (true) break;',
|
|
'for ($mod.i = 1; $mod.i <= 2; $mod.i++) break;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestBreakAsVar;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure DoIt(break: boolean);',
|
|
'begin',
|
|
' if break then ;',
|
|
'end;',
|
|
'var',
|
|
' break: boolean;',
|
|
'begin',
|
|
' if break then ;']);
|
|
ConvertProgram;
|
|
CheckSource('TestBreakAsVar',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (Break) {',
|
|
' if (Break) ;',
|
|
'};',
|
|
'this.Break = false;',
|
|
'']),
|
|
LinesToStr([
|
|
'if($mod.Break) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestContinue;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var i: longint;');
|
|
Add('begin');
|
|
Add(' repeat');
|
|
Add(' continue;');
|
|
Add(' until true;');
|
|
Add(' while true do');
|
|
Add(' continue;');
|
|
Add(' for i:=1 to 2 do');
|
|
Add(' continue;');
|
|
ConvertProgram;
|
|
CheckSource('TestContinue',
|
|
LinesToStr([ // statements
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([
|
|
'do {',
|
|
' continue;',
|
|
'} while (!true);',
|
|
'while (true) continue;',
|
|
'for ($mod.i = 1; $mod.i <= 2; $mod.i++) continue;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_External;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure Foo; external name ''console.log'';');
|
|
Add('function Bar: longint; external name ''get.item'';');
|
|
Add('function Bla(s: string): longint; external name ''apply.something'';');
|
|
Add('var');
|
|
Add(' i: longint;');
|
|
Add('begin');
|
|
Add(' Foo;');
|
|
Add(' i:=Bar;');
|
|
Add(' i:=Bla(''abc'');');
|
|
ConvertProgram;
|
|
CheckSource('TestProc_External',
|
|
LinesToStr([ // statements
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([
|
|
'console.log();',
|
|
'$mod.i = get.item();',
|
|
'$mod.i = apply.something("abc");'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_ExternalOtherUnit;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit2.pas',
|
|
LinesToStr([
|
|
'procedure Now; external name ''Date.now'';',
|
|
'procedure DoIt;'
|
|
]),
|
|
'procedure doit; begin end;');
|
|
|
|
StartUnit(true);
|
|
Add('interface');
|
|
Add('uses unit2;');
|
|
Add('implementation');
|
|
Add('begin');
|
|
Add(' now;');
|
|
Add(' now();');
|
|
Add(' uNit2.now;');
|
|
Add(' uNit2.now();');
|
|
Add(' doit;');
|
|
Add(' uNit2.doit;');
|
|
ConvertUnit;
|
|
CheckSource('TestProc_ExternalOtherUnit',
|
|
LinesToStr([
|
|
'']),
|
|
LinesToStr([
|
|
'Date.now();',
|
|
'Date.now();',
|
|
'Date.now();',
|
|
'Date.now();',
|
|
'pas.unit2.DoIt();',
|
|
'pas.unit2.DoIt();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_Asm;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'function DoIt: longint;',
|
|
'begin;',
|
|
' asm',
|
|
' { a:{ b:{}, c:[]}, d:''1'' };',
|
|
' end;',
|
|
' asm console.log(); end;',
|
|
' asm',
|
|
' s = "'' ";',
|
|
' s = ''" '';',
|
|
' s = s + "world" + "''";',
|
|
' // end',
|
|
' s = ''end'';',
|
|
' s = "end";',
|
|
' end;',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestProc_Asm',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function () {',
|
|
' var Result = 0;',
|
|
' { a:{ b:{}, c:[]}, d:''1'' };',
|
|
' console.log();',
|
|
' s = "'' ";',
|
|
' s = ''" '';',
|
|
' s = s + "world" + "''";',
|
|
' // end',
|
|
' s = ''end'';',
|
|
' s = "end";',
|
|
' return Result;',
|
|
'};'
|
|
]),
|
|
LinesToStr([
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_Assembler;
|
|
begin
|
|
StartProgram(false);
|
|
Add('function DoIt: longint; assembler;');
|
|
Add('asm');
|
|
Add('{ a:{ b:{}, c:[]}, d:''1'' };');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestProc_Assembler',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function () {',
|
|
' { a:{ b:{}, c:[]}, d:''1'' };',
|
|
'};'
|
|
]),
|
|
LinesToStr([
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_VarParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type integer = longint;');
|
|
Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
|
|
Add('var vJ: integer;');
|
|
Add('begin');
|
|
Add(' vg:=vg+1;');
|
|
Add(' vj:=vh+2;');
|
|
Add(' vi:=vi+3;');
|
|
Add(' doit(vg,vg,vg);');
|
|
Add(' doit(vh,vh,vj);');
|
|
Add(' doit(vi,vi,vi);');
|
|
Add(' doit(vj,vj,vj);');
|
|
Add('end;');
|
|
Add('var i: integer;');
|
|
Add('begin');
|
|
Add(' doit(i,i,i);');
|
|
ConvertProgram;
|
|
CheckSource('TestProc_VarParam',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
' var vJ = 0;',
|
|
' vG = vG + 1;',
|
|
' vJ = vH + 2;',
|
|
' vI.set(vI.get()+3);',
|
|
' $mod.DoIt(vG, vG, {',
|
|
' get: function () {',
|
|
' return vG;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vG = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(vH, vH, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(vI.get(), vI.get(), vI);',
|
|
' $mod.DoIt(vJ, vJ, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
'};',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt($mod.i,$mod.i,{',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_VarParamString;
|
|
begin
|
|
StartProgram(false);
|
|
Add(['type TCaption = string;',
|
|
'procedure DoIt(vA: TCaption; var vB: TCaption; out vC: TCaption);',
|
|
'var c: char;',
|
|
'begin',
|
|
' va[1]:=c;',
|
|
' vb[2]:=c;',
|
|
' vc[3]:=c;',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestProc_VarParamString',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (vA,vB,vC) {',
|
|
' var c = "";',
|
|
' vA = rtl.setCharAt(vA, 0, c);',
|
|
' vB.set(rtl.setCharAt(vB.get(), 1, c));',
|
|
' vC.set(rtl.setCharAt(vC.get(), 2, c));',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_VarParamV;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure Inc2(var i: longint);',
|
|
'begin',
|
|
' i:=i+2;',
|
|
'end;',
|
|
'procedure DoIt(v: longint);',
|
|
'var p: array of longint;',
|
|
'begin',
|
|
' Inc2(v);',
|
|
' Inc2(p[v]);',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestProc_VarParamV',
|
|
LinesToStr([ // statements
|
|
'this.Inc2 = function (i) {',
|
|
' i.set(i.get()+2);',
|
|
'};',
|
|
'this.DoIt = function (v) {',
|
|
' var p = [];',
|
|
' $mod.Inc2({get: function () {',
|
|
' return v;',
|
|
' }, set: function (w) {',
|
|
' v = w;',
|
|
' }});',
|
|
' $mod.Inc2({',
|
|
' a: v,',
|
|
' p: p,',
|
|
' get: function () {',
|
|
' return this.p[this.a];',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p[this.a] = v;',
|
|
' }',
|
|
' });',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_Overload;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure DoIt(vI: longint); begin end;');
|
|
Add('procedure DoIt(vI, vJ: longint); begin end;');
|
|
Add('procedure DoIt(vD: double); begin end;');
|
|
Add('begin');
|
|
Add(' DoIt(1);');
|
|
Add(' DoIt(2,3);');
|
|
Add(' DoIt(4.5);');
|
|
ConvertProgram;
|
|
CheckSource('TestProcedureOverload',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (vI) {',
|
|
'};',
|
|
'this.DoIt$1 = function (vI, vJ) {',
|
|
'};',
|
|
'this.DoIt$2 = function (vD) {',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.DoIt(1);',
|
|
'$mod.DoIt$1(2, 3);',
|
|
'$mod.DoIt$2(4.5);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_OverloadForward;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure DoIt(vI: longint); forward;');
|
|
Add('procedure DoIt(vI, vJ: longint); begin end;');
|
|
Add('procedure doit(vi: longint); begin end;');
|
|
Add('begin');
|
|
Add(' doit(1);');
|
|
Add(' doit(2,3);');
|
|
ConvertProgram;
|
|
CheckSource('TestProcedureOverloadForward',
|
|
LinesToStr([ // statements
|
|
'this.DoIt$1 = function (vI, vJ) {',
|
|
'};',
|
|
'this.DoIt = function (vI) {',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.DoIt(1);',
|
|
'$mod.DoIt$1(2, 3);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_OverloadIntfImpl;
|
|
begin
|
|
StartUnit(false);
|
|
Add('interface');
|
|
Add('procedure DoIt(vI: longint);');
|
|
Add('procedure DoIt(vI, vJ: longint);');
|
|
Add('implementation');
|
|
Add('procedure DoIt(vI, vJ, vK, vL, vM: longint); forward;');
|
|
Add('procedure DoIt(vI, vJ, vK: longint); begin end;');
|
|
Add('procedure DoIt(vi: longint); begin end;');
|
|
Add('procedure DoIt(vI, vJ, vK, vL: longint); begin end;');
|
|
Add('procedure DoIt(vi, vj: longint); begin end;');
|
|
Add('procedure DoIt(vi, vj, vk, vl, vm: longint); begin end;');
|
|
Add('begin');
|
|
Add(' doit(1);');
|
|
Add(' doit(2,3);');
|
|
Add(' doit(4,5,6);');
|
|
Add(' doit(7,8,9,10);');
|
|
Add(' doit(11,12,13,14,15);');
|
|
ConvertUnit;
|
|
CheckSource('TestProcedureOverloadUnit',
|
|
LinesToStr([ // statements
|
|
'var $impl = $mod.$impl;',
|
|
'this.DoIt = function (vI) {',
|
|
'};',
|
|
'this.DoIt$1 = function (vI, vJ) {',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // this.$init
|
|
'$mod.DoIt(1);',
|
|
'$mod.DoIt$1(2, 3);',
|
|
'$impl.DoIt$3(4,5,6);',
|
|
'$impl.DoIt$4(7,8,9,10);',
|
|
'$impl.DoIt$2(11,12,13,14,15);',
|
|
'']),
|
|
LinesToStr([ // implementation
|
|
'$impl.DoIt$3 = function (vI, vJ, vK) {',
|
|
'};',
|
|
'$impl.DoIt$4 = function (vI, vJ, vK, vL) {',
|
|
'};',
|
|
'$impl.DoIt$2 = function (vI, vJ, vK, vL, vM) {',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_OverloadNested;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure DoIt(vA: longint); overload; forward;',
|
|
'procedure DoIt(vB, vC: longint); overload;',
|
|
'begin // 2 param overload',
|
|
' doit(1);',
|
|
' doit(1,2);',
|
|
'end;',
|
|
'procedure doit(vA: longint);',
|
|
' procedure DoIt(vA, vB, vC: longint); overload; forward;',
|
|
' procedure DoIt(vA, vB, vC, vD: longint); overload;',
|
|
' begin // 4 param overload',
|
|
' doit(1);',
|
|
' doit(1,2);',
|
|
' doit(1,2,3);',
|
|
' doit(1,2,3,4);',
|
|
' end;',
|
|
' procedure doit(vA, vB, vC: longint);',
|
|
' procedure DoIt(vA, vB, vC, vD, vE: longint); overload; forward;',
|
|
' procedure DoIt(vA, vB, vC, vD, vE, vF: longint); overload;',
|
|
' begin // 6 param overload',
|
|
' doit(1);',
|
|
' doit(1,2);',
|
|
' doit(1,2,3);',
|
|
' doit(1,2,3,4);',
|
|
' doit(1,2,3,4,5);',
|
|
' doit(1,2,3,4,5,6);',
|
|
' end;',
|
|
' procedure doit(vA, vB, vC, vD, vE: longint);',
|
|
' begin // 5 param overload',
|
|
' doit(1);',
|
|
' doit(1,2);',
|
|
' doit(1,2,3);',
|
|
' doit(1,2,3,4);',
|
|
' doit(1,2,3,4,5);',
|
|
' doit(1,2,3,4,5,6);',
|
|
' end;',
|
|
' begin // 3 param overload',
|
|
' doit(1);',
|
|
' doit(1,2);',
|
|
' doit(1,2,3);',
|
|
' doit(1,2,3,4);',
|
|
' doit(1,2,3,4,5);',
|
|
' doit(1,2,3,4,5,6);',
|
|
' end;',
|
|
'begin // 1 param overload',
|
|
' doit(1);',
|
|
' doit(1,2);',
|
|
' doit(1,2,3);',
|
|
' doit(1,2,3,4);',
|
|
'end;',
|
|
'begin // main',
|
|
' doit(1);',
|
|
' doit(1,2);']);
|
|
ConvertProgram;
|
|
CheckSource('TestProcedureOverloadNested',
|
|
LinesToStr([ // statements
|
|
'this.DoIt$1 = function (vB, vC) {',
|
|
' $mod.DoIt(1);',
|
|
' $mod.DoIt$1(1, 2);',
|
|
'};',
|
|
'this.DoIt = function (vA) {',
|
|
' function DoIt$3(vA, vB, vC, vD) {',
|
|
' $mod.DoIt(1);',
|
|
' $mod.DoIt$1(1, 2);',
|
|
' DoIt$2(1, 2, 3);',
|
|
' DoIt$3(1, 2, 3, 4);',
|
|
' };',
|
|
' function DoIt$2(vA, vB, vC) {',
|
|
' function DoIt$5(vA, vB, vC, vD, vE, vF) {',
|
|
' $mod.DoIt(1);',
|
|
' $mod.DoIt$1(1, 2);',
|
|
' DoIt$2(1, 2, 3);',
|
|
' DoIt$3(1, 2, 3, 4);',
|
|
' DoIt$4(1, 2, 3, 4, 5);',
|
|
' DoIt$5(1, 2, 3, 4, 5, 6);',
|
|
' };',
|
|
' function DoIt$4(vA, vB, vC, vD, vE) {',
|
|
' $mod.DoIt(1);',
|
|
' $mod.DoIt$1(1, 2);',
|
|
' DoIt$2(1, 2, 3);',
|
|
' DoIt$3(1, 2, 3, 4);',
|
|
' DoIt$4(1, 2, 3, 4, 5);',
|
|
' DoIt$5(1, 2, 3, 4, 5, 6);',
|
|
' };',
|
|
' $mod.DoIt(1);',
|
|
' $mod.DoIt$1(1, 2);',
|
|
' DoIt$2(1, 2, 3);',
|
|
' DoIt$3(1, 2, 3, 4);',
|
|
' DoIt$4(1, 2, 3, 4, 5);',
|
|
' DoIt$5(1, 2, 3, 4, 5, 6);',
|
|
' };',
|
|
' $mod.DoIt(1);',
|
|
' $mod.DoIt$1(1, 2);',
|
|
' DoIt$2(1, 2, 3);',
|
|
' DoIt$3(1, 2, 3, 4);',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.DoIt(1);',
|
|
'$mod.DoIt$1(1, 2);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_OverloadUnitCycle;
|
|
begin
|
|
AddModuleWithIntfImplSrc('Unit2.pas',
|
|
LinesToStr([
|
|
'type',
|
|
' TObject = class',
|
|
' procedure DoIt(b: boolean); virtual; abstract;',
|
|
' procedure DoIt(i: longint); virtual; abstract;',
|
|
' end;',
|
|
'']),
|
|
'uses test1;');
|
|
StartUnit(true);
|
|
Add([
|
|
'interface',
|
|
'uses unit2;',
|
|
'type',
|
|
' TEagle = class(TObject)',
|
|
' procedure DoIt(b: boolean); override;',
|
|
' procedure DoIt(i: longint); override;',
|
|
' end;',
|
|
'implementation',
|
|
'procedure TEagle.DoIt(b: boolean); begin end;',
|
|
'procedure TEagle.DoIt(i: longint); begin end;',
|
|
'']);
|
|
ConvertUnit;
|
|
CheckSource('TestProc_OverloadUnitCycle',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TEagle", pas.Unit2.TObject, function () {',
|
|
' this.DoIt = function (b) {',
|
|
' };',
|
|
' this.DoIt$1 = function (i) {',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
'',
|
|
LinesToStr([
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_Varargs;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure ProcA(i:longint); varargs; external name ''ProcA'';',
|
|
'procedure ProcB; varargs; external name ''ProcB'';',
|
|
'procedure ProcC(i: longint = 17); varargs; external name ''ProcC'';',
|
|
'function GetIt: longint; begin end;',
|
|
'begin',
|
|
' ProcA(1);',
|
|
' ProcA(1,2);',
|
|
' ProcA(1,2.0);',
|
|
' ProcA(1,2,3);',
|
|
' ProcA(1,''2'');',
|
|
' ProcA(2,'''');',
|
|
' ProcA(3,false);',
|
|
' ProcB;',
|
|
' ProcB();',
|
|
' ProcB(4);',
|
|
' ProcB(''foo'');',
|
|
' ProcC;',
|
|
' ProcC();',
|
|
' ProcC(4);',
|
|
' ProcC(5,''foo'');',
|
|
' ProcB(GetIt);',
|
|
' ProcB(GetIt());',
|
|
' ProcB(GetIt,GetIt());']);
|
|
ConvertProgram;
|
|
CheckSource('TestProc_Varargs',
|
|
LinesToStr([ // statements
|
|
'this.GetIt = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'ProcA(1);',
|
|
'ProcA(1, 2);',
|
|
'ProcA(1, 2.0);',
|
|
'ProcA(1, 2, 3);',
|
|
'ProcA(1, "2");',
|
|
'ProcA(2, "");',
|
|
'ProcA(3, false);',
|
|
'ProcB();',
|
|
'ProcB();',
|
|
'ProcB(4);',
|
|
'ProcB("foo");',
|
|
'ProcC(17);',
|
|
'ProcC(17);',
|
|
'ProcC(4);',
|
|
'ProcC(5, "foo");',
|
|
'ProcB($mod.GetIt());',
|
|
'ProcB($mod.GetIt());',
|
|
'ProcB($mod.GetIt(), $mod.GetIt());',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_ConstOrder;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'const A = 3;',
|
|
'const B = A+1;',
|
|
'procedure DoIt;',
|
|
'const C = A+1;',
|
|
'const D = B+1;',
|
|
'const E = D+C+B+A;',
|
|
'begin',
|
|
'end;',
|
|
'begin'
|
|
]);
|
|
ConvertProgram;
|
|
CheckSource('TestProc_ConstOrder',
|
|
LinesToStr([ // statements
|
|
'this.A = 3;',
|
|
'this.B = 3 + 1;',
|
|
'var C = 3 + 1;',
|
|
'var D = 4 + 1;',
|
|
'var E = ((5 + 4) + 4) + 3;',
|
|
'this.DoIt = function () {',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_DuplicateConst;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'const A = 1;',
|
|
'procedure DoIt;',
|
|
'const A = 2;',
|
|
' procedure SubIt;',
|
|
' const A = 21;',
|
|
' begin',
|
|
' end;',
|
|
'begin',
|
|
'end;',
|
|
'procedure DoSome;',
|
|
'const A = 3;',
|
|
'begin',
|
|
'end;',
|
|
'begin'
|
|
]);
|
|
ConvertProgram;
|
|
CheckSource('TestProc_DuplicateConst',
|
|
LinesToStr([ // statements
|
|
'this.A = 1;',
|
|
'var A$1 = 2;',
|
|
'var A$2 = 21;',
|
|
'this.DoIt = function () {',
|
|
' function SubIt() {',
|
|
' };',
|
|
'};',
|
|
'var A$3 = 3;',
|
|
'this.DoSome = function () {',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_LocalVarAbsolute;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' Index: longint;',
|
|
' procedure DoAbs(Item: pointer);',
|
|
' end;',
|
|
'procedure TObject.DoAbs(Item: pointer);',
|
|
'var',
|
|
' o: TObject absolute Item;',
|
|
'begin',
|
|
' if o.Index<o.Index then o.Index:=o.Index;',
|
|
'end;',
|
|
'procedure DoIt(i: longint; p: pointer);',
|
|
'var',
|
|
' d: double absolute i;',
|
|
' s: string absolute d;',
|
|
' oi: TObject absolute i;',
|
|
' op: TObject absolute p;',
|
|
'begin',
|
|
' if d=d then d:=d;',
|
|
' if s=s then s:=s;',
|
|
' if oi.Index<oi.Index then oi.Index:=oi.Index;',
|
|
' if op.Index=op.Index then op.Index:=op.Index;',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestProc_LocalVarAbsolute',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.Index = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoAbs = function (Item) {',
|
|
' if (Item.Index < Item.Index) Item.Index = Item.Index;',
|
|
' };',
|
|
'});',
|
|
'this.DoIt = function (i, p) {',
|
|
' if (i === i) i = i;',
|
|
' if (i === i) i = i;',
|
|
' if (i.Index < i.Index) i.Index = i.Index;',
|
|
' if (p.Index === p.Index) p.Index = p.Index;',
|
|
'};'
|
|
]),
|
|
LinesToStr([
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_ReservedWords;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure Date(ArrayBuffer: longint);',
|
|
'const',
|
|
' NaN: longint = 3;',
|
|
'var',
|
|
' &Boolean: longint;',
|
|
' procedure Error(ArrayBuffer: longint);',
|
|
' begin',
|
|
' end;',
|
|
'begin',
|
|
' Nan:=&bOolean;',
|
|
'end;',
|
|
'begin',
|
|
' Date(1);']);
|
|
ConvertProgram;
|
|
CheckSource('TestProc_ReservedWords',
|
|
LinesToStr([ // statements
|
|
'var naN = 3;',
|
|
'this.Date = function (arrayBuffer) {',
|
|
' var boolean = 0;',
|
|
' function error(arrayBuffer) {',
|
|
' };',
|
|
' naN = boolean;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
' $mod.Date(1);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestEnum_Name;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type TMyEnum = (Red, Green, Blue);');
|
|
Add('var e: TMyEnum;');
|
|
Add('var f: TMyEnum = Blue;');
|
|
Add('begin');
|
|
Add(' e:=green;');
|
|
Add(' e:=default(TMyEnum);');
|
|
ConvertProgram;
|
|
CheckSource('TestEnumName',
|
|
LinesToStr([ // statements
|
|
'this.TMyEnum = {',
|
|
' "0":"Red",',
|
|
' Red:0,',
|
|
' "1":"Green",',
|
|
' Green:1,',
|
|
' "2":"Blue",',
|
|
' Blue:2',
|
|
' };',
|
|
'this.e = 0;',
|
|
'this.f = $mod.TMyEnum.Blue;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.e=$mod.TMyEnum.Green;',
|
|
'$mod.e=$mod.TMyEnum.Red;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestEnum_Number;
|
|
begin
|
|
Converter.Options:=Converter.Options+[coEnumNumbers];
|
|
StartProgram(false);
|
|
Add('type TMyEnum = (Red, Green);');
|
|
Add('var');
|
|
Add(' e: TMyEnum;');
|
|
Add(' f: TMyEnum = Green;');
|
|
Add(' i: longint;');
|
|
Add('begin');
|
|
Add(' e:=green;');
|
|
Add(' i:=longint(e);');
|
|
ConvertProgram;
|
|
CheckSource('TestEnumNumber',
|
|
LinesToStr([ // statements
|
|
'this.TMyEnum = {',
|
|
' "0":"Red",',
|
|
' Red:0,',
|
|
' "1":"Green",',
|
|
' Green:1',
|
|
' };',
|
|
'this.e = 0;',
|
|
'this.f = 1;',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.e=1;',
|
|
'$mod.i=$mod.e;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestEnum_ConstFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type TMyEnum = (Red = 100, Green = 101);',
|
|
'var',
|
|
' e: TMyEnum;',
|
|
' f: TMyEnum = Green;',
|
|
'begin',
|
|
' e:=green;']);
|
|
SetExpectedPasResolverError('not yet implemented: Red:TPasEnumValue [20180126202434] enum const',3002);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestEnum_Functions;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type TMyEnum = (Red, Green);',
|
|
'var',
|
|
' e: TMyEnum;',
|
|
' i: longint;',
|
|
' s: string;',
|
|
' b: boolean;',
|
|
'begin',
|
|
' i:=ord(red);',
|
|
' i:=ord(green);',
|
|
' i:=ord(e);',
|
|
' i:=ord(b);',
|
|
' e:=low(tmyenum);',
|
|
' e:=low(e);',
|
|
' b:=low(boolean);',
|
|
' e:=high(tmyenum);',
|
|
' e:=high(e);',
|
|
' b:=high(boolean);',
|
|
' e:=pred(green);',
|
|
' e:=pred(e);',
|
|
' b:=pred(b);',
|
|
' e:=succ(red);',
|
|
' e:=succ(e);',
|
|
' b:=succ(b);',
|
|
' e:=tmyenum(1);',
|
|
' e:=tmyenum(i);',
|
|
' s:=str(e);',
|
|
' str(e,s);',
|
|
' str(red,s);',
|
|
' s:=str(e:3);',
|
|
' writestr(s,e:3,red);',
|
|
' e:=TMyEnum(i);',
|
|
' i:=longint(e);']);
|
|
ConvertProgram;
|
|
CheckSource('TestEnum_Functions',
|
|
LinesToStr([ // statements
|
|
'this.TMyEnum = {',
|
|
' "0":"Red",',
|
|
' Red:0,',
|
|
' "1":"Green",',
|
|
' Green:1',
|
|
' };',
|
|
'this.e = 0;',
|
|
'this.i = 0;',
|
|
'this.s = "";',
|
|
'this.b = false;',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.i=$mod.TMyEnum.Red;',
|
|
'$mod.i=$mod.TMyEnum.Green;',
|
|
'$mod.i=$mod.e;',
|
|
'$mod.i=$mod.b+0;',
|
|
'$mod.e=$mod.TMyEnum.Red;',
|
|
'$mod.e=$mod.TMyEnum.Red;',
|
|
'$mod.b=false;',
|
|
'$mod.e=$mod.TMyEnum.Green;',
|
|
'$mod.e=$mod.TMyEnum.Green;',
|
|
'$mod.b=true;',
|
|
'$mod.e=$mod.TMyEnum.Green-1;',
|
|
'$mod.e=$mod.e-1;',
|
|
'$mod.b=false;',
|
|
'$mod.e=$mod.TMyEnum.Red+1;',
|
|
'$mod.e=$mod.e+1;',
|
|
'$mod.b=true;',
|
|
'$mod.e=1;',
|
|
'$mod.e=$mod.i;',
|
|
'$mod.s = $mod.TMyEnum[$mod.e];',
|
|
'$mod.s = $mod.TMyEnum[$mod.e];',
|
|
'$mod.s = $mod.TMyEnum[$mod.TMyEnum.Red];',
|
|
'$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3);',
|
|
'$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3)+$mod.TMyEnum[$mod.TMyEnum.Red];',
|
|
'$mod.e=$mod.i;',
|
|
'$mod.i=$mod.e;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestEnum_AsParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type TEnum = (Red,Blue);');
|
|
Add('procedure DoIt(vG: TEnum; const vH: TEnum; var vI: TEnum);');
|
|
Add('var vJ: TEnum;');
|
|
Add('begin');
|
|
Add(' vg:=vg;');
|
|
Add(' vj:=vh;');
|
|
Add(' vi:=vi;');
|
|
Add(' doit(vg,vg,vg);');
|
|
Add(' doit(vh,vh,vj);');
|
|
Add(' doit(vi,vi,vi);');
|
|
Add(' doit(vj,vj,vj);');
|
|
Add('end;');
|
|
Add('var i: TEnum;');
|
|
Add('begin');
|
|
Add(' doit(i,i,i);');
|
|
ConvertProgram;
|
|
CheckSource('TestEnum_AsParams',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "Red",',
|
|
' Red: 0,',
|
|
' "1": "Blue",',
|
|
' Blue: 1',
|
|
'};',
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
' var vJ = 0;',
|
|
' vG = vG;',
|
|
' vJ = vH;',
|
|
' vI.set(vI.get());',
|
|
' $mod.DoIt(vG, vG, {',
|
|
' get: function () {',
|
|
' return vG;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vG = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(vH, vH, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(vI.get(), vI.get(), vI);',
|
|
' $mod.DoIt(vJ, vJ, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
'};',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt($mod.i,$mod.i,{',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestEnumRange_Array;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (Red, Green, Blue);',
|
|
' TEnumRg = green..blue;',
|
|
' TArr = array[TEnumRg] of byte;',
|
|
' TArr2 = array[green..blue] of byte;',
|
|
'var',
|
|
' a: TArr;',
|
|
' b: TArr = (3,4);',
|
|
' c: TArr2 = (5,6);',
|
|
'begin',
|
|
' a[green] := b[blue];',
|
|
' c[green] := c[blue];',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestEnumRange_Array',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "Red",',
|
|
' Red: 0,',
|
|
' "1": "Green",',
|
|
' Green: 1,',
|
|
' "2": "Blue",',
|
|
' Blue: 2',
|
|
'};',
|
|
'this.a = rtl.arraySetLength(null, 0, 2);',
|
|
'this.b = [3, 4];',
|
|
'this.c = [5, 6];',
|
|
'']),
|
|
LinesToStr([
|
|
' $mod.a[$mod.TEnum.Green - 1] = $mod.b[$mod.TEnum.Blue - 1];',
|
|
' $mod.c[$mod.TEnum.Green - 1] = $mod.c[$mod.TEnum.Blue - 1];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestEnum_ForIn;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (Red, Green, Blue);',
|
|
' TEnumRg = green..blue;',
|
|
' TArr = array[TEnum] of byte;',
|
|
' TArrRg = array[TEnumRg] of byte;',
|
|
'var',
|
|
' e: TEnum;',
|
|
' a1: TArr = (3,4,5);',
|
|
' a2: TArrRg = (11,12);',
|
|
' b: byte;',
|
|
'begin',
|
|
' for e in TEnum do ;',
|
|
' for e in TEnumRg do ;',
|
|
' for e in TArr do ;',
|
|
' for e in TArrRg do ;',
|
|
' for b in a1 do ;',
|
|
' for b in a2 do ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestEnum_ForIn',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "Red",',
|
|
' Red: 0,',
|
|
' "1": "Green",',
|
|
' Green: 1,',
|
|
' "2": "Blue",',
|
|
' Blue: 2',
|
|
'};',
|
|
'this.e = 0;',
|
|
'this.a1 = [3, 4, 5];',
|
|
'this.a2 = [11, 12];',
|
|
'this.b = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
|
|
' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
|
|
' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
|
|
' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
|
|
' for (var $in1 = $mod.a1, $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) $mod.b = $in1[$l2];',
|
|
' for (var $in4 = $mod.a2, $l5 = 0, $end6 = rtl.length($in4) - 1; $l5 <= $end6; $l5++) $mod.b = $in4[$l5];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestEnum_ScopedNumber;
|
|
begin
|
|
Converter.Options:=Converter.Options+[coEnumNumbers];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (Red, Green);',
|
|
'var',
|
|
' e: TEnum;',
|
|
'begin',
|
|
' e:=TEnum.Green;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestEnum_ScopedNumber',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "Red",',
|
|
' Red: 0,',
|
|
' "1": "Green",',
|
|
' Green: 1',
|
|
'};',
|
|
'this.e = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.e = 1;']));
|
|
end;
|
|
|
|
procedure TTestModule.TestEnum_InFunction;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure DoIt;',
|
|
'type',
|
|
' TEnum = (Red, Green, Blue);',
|
|
' procedure Sub;',
|
|
' type',
|
|
' TEnumSub = (Left, Right);',
|
|
' var',
|
|
' es: TEnumSub;',
|
|
' begin',
|
|
' es:=Left;',
|
|
' end;',
|
|
'var',
|
|
' e, e2: TEnum;',
|
|
'begin',
|
|
' if e in [red,blue] then e2:=e;',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestEnum_InFunction',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function () {',
|
|
' var TEnum = {',
|
|
' "0":"Red",',
|
|
' Red:0,',
|
|
' "1":"Green",',
|
|
' Green:1,',
|
|
' "2":"Blue",',
|
|
' Blue:2',
|
|
' };',
|
|
' function Sub() {',
|
|
' var TEnumSub = {',
|
|
' "0": "Left",',
|
|
' Left: 0,',
|
|
' "1": "Right",',
|
|
' Right: 1',
|
|
' };',
|
|
' var es = 0;',
|
|
' es = TEnumSub.Left;',
|
|
' };',
|
|
' var e = 0;',
|
|
' var e2 = 0;',
|
|
' if (e in rtl.createSet(TEnum.Red, TEnum.Blue)) e2 = e;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_Enum;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TColor = (Red, Green, Blue);',
|
|
' TColors = set of TColor;',
|
|
'var',
|
|
' c: TColor;',
|
|
' s: TColors;',
|
|
' t: TColors = [];',
|
|
' u: TColors = [Red];',
|
|
'begin',
|
|
' s:=[];',
|
|
' s:=[Green];',
|
|
' s:=[Green,Blue];',
|
|
' s:=[Red..Blue];',
|
|
' s:=[Red,Green..Blue];',
|
|
' s:=[Red,c];',
|
|
' s:=t;',
|
|
' s:=default(TColors);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestSet',
|
|
LinesToStr([ // statements
|
|
'this.TColor = {',
|
|
' "0":"Red",',
|
|
' Red:0,',
|
|
' "1":"Green",',
|
|
' Green:1,',
|
|
' "2":"Blue",',
|
|
' Blue:2',
|
|
' };',
|
|
'this.c = 0;',
|
|
'this.s = {};',
|
|
'this.t = {};',
|
|
'this.u = rtl.createSet($mod.TColor.Red);'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.s={};',
|
|
'$mod.s=rtl.createSet($mod.TColor.Green);',
|
|
'$mod.s=rtl.createSet($mod.TColor.Green,$mod.TColor.Blue);',
|
|
'$mod.s=rtl.createSet(null,$mod.TColor.Red,$mod.TColor.Blue);',
|
|
'$mod.s=rtl.createSet($mod.TColor.Red,null,$mod.TColor.Green,$mod.TColor.Blue);',
|
|
'$mod.s=rtl.createSet($mod.TColor.Red,$mod.c);',
|
|
'$mod.s=rtl.refSet($mod.t);',
|
|
'$mod.s={};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_Operators;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TColor = (Red, Green, Blue);');
|
|
Add(' TColors = set of tcolor;');
|
|
Add('var');
|
|
Add(' vC: TColor;');
|
|
Add(' vS: TColors;');
|
|
Add(' vT: TColors;');
|
|
Add(' vU: TColors;');
|
|
Add(' B: boolean;');
|
|
Add('begin');
|
|
Add(' include(vs,green);');
|
|
Add(' exclude(vs,vc);');
|
|
Add(' vs:=vt+vu;');
|
|
Add(' vs:=vt+[red];');
|
|
Add(' vs:=[red]+vt;');
|
|
Add(' vs:=[red]+[green];');
|
|
Add(' vs:=vt-vu;');
|
|
Add(' vs:=vt-[red];');
|
|
Add(' vs:=[red]-vt;');
|
|
Add(' vs:=[red]-[green];');
|
|
Add(' vs:=vt*vu;');
|
|
Add(' vs:=vt*[red];');
|
|
Add(' vs:=[red]*vt;');
|
|
Add(' vs:=[red]*[green];');
|
|
Add(' vs:=vt><vu;');
|
|
Add(' vs:=vt><[red];');
|
|
Add(' vs:=[red]><vt;');
|
|
Add(' vs:=[red]><[green];');
|
|
Add(' b:=vt=vu;');
|
|
Add(' b:=vt=[red];');
|
|
Add(' b:=[red]=vt;');
|
|
Add(' b:=[red]=[green];');
|
|
Add(' b:=vt<>vu;');
|
|
Add(' b:=vt<>[red];');
|
|
Add(' b:=[red]<>vt;');
|
|
Add(' b:=[red]<>[green];');
|
|
Add(' b:=vt<=vu;');
|
|
Add(' b:=vt<=[red];');
|
|
Add(' b:=[red]<=vt;');
|
|
Add(' b:=[red]<=[green];');
|
|
Add(' b:=vt>=vu;');
|
|
Add(' b:=vt>=[red];');
|
|
Add(' b:=[red]>=vt;');
|
|
Add(' b:=[red]>=[green];');
|
|
ConvertProgram;
|
|
CheckSource('TestSet_Operators',
|
|
LinesToStr([ // statements
|
|
'this.TColor = {',
|
|
' "0":"Red",',
|
|
' Red:0,',
|
|
' "1":"Green",',
|
|
' Green:1,',
|
|
' "2":"Blue",',
|
|
' Blue:2',
|
|
' };',
|
|
'this.vC = 0;',
|
|
'this.vS = {};',
|
|
'this.vT = {};',
|
|
'this.vU = {};',
|
|
'this.B = false;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.vS = rtl.includeSet($mod.vS,$mod.TColor.Green);',
|
|
'$mod.vS = rtl.excludeSet($mod.vS,$mod.vC);',
|
|
'$mod.vS = rtl.unionSet($mod.vT, $mod.vU);',
|
|
'$mod.vS = rtl.unionSet($mod.vT, rtl.createSet($mod.TColor.Red));',
|
|
'$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
|
|
'$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
|
|
'$mod.vS = rtl.diffSet($mod.vT, $mod.vU);',
|
|
'$mod.vS = rtl.diffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
|
|
'$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
|
|
'$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
|
|
'$mod.vS = rtl.intersectSet($mod.vT, $mod.vU);',
|
|
'$mod.vS = rtl.intersectSet($mod.vT, rtl.createSet($mod.TColor.Red));',
|
|
'$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
|
|
'$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
|
|
'$mod.vS = rtl.symDiffSet($mod.vT, $mod.vU);',
|
|
'$mod.vS = rtl.symDiffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
|
|
'$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
|
|
'$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
|
|
'$mod.B = rtl.eqSet($mod.vT, $mod.vU);',
|
|
'$mod.B = rtl.eqSet($mod.vT, rtl.createSet($mod.TColor.Red));',
|
|
'$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
|
|
'$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
|
|
'$mod.B = rtl.neSet($mod.vT, $mod.vU);',
|
|
'$mod.B = rtl.neSet($mod.vT, rtl.createSet($mod.TColor.Red));',
|
|
'$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
|
|
'$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
|
|
'$mod.B = rtl.leSet($mod.vT, $mod.vU);',
|
|
'$mod.B = rtl.leSet($mod.vT, rtl.createSet($mod.TColor.Red));',
|
|
'$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
|
|
'$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
|
|
'$mod.B = rtl.geSet($mod.vT, $mod.vU);',
|
|
'$mod.B = rtl.geSet($mod.vT, rtl.createSet($mod.TColor.Red));',
|
|
'$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
|
|
'$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_Operator_In;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TColor = (Red, Green, Blue);');
|
|
Add(' TColors = set of tcolor;');
|
|
Add('var');
|
|
Add(' vC: tcolor;');
|
|
Add(' vT: tcolors;');
|
|
Add(' B: boolean;');
|
|
Add('begin');
|
|
Add(' b:=red in vt;');
|
|
Add(' b:=vc in vt;');
|
|
Add(' b:=green in [red..blue];');
|
|
Add(' b:=vc in [red..blue];');
|
|
Add(' ');
|
|
Add(' if red in vt then ;');
|
|
Add(' while vC in vt do ;');
|
|
Add(' repeat');
|
|
Add(' until vC in vt;');
|
|
ConvertProgram;
|
|
CheckSource('TestSet_Operator_In',
|
|
LinesToStr([ // statements
|
|
'this.TColor = {',
|
|
' "0":"Red",',
|
|
' Red:0,',
|
|
' "1":"Green",',
|
|
' Green:1,',
|
|
' "2":"Blue",',
|
|
' Blue:2',
|
|
' };',
|
|
'this.vC = 0;',
|
|
'this.vT = {};',
|
|
'this.B = false;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.B = $mod.TColor.Red in $mod.vT;',
|
|
'$mod.B = $mod.vC in $mod.vT;',
|
|
'$mod.B = $mod.TColor.Green in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
|
|
'$mod.B = $mod.vC in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
|
|
'if ($mod.TColor.Red in $mod.vT) ;',
|
|
'while ($mod.vC in $mod.vT) {',
|
|
'};',
|
|
'do {',
|
|
'} while (!($mod.vC in $mod.vT));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_Functions;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TMyEnum = (Red, Green);');
|
|
Add(' TMyEnums = set of TMyEnum;');
|
|
Add('var');
|
|
Add(' e: TMyEnum;');
|
|
Add(' s: TMyEnums;');
|
|
Add('begin');
|
|
Add(' e:=Low(TMyEnums);');
|
|
Add(' e:=Low(s);');
|
|
Add(' e:=High(TMyEnums);');
|
|
Add(' e:=High(s);');
|
|
ConvertProgram;
|
|
CheckSource('TestSetFunctions',
|
|
LinesToStr([ // statements
|
|
'this.TMyEnum = {',
|
|
' "0":"Red",',
|
|
' Red:0,',
|
|
' "1":"Green",',
|
|
' Green:1',
|
|
' };',
|
|
'this.e = 0;',
|
|
'this.s = {};'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.e=$mod.TMyEnum.Red;',
|
|
'$mod.e=$mod.TMyEnum.Red;',
|
|
'$mod.e=$mod.TMyEnum.Green;',
|
|
'$mod.e=$mod.TMyEnum.Green;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_PassAsArgClone;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TMyEnum = (Red, Green);');
|
|
Add(' TMyEnums = set of TMyEnum;');
|
|
Add('procedure DoDefault(s: tmyenums); begin end;');
|
|
Add('procedure DoConst(const s: tmyenums); begin end;');
|
|
Add('var');
|
|
Add(' aSet: tmyenums;');
|
|
Add('begin');
|
|
Add(' dodefault(aset);');
|
|
Add(' doconst(aset);');
|
|
ConvertProgram;
|
|
CheckSource('TestSetFunctions',
|
|
LinesToStr([ // statements
|
|
'this.TMyEnum = {',
|
|
' "0":"Red",',
|
|
' Red:0,',
|
|
' "1":"Green",',
|
|
' Green:1',
|
|
' };',
|
|
'this.DoDefault = function (s) {',
|
|
'};',
|
|
'this.DoConst = function (s) {',
|
|
'};',
|
|
'this.aSet = {};'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoDefault(rtl.refSet($mod.aSet));',
|
|
'$mod.DoConst($mod.aSet);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_AsParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type TEnum = (Red,Blue);',
|
|
'type TEnums = set of TEnum;',
|
|
'function DoIt(vG: TEnums; const vH: TEnums; var vI: TEnums): TEnums;',
|
|
'var vJ: TEnums;',
|
|
'begin',
|
|
' Include(vg,red);',
|
|
' Include(result,blue);',
|
|
' vg:=vg;',
|
|
' vj:=vh;',
|
|
' vi:=vi;',
|
|
' doit(vg,vg,vg);',
|
|
' doit(vh,vh,vj);',
|
|
' doit(vi,vi,vi);',
|
|
' doit(vj,vj,vj);',
|
|
'end;',
|
|
'var i: TEnums;',
|
|
'begin',
|
|
' doit(i,i,i);']);
|
|
ConvertProgram;
|
|
CheckSource('TestSet_AsParams',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "Red",',
|
|
' Red: 0,',
|
|
' "1": "Blue",',
|
|
' Blue: 1',
|
|
'};',
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
' var Result = {};',
|
|
' var vJ = {};',
|
|
' vG = rtl.includeSet(vG, $mod.TEnum.Red);',
|
|
' Result = rtl.includeSet(Result, $mod.TEnum.Blue);',
|
|
' vG = rtl.refSet(vG);',
|
|
' vJ = rtl.refSet(vH);',
|
|
' vI.set(rtl.refSet(vI.get()));',
|
|
' $mod.DoIt(rtl.refSet(vG), vG, {',
|
|
' get: function () {',
|
|
' return vG;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vG = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(rtl.refSet(vH), vH, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(rtl.refSet(vI.get()), vI.get(), vI);',
|
|
' $mod.DoIt(rtl.refSet(vJ), vJ, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
' return Result;',
|
|
'};',
|
|
'this.i = {};'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt(rtl.refSet($mod.i),$mod.i,{',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_Property;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TEnum = (Red,Blue);');
|
|
Add(' TEnums = set of TEnum;');
|
|
Add(' TObject = class');
|
|
Add(' function GetColors: TEnums; external name ''GetColors'';');
|
|
Add(' procedure SetColors(const Value: TEnums); external name ''SetColors'';');
|
|
Add(' property Colors: TEnums read GetColors write SetColors;');
|
|
Add(' end;');
|
|
Add('procedure DoIt(i: TEnums; const j: TEnums; var k: TEnums; out l: TEnums);');
|
|
Add('begin end;');
|
|
Add('var Obj: TObject;');
|
|
Add('begin');
|
|
Add(' Include(Obj.Colors,Red);');
|
|
Add(' Exclude(Obj.Colors,Red);');
|
|
//Add(' DoIt(Obj.Colors,Obj.Colors,Obj.Colors,Obj.Colors);');
|
|
ConvertProgram;
|
|
CheckSource('TestSet_Property',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "Red",',
|
|
' Red: 0,',
|
|
' "1": "Blue",',
|
|
' Blue: 1',
|
|
'};',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.DoIt = function (i, j, k, l) {',
|
|
'};',
|
|
'this.Obj = null;',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.Obj.SetColors(rtl.includeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
|
|
'$mod.Obj.SetColors(rtl.excludeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_EnumConst;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (Red,Blue);',
|
|
' TEnums = set of TEnum;',
|
|
'const',
|
|
' Orange = red;',
|
|
'var',
|
|
' Enum: tenum;',
|
|
' Enums: tenums;',
|
|
'begin',
|
|
' Include(enums,orange);',
|
|
' Exclude(enums,orange);',
|
|
' if orange in enums then;',
|
|
' if orange in [orange,red] then;']);
|
|
ConvertProgram;
|
|
CheckSource('TestSet_EnumConst',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "Red",',
|
|
' Red: 0,',
|
|
' "1": "Blue",',
|
|
' Blue: 1',
|
|
'};',
|
|
'this.Orange = $mod.TEnum.Red;',
|
|
'this.Enum = 0;',
|
|
'this.Enums = {};',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.Enums = rtl.includeSet($mod.Enums, $mod.TEnum.Red);',
|
|
'$mod.Enums = rtl.excludeSet($mod.Enums, $mod.TEnum.Red);',
|
|
'if ($mod.TEnum.Red in $mod.Enums) ;',
|
|
'if ($mod.TEnum.Red in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Red)) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_IntConst;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnums = set of Byte;',
|
|
'const',
|
|
' Orange = 0;',
|
|
'var',
|
|
' Enum: byte;',
|
|
' Enums: tenums;',
|
|
'begin',
|
|
' Enums:=[];',
|
|
' Enums:=[0];',
|
|
' Enums:=[1..2];',
|
|
//' Include(enums,orange);',
|
|
//' Exclude(enums,orange);',
|
|
' if orange in enums then;',
|
|
' if orange in [orange,1] then;']);
|
|
ConvertProgram;
|
|
CheckSource('TestSet_IntConst',
|
|
LinesToStr([ // statements
|
|
'this.Orange = 0;',
|
|
'this.Enum = 0;',
|
|
'this.Enums = {};',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.Enums = {};',
|
|
'$mod.Enums = rtl.createSet(0);',
|
|
'$mod.Enums = rtl.createSet(null, 1, 2);',
|
|
'if (0 in $mod.Enums) ;',
|
|
'if (0 in rtl.createSet(0, 1)) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_AnonymousEnumType;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TFlags = set of (red, green);');
|
|
Add('const');
|
|
Add(' favorite = red;');
|
|
Add('var');
|
|
Add(' f: TFlags;');
|
|
Add(' i: longint;');
|
|
Add('begin');
|
|
Add(' Include(f,red);');
|
|
Add(' Include(f,favorite);');
|
|
Add(' i:=ord(red);');
|
|
Add(' i:=ord(favorite);');
|
|
Add(' i:=ord(low(TFlags));');
|
|
Add(' i:=ord(low(f));');
|
|
Add(' i:=ord(low(favorite));');
|
|
Add(' i:=ord(high(TFlags));');
|
|
Add(' i:=ord(high(f));');
|
|
Add(' i:=ord(high(favorite));');
|
|
Add(' f:=[green,favorite];');
|
|
ConvertProgram;
|
|
CheckSource('TestSet_AnonymousEnumType',
|
|
LinesToStr([ // statements
|
|
'this.TFlags$a = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "green",',
|
|
' green: 1',
|
|
'};',
|
|
'this.favorite = $mod.TFlags$a.red;',
|
|
'this.f = {};',
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
|
|
'$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
|
|
'$mod.i = $mod.TFlags$a.red;',
|
|
'$mod.i = $mod.TFlags$a.red;',
|
|
'$mod.i = $mod.TFlags$a.red;',
|
|
'$mod.i = $mod.TFlags$a.red;',
|
|
'$mod.i = $mod.TFlags$a.red;',
|
|
'$mod.i = $mod.TFlags$a.green;',
|
|
'$mod.i = $mod.TFlags$a.green;',
|
|
'$mod.i = $mod.TFlags$a.green;',
|
|
'$mod.f = rtl.createSet($mod.TFlags$a.green, $mod.TFlags$a.red);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_AnonymousEnumTypeChar;
|
|
begin
|
|
exit;
|
|
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TAtoZ = ''A''..''Z'';',
|
|
' TSetOfAZ = set of TAtoZ;',
|
|
'var',
|
|
' c: char;',
|
|
' a: TAtoZ;',
|
|
' s: TSetOfAZ = [''P'',''A''];',
|
|
' i: longint;',
|
|
'begin',
|
|
' Include(s,''S'');',
|
|
' Include(s,c);',
|
|
' Include(s,a);',
|
|
' c:=low(TAtoZ);',
|
|
' i:=ord(low(TAtoZ));',
|
|
' a:=high(TAtoZ);',
|
|
' a:=high(TSetOfAtoZ);',
|
|
' s:=[a,c,''M''];',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestSet_AnonymousEnumTypeChar',
|
|
LinesToStr([ // statements
|
|
'']),
|
|
LinesToStr([
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_ConstEnum;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (red,blue,green);',
|
|
' TEnums = set of TEnum;',
|
|
'const',
|
|
' teAny = [low(TEnum)..high(TEnum)];',
|
|
' teRedBlue = [low(TEnum)..pred(high(TEnum))];',
|
|
'var',
|
|
' e: TEnum;',
|
|
' s: TEnums;',
|
|
'begin',
|
|
' if blue in teAny then;',
|
|
' if blue in teAny+[e] then;',
|
|
' if blue in teAny+teRedBlue then;',
|
|
' if e in [red,blue] then;',
|
|
' s:=teAny;',
|
|
' s:=teAny+[e];',
|
|
' s:=[e]+teAny;',
|
|
' s:=teAny+teRedBlue;',
|
|
' s:=teAny+teRedBlue+[e];',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestSet_ConstEnum',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "blue",',
|
|
' blue: 1,',
|
|
' "2": "green",',
|
|
' green: 2',
|
|
'};',
|
|
'this.teAny = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green);',
|
|
'this.teRedBlue = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green - 1);',
|
|
'this.e = 0;',
|
|
'this.s = {};',
|
|
'']),
|
|
LinesToStr([
|
|
'if ($mod.TEnum.blue in $mod.teAny) ;',
|
|
'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, rtl.createSet($mod.e))) ;',
|
|
'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, $mod.teRedBlue)) ;',
|
|
'if ($mod.e in rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)) ;',
|
|
'$mod.s = rtl.refSet($mod.teAny);',
|
|
'$mod.s = rtl.unionSet($mod.teAny, rtl.createSet($mod.e));',
|
|
'$mod.s = rtl.unionSet(rtl.createSet($mod.e), $mod.teAny);',
|
|
'$mod.s = rtl.unionSet($mod.teAny, $mod.teRedBlue);',
|
|
'$mod.s = rtl.unionSet(rtl.unionSet($mod.teAny, $mod.teRedBlue), rtl.createSet($mod.e));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_ConstChar;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'const',
|
|
' LowChars = [''a''..''z''];',
|
|
' Chars = LowChars+[''A''..''Z''];',
|
|
'var',
|
|
' c: char;',
|
|
' s: string;',
|
|
'begin',
|
|
' if c in lowchars then ;',
|
|
' if ''a'' in lowchars then ;',
|
|
' if s[1] in lowchars then ;',
|
|
' if c in chars then ;',
|
|
' if c in [''a''..''z'',''_''] then ;',
|
|
' if ''b'' in [''a''..''z'',''_''] then ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestSet_ConstChar',
|
|
LinesToStr([ // statements
|
|
'this.LowChars = rtl.createSet(null, 97, 122);',
|
|
'this.Chars = rtl.unionSet($mod.LowChars, rtl.createSet(null, 65, 90));',
|
|
'this.c = "";',
|
|
'this.s = "";',
|
|
'']),
|
|
LinesToStr([
|
|
'if ($mod.c.charCodeAt() in $mod.LowChars) ;',
|
|
'if (97 in $mod.LowChars) ;',
|
|
'if ($mod.s.charCodeAt(0) in $mod.LowChars) ;',
|
|
'if ($mod.c.charCodeAt() in $mod.Chars) ;',
|
|
'if ($mod.c.charCodeAt() in rtl.createSet(null, 97, 122, 95)) ;',
|
|
'if (98 in rtl.createSet(null, 97, 122, 95)) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_ConstInt;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'const',
|
|
' Months = [1..12];',
|
|
' Mirror = [-12..-1]+Months;',
|
|
'var',
|
|
' i: smallint;',
|
|
'begin',
|
|
' if 3 in Months then;',
|
|
' if i in Months+[i] then;',
|
|
' if i in Months+Mirror then;',
|
|
' if i in [4..6,8] then;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestSet_ConstInt',
|
|
LinesToStr([ // statements
|
|
'this.Months = rtl.createSet(null, 1, 12);',
|
|
'this.Mirror = rtl.unionSet(rtl.createSet(null, -12, -1), $mod.Months);',
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
'if (3 in $mod.Months) ;',
|
|
'if ($mod.i in rtl.unionSet($mod.Months, rtl.createSet($mod.i))) ;',
|
|
'if ($mod.i in rtl.unionSet($mod.Months, $mod.Mirror)) ;',
|
|
'if ($mod.i in rtl.createSet(null, 4, 6, 8)) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestSet_ForIn;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (Red, Green, Blue);',
|
|
' TEnumRg = green..blue;',
|
|
' TSetOfEnum = set of TEnum;',
|
|
' TSetOfEnumRg = set of TEnumRg;',
|
|
'var',
|
|
' e, e2: TEnum;',
|
|
' er: TEnum;',
|
|
' s: TSetOfEnum;',
|
|
'begin',
|
|
' for e in TSetOfEnum do ;',
|
|
' for e in TSetOfEnumRg do ;',
|
|
' for e in [] do e2:=e;',
|
|
' for e in [red..green] do e2:=e;',
|
|
' for e in [green,blue] do e2:=e;',
|
|
' for e in [red,blue] do e2:=e;',
|
|
' for e in s do e2:=e;',
|
|
' for er in TSetOfEnumRg do ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestSet_ForIn',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0":"Red",',
|
|
' Red:0,',
|
|
' "1":"Green",',
|
|
' Green:1,',
|
|
' "2":"Blue",',
|
|
' Blue:2',
|
|
' };',
|
|
'this.e = 0;',
|
|
'this.e2 = 0;',
|
|
'this.er = 0;',
|
|
'this.s = {};',
|
|
'']),
|
|
LinesToStr([
|
|
'for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
|
|
'for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
|
|
'for ($mod.e = 0; $mod.e <= 1; $mod.e++) $mod.e2 = $mod.e;',
|
|
'for ($mod.e = 1; $mod.e <= 2; $mod.e++) $mod.e2 = $mod.e;',
|
|
'for ($mod.e in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Blue)) $mod.e2 = $mod.e;',
|
|
'for (var $l1 in $mod.s){',
|
|
' $mod.e = +$l1;',
|
|
' $mod.e2 = $mod.e;',
|
|
'};',
|
|
'for ($mod.er = 1; $mod.er <= 2; $mod.er++) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestNestBegin;
|
|
begin
|
|
StartProgram(false);
|
|
Add('begin');
|
|
Add(' begin');
|
|
Add(' begin');
|
|
Add(' end;');
|
|
Add(' begin');
|
|
Add(' if true then ;');
|
|
Add(' end;');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestNestBegin',
|
|
'',
|
|
'if (true) ;');
|
|
end;
|
|
|
|
procedure TTestModule.TestUnitImplVars;
|
|
begin
|
|
StartUnit(false);
|
|
Add('interface');
|
|
Add('implementation');
|
|
Add('var');
|
|
Add(' V1:longint;');
|
|
Add(' V2:longint = 3;');
|
|
Add(' V3:string = ''abc'';');
|
|
ConvertUnit;
|
|
CheckSource('TestUnitImplVars',
|
|
LinesToStr([ // statements
|
|
'var $impl = $mod.$impl;',
|
|
'']),
|
|
'', // this.$init
|
|
LinesToStr([ // implementation
|
|
'$impl.V1 = 0;',
|
|
'$impl.V2 = 3;',
|
|
'$impl.V3 = "abc";',
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestUnitImplConsts;
|
|
begin
|
|
StartUnit(false);
|
|
Add('interface');
|
|
Add('implementation');
|
|
Add('const');
|
|
Add(' v1 = 3;');
|
|
Add(' v2:longint = 4;');
|
|
Add(' v3:string = ''abc'';');
|
|
ConvertUnit;
|
|
CheckSource('TestUnitImplConsts',
|
|
LinesToStr([ // statements
|
|
'var $impl = $mod.$impl;',
|
|
'']),
|
|
'', // this.$init
|
|
LinesToStr([ // implementation
|
|
'$impl.v1 = 3;',
|
|
'$impl.v2 = 4;',
|
|
'$impl.v3 = "abc";',
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestUnitImplRecord;
|
|
begin
|
|
StartUnit(false);
|
|
Add('interface');
|
|
Add('implementation');
|
|
Add('type');
|
|
Add(' TMyRecord = record');
|
|
Add(' i: longint;');
|
|
Add(' end;');
|
|
Add('var aRec: TMyRecord;');
|
|
Add('initialization');
|
|
Add(' arec.i:=3;');
|
|
ConvertUnit;
|
|
CheckSource('TestUnitImplRecord',
|
|
LinesToStr([ // statements
|
|
'var $impl = $mod.$impl;',
|
|
'']),
|
|
// this.$init
|
|
'$impl.aRec.i = 3;',
|
|
LinesToStr([ // implementation
|
|
'$impl.TMyRecord = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.i === b.i;',
|
|
' };',
|
|
'};',
|
|
'$impl.aRec = new $impl.TMyRecord();',
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestRenameJSNameConflict;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var apply: longint;');
|
|
Add('var bind: longint;');
|
|
Add('var call: longint;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestRenameJSNameConflict',
|
|
LinesToStr([ // statements
|
|
'this.Apply = 0;',
|
|
'this.Bind = 0;',
|
|
'this.Call = 0;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestLocalConst;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure DoIt;');
|
|
Add('const');
|
|
Add(' cA: longint = 1;');
|
|
Add(' cB = 2;');
|
|
Add(' procedure Sub;');
|
|
Add(' const');
|
|
Add(' csA = 3;');
|
|
Add(' cB: double = 4;');
|
|
Add(' begin');
|
|
Add(' cb:=cb+csa;');
|
|
Add(' ca:=ca+csa+5;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
Add(' ca:=ca+cb+6;');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestLocalConst',
|
|
LinesToStr([
|
|
'var cA = 1;',
|
|
'var cB = 2;',
|
|
'var csA = 3;',
|
|
'var cB$1 = 4;',
|
|
'this.DoIt = function () {',
|
|
' function Sub() {',
|
|
' cB$1 = cB$1 + 3;',
|
|
' cA = (cA + 3) + 5;',
|
|
' };',
|
|
' cA = (cA + 2) + 6;',
|
|
'};'
|
|
]),
|
|
LinesToStr([
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestVarExternal;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' NaN: double; external name ''Global.NaN'';');
|
|
Add(' d: double;');
|
|
Add('begin');
|
|
Add(' d:=NaN;');
|
|
ConvertProgram;
|
|
CheckSource('TestVarExternal',
|
|
LinesToStr([
|
|
'this.d = 0.0;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.d = Global.NaN;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestVarExternalOtherUnit;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit2.pas',
|
|
LinesToStr([
|
|
'var NaN: double; external name ''Global.NaN'';',
|
|
'var iV: longint;'
|
|
]),
|
|
'');
|
|
|
|
StartUnit(true);
|
|
Add('interface');
|
|
Add('uses unit2;');
|
|
Add('implementation');
|
|
Add('var');
|
|
Add(' d: double;');
|
|
Add(' i: longint; external name ''$i'';');
|
|
Add('begin');
|
|
Add(' d:=nan;');
|
|
Add(' d:=uNit2.nan;');
|
|
Add(' d:=test1.d;');
|
|
Add(' i:=iv;');
|
|
Add(' i:=uNit2.iv;');
|
|
Add(' i:=test1.i;');
|
|
ConvertUnit;
|
|
CheckSource('TestVarExternalOtherUnit',
|
|
LinesToStr([
|
|
'var $impl = $mod.$impl;',
|
|
'']),
|
|
LinesToStr([ // this.$init
|
|
'$impl.d = Global.NaN;',
|
|
'$impl.d = Global.NaN;',
|
|
'$impl.d = $impl.d;',
|
|
'$i = pas.unit2.iV;',
|
|
'$i = pas.unit2.iV;',
|
|
'$i = $i;',
|
|
'']),
|
|
LinesToStr([ // implementation
|
|
'$impl.d = 0.0;',
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestVarAbsoluteFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' a: longint;',
|
|
' b: longword absolute a;',
|
|
'begin']);
|
|
SetExpectedPasResolverError('Invalid variable modifier "absolute"',nInvalidVariableModifier);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestConstExternal;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'const',
|
|
' PI: double; external name ''Global.PI'';',
|
|
' Tau = 2*pi;',
|
|
'var d: double;',
|
|
'begin',
|
|
' d:=pi;',
|
|
' d:=tau+pi;']);
|
|
ConvertProgram;
|
|
CheckSource('TestConstExternal',
|
|
LinesToStr([
|
|
'this.Tau = 2*Global.PI;',
|
|
'this.d = 0.0;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.d = Global.PI;',
|
|
'$mod.d = $mod.Tau + Global.PI;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestDouble;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TDateTime = double;',
|
|
'const',
|
|
' a = TDateTime(2.7);',
|
|
' b = a + TDateTime(1.7);',
|
|
' c = 0.9 + 0.1;',
|
|
' f0_1 = 0.1;',
|
|
' f0_3 = 0.3;',
|
|
' fn0_1 = -0.1;',
|
|
' fn0_3 = -0.3;',
|
|
' fn0_003 = -0.003;',
|
|
' fn0_123456789 = -0.123456789;',
|
|
' fn300_0 = -300.0;',
|
|
' fn123456_0 = -123456.0;',
|
|
' fn1234567_8 = -1234567.8;',
|
|
' fn12345678_9 = -12345678.9;',
|
|
' f1_0En12 = 1E-12;',
|
|
' fn1_0En12 = -1E-12;',
|
|
' maxdouble = 1.7e+308;',
|
|
' mindouble = -1.7e+308;',
|
|
' MinSafeIntDouble = -$10000000000000;',
|
|
' MaxSafeIntDouble = $fffffffffffff;',
|
|
'var',
|
|
' d: double = b;',
|
|
'begin',
|
|
' d:=1.0;',
|
|
' d:=1.0/3.0;',
|
|
' d:=1/3;',
|
|
' d:=5.0E-324;',
|
|
' d:=1.7E308;',
|
|
' d:=001.00E00;',
|
|
' d:=002.00E001;',
|
|
' d:=-003.00E-00;',
|
|
' d:=-004.00E-001;',
|
|
' d:=10**3;',
|
|
' d:=10 mod 3;',
|
|
' d:=10 div 3;',
|
|
' d:=c;',
|
|
' d:=f0_1;',
|
|
' d:=f0_3;',
|
|
' d:=fn0_1;',
|
|
' d:=fn0_3;',
|
|
' d:=fn0_003;',
|
|
' d:=fn0_123456789;',
|
|
' d:=fn300_0;',
|
|
' d:=fn123456_0;',
|
|
' d:=fn1234567_8;',
|
|
' d:=fn12345678_9;',
|
|
' d:=f1_0En12;',
|
|
' d:=fn1_0En12;',
|
|
' d:=maxdouble;',
|
|
' d:=mindouble;',
|
|
' d:=MinSafeIntDouble;',
|
|
' d:=MaxSafeIntDouble;',
|
|
' d:=default(double);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestDouble',
|
|
LinesToStr([
|
|
'this.a = 2.7;',
|
|
'this.b = 2.7 + 1.7;',
|
|
'this.c = 0.9 + 0.1;',
|
|
'this.f0_1 = 0.1;',
|
|
'this.f0_3 = 0.3;',
|
|
'this.fn0_1 = -0.1;',
|
|
'this.fn0_3 = -0.3;',
|
|
'this.fn0_003 = -0.003;',
|
|
'this.fn0_123456789 = -0.123456789;',
|
|
'this.fn300_0 = -300.0;',
|
|
'this.fn123456_0 = -123456.0;',
|
|
'this.fn1234567_8 = -1234567.8;',
|
|
'this.fn12345678_9 = -12345678.9;',
|
|
'this.f1_0En12 = 1E-12;',
|
|
'this.fn1_0En12 = -1E-12;',
|
|
'this.maxdouble = 1.7e+308;',
|
|
'this.mindouble = -1.7e+308;',
|
|
'this.MinSafeIntDouble = -0x10000000000000;',
|
|
'this.MaxSafeIntDouble = 0xfffffffffffff;',
|
|
'this.d = 4.4;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.d = 1.0;',
|
|
'$mod.d = 1.0 / 3.0;',
|
|
'$mod.d = 1 / 3;',
|
|
'$mod.d = 5.0E-324;',
|
|
'$mod.d = 1.7E308;',
|
|
'$mod.d = 1.00E0;',
|
|
'$mod.d = 2.00E1;',
|
|
'$mod.d = -3.00E-0;',
|
|
'$mod.d = -4.00E-1;',
|
|
'$mod.d = Math.pow(10, 3);',
|
|
'$mod.d = 10 % 3;',
|
|
'$mod.d = Math.floor(10 / 3);',
|
|
'$mod.d = 1;',
|
|
'$mod.d = 0.1;',
|
|
'$mod.d = 0.3;',
|
|
'$mod.d = -0.1;',
|
|
'$mod.d = -0.3;',
|
|
'$mod.d = -0.003;',
|
|
'$mod.d = -0.123456789;',
|
|
'$mod.d = -300;',
|
|
'$mod.d = -123456;',
|
|
'$mod.d = -1234567.8;',
|
|
'$mod.d = -1.23456789E7;',
|
|
'$mod.d = 1E-12;',
|
|
'$mod.d = -1E-12;',
|
|
'$mod.d = 1.7E308;',
|
|
'$mod.d = -1.7E308;',
|
|
'$mod.d = -4503599627370496;',
|
|
'$mod.d = 4503599627370495;',
|
|
'$mod.d = 0.0;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestInteger;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'const',
|
|
' MinInt = low(NativeInt);',
|
|
' MaxInt = high(NativeInt);',
|
|
'type',
|
|
' {#TMyInt}TMyInt = MinInt..MaxInt;',
|
|
'const',
|
|
' a = low(TMyInt)+High(TMyInt);',
|
|
'var',
|
|
' i: TMyInt;',
|
|
'begin',
|
|
' i:=-MinInt;',
|
|
' i:=default(TMyInt);',
|
|
' i:=low(i)+high(i);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestIntegerRange',
|
|
LinesToStr([
|
|
'this.MinInt = -4503599627370496;',
|
|
'this.MaxInt = 4503599627370495;',
|
|
'this.a = -4503599627370496 + 4503599627370495;',
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.i = - -4503599627370496;',
|
|
'$mod.i = -4503599627370496;',
|
|
'$mod.i = -4503599627370496 + 4503599627370495;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestIntegerRange;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'const',
|
|
' MinInt = -1;',
|
|
' MaxInt = +1;',
|
|
'type',
|
|
' {#TMyInt}TMyInt = MinInt..MaxInt;',
|
|
' TInt2 = 1..3;',
|
|
'const',
|
|
' a = low(TMyInt)+High(TMyInt);',
|
|
' b = low(TInt2)+High(TInt2);',
|
|
' s1 = [1];',
|
|
' s2 = [1,2];',
|
|
' s3 = [1..3];',
|
|
' s4 = [low(shortint)..high(shortint)];',
|
|
' s5 = [succ(low(shortint))..pred(high(shortint))];',
|
|
' s6 = 1 in s2;',
|
|
'var',
|
|
' i: TMyInt;',
|
|
' i2: TInt2;',
|
|
'begin',
|
|
' i:=i2;',
|
|
' i:=default(TMyInt);',
|
|
' if i=i2 then ;']);
|
|
ConvertProgram;
|
|
CheckSource('TestIntegerRange',
|
|
LinesToStr([
|
|
'this.MinInt = -1;',
|
|
'this.MaxInt = +1;',
|
|
'this.a = -1 + 1;',
|
|
'this.b = 1 + 3;',
|
|
'this.s1 = rtl.createSet(1);',
|
|
'this.s2 = rtl.createSet(1, 2);',
|
|
'this.s3 = rtl.createSet(null, 1, 3);',
|
|
'this.s4 = rtl.createSet(null, -128, 127);',
|
|
'this.s5 = rtl.createSet(null, -128 + 1, 127 - 1);',
|
|
'this.s6 = 1 in $mod.s2;',
|
|
'this.i = 0;',
|
|
'this.i2 = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.i = $mod.i2;',
|
|
'$mod.i = -1;',
|
|
'if ($mod.i === $mod.i2) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestIntegerTypecasts;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' i: nativeint;',
|
|
' b: byte;',
|
|
' sh: shortint;',
|
|
' w: word;',
|
|
' sm: smallint;',
|
|
' lw: longword;',
|
|
' li: longint;',
|
|
'begin',
|
|
' b:=byte(i);',
|
|
' sh:=shortint(i);',
|
|
' w:=word(i);',
|
|
' sm:=smallint(i);',
|
|
' lw:=longword(i);',
|
|
' li:=longint(i);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestIntegerTypecasts',
|
|
LinesToStr([
|
|
'this.i = 0;',
|
|
'this.b = 0;',
|
|
'this.sh = 0;',
|
|
'this.w = 0;',
|
|
'this.sm = 0;',
|
|
'this.lw = 0;',
|
|
'this.li = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.b = $mod.i & 255;',
|
|
'$mod.sh = (($mod.i & 255) << 24) >> 24;',
|
|
'$mod.w = $mod.i & 65535;',
|
|
'$mod.sm = (($mod.i & 65535) << 16) >> 16;',
|
|
'$mod.lw = $mod.i >>> 0;',
|
|
'$mod.li = $mod.i & 0xFFFFFFFF;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestCurrency;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TCoin = currency;',
|
|
'const',
|
|
' a = TCoin(2.7);',
|
|
' b = a + TCoin(1.7);',
|
|
' MinSafeIntCurrency: TCoin = -92233720368.5477;',
|
|
' MaxSafeIntCurrency: TCoin = 92233720368.5477;',
|
|
'var',
|
|
' c: TCoin = b;',
|
|
' i: nativeint;',
|
|
' d: double;',
|
|
' j: jsvalue;',
|
|
'function DoIt(c: currency): currency; begin end;',
|
|
'function GetIt(d: double): double; begin end;',
|
|
'procedure Write(v: jsvalue); begin end;',
|
|
'begin',
|
|
' c:=1.0;',
|
|
' c:=0.1;',
|
|
' c:=1.0/3.0;',
|
|
' c:=1/3;',
|
|
' c:=a;',
|
|
' d:=c;',
|
|
' c:=d;',
|
|
' c:=currency(c);',
|
|
' c:=currency(d);',
|
|
' d:=double(c);',
|
|
' c:=i;',
|
|
' c:=currency(i);',
|
|
//' i:=c;', not allowed
|
|
' i:=nativeint(c);',
|
|
' c:=c+a;',
|
|
' c:=-c-a;',
|
|
' c:=d+c;',
|
|
' c:=c+d;',
|
|
' c:=d-c;',
|
|
' c:=c-d;',
|
|
' c:=c*a;',
|
|
' c:=a*c;',
|
|
' c:=d*c;',
|
|
' c:=c*d;',
|
|
' c:=c/a;',
|
|
' c:=a/c;',
|
|
' c:=d/c;',
|
|
' c:=c/d;',
|
|
' c:=c**a;',
|
|
' c:=a**c;',
|
|
' c:=d**c;',
|
|
' c:=c**d;',
|
|
' if c=c then ;',
|
|
' if c=a then ;',
|
|
' if a=c then ;',
|
|
' if d=c then ;',
|
|
' if c=d then ;',
|
|
' c:=DoIt(c);',
|
|
' c:=DoIt(i);',
|
|
' c:=DoIt(d);',
|
|
' c:=GetIt(c);',
|
|
' j:=c;',
|
|
' Write(c);',
|
|
' c:=default(currency);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestCurrency',
|
|
LinesToStr([
|
|
'this.a = 27000;',
|
|
'this.b = $mod.a + 17000;',
|
|
'this.MinSafeIntCurrency = -92233720368.5477;',
|
|
'this.MaxSafeIntCurrency = 92233720368.5477;',
|
|
'this.c = $mod.b;',
|
|
'this.i = 0;',
|
|
'this.d = 0.0;',
|
|
'this.j = undefined;',
|
|
'this.DoIt = function (c) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
'};',
|
|
'this.GetIt = function (d) {',
|
|
' var Result = 0.0;',
|
|
' return Result;',
|
|
'};',
|
|
'this.Write = function (v) {',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.c = 10000;',
|
|
'$mod.c = 1000;',
|
|
'$mod.c = Math.floor((1.0 / 3.0) * 10000);',
|
|
'$mod.c = Math.floor((1 / 3) * 10000);',
|
|
'$mod.c = $mod.a;',
|
|
'$mod.d = $mod.c / 10000;',
|
|
'$mod.c = Math.floor($mod.d * 10000);',
|
|
'$mod.c = $mod.c;',
|
|
'$mod.c = $mod.d * 10000;',
|
|
'$mod.d = $mod.c / 10000;',
|
|
'$mod.c = $mod.i * 10000;',
|
|
'$mod.c = $mod.i * 10000;',
|
|
'$mod.i = Math.floor($mod.c / 10000);',
|
|
'$mod.c = $mod.c + $mod.a;',
|
|
'$mod.c = -$mod.c - $mod.a;',
|
|
'$mod.c = ($mod.d * 10000) + $mod.c;',
|
|
'$mod.c = $mod.c + ($mod.d * 10000);',
|
|
'$mod.c = ($mod.d * 10000) - $mod.c;',
|
|
'$mod.c = $mod.c - ($mod.d * 10000);',
|
|
'$mod.c = ($mod.c * $mod.a) / 10000;',
|
|
'$mod.c = ($mod.a * $mod.c) / 10000;',
|
|
'$mod.c = $mod.d * $mod.c;',
|
|
'$mod.c = $mod.c * $mod.d;',
|
|
'$mod.c = Math.floor(($mod.c / $mod.a) * 10000);',
|
|
'$mod.c = Math.floor(($mod.a / $mod.c) * 10000);',
|
|
'$mod.c = Math.floor($mod.d / $mod.c);',
|
|
'$mod.c = Math.floor($mod.c / $mod.d);',
|
|
'$mod.c = Math.floor(Math.pow($mod.c / 10000, $mod.a / 10000) * 10000);',
|
|
'$mod.c = Math.floor(Math.pow($mod.a / 10000, $mod.c / 10000) * 10000);',
|
|
'$mod.c = Math.floor(Math.pow($mod.d, $mod.c / 10000) * 10000);',
|
|
'$mod.c = Math.floor(Math.pow($mod.c / 10000, $mod.d) * 10000);',
|
|
'if ($mod.c === $mod.c) ;',
|
|
'if ($mod.c === $mod.a) ;',
|
|
'if ($mod.a === $mod.c) ;',
|
|
'if (($mod.d * 10000) === $mod.c) ;',
|
|
'if ($mod.c === ($mod.d * 10000)) ;',
|
|
'$mod.c = $mod.DoIt($mod.c);',
|
|
'$mod.c = $mod.DoIt($mod.i * 10000);',
|
|
'$mod.c = $mod.DoIt($mod.d * 10000);',
|
|
'$mod.c = Math.floor($mod.GetIt($mod.c / 10000) * 10000);',
|
|
'$mod.j = $mod.c / 10000;',
|
|
'$mod.Write($mod.c / 10000);',
|
|
'$mod.c = 0;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestForBoolDo;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var b: boolean;',
|
|
'begin',
|
|
' for b:=false to true do ;',
|
|
' for b:=b downto false do ;',
|
|
' for b in boolean do ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestForBoolDo',
|
|
LinesToStr([ // statements
|
|
'this.b = false;']),
|
|
LinesToStr([ // this.$main
|
|
'for (var $l1 = 0; $l1 <= 1; $l1++) $mod.b = $l1 !== 0;',
|
|
'for (var $l2 = +$mod.b; $l2 >= 0; $l2--) $mod.b = $l2 !== 0;',
|
|
'for (var $l3 = 0; $l3 <= 1; $l3++) $mod.b = $l3 !== 0;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestForIntDo;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var i: longint;',
|
|
'begin',
|
|
' for i:=3 to 5 do ;',
|
|
' for i:=i downto 2 do ;',
|
|
' for i in byte do ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestForIntDo',
|
|
LinesToStr([ // statements
|
|
'this.i = 0;']),
|
|
LinesToStr([ // this.$main
|
|
'for ($mod.i = 3; $mod.i <= 5; $mod.i++) ;',
|
|
'for (var $l1 = $mod.i; $l1 >= 2; $l1--) $mod.i = $l1;',
|
|
'for (var $l2 = 0; $l2 <= 255; $l2++) $mod.i = $l2;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestForIntInDo;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TSetOfInt = set of byte;',
|
|
' TIntRg = 3..7;',
|
|
' TSetOfIntRg = set of TIntRg;',
|
|
'var',
|
|
' i,i2: longint;',
|
|
' a1: array of byte;',
|
|
' a2: array[1..3] of byte;',
|
|
' soi: TSetOfInt;',
|
|
' soir: TSetOfIntRg;',
|
|
' ir: TIntRg;',
|
|
'begin',
|
|
' for i in byte do ;',
|
|
' for i in a1 do ;',
|
|
' for i in a2 do ;',
|
|
' for i in [11..13] do ;',
|
|
' for i in TSetOfInt do ;',
|
|
' for i in TIntRg do ;',
|
|
' for i in soi do i2:=i;',
|
|
' for i in TSetOfIntRg do ;',
|
|
' for i in soir do ;',
|
|
' for ir in TIntRg do ;',
|
|
' for ir in TSetOfIntRg do ;',
|
|
' for ir in soir do ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestForIntInDo',
|
|
LinesToStr([ // statements
|
|
'this.i = 0;',
|
|
'this.i2 = 0;',
|
|
'this.a1 = [];',
|
|
'this.a2 = rtl.arraySetLength(null, 0, 3);',
|
|
'this.soi = {};',
|
|
'this.soir = {};',
|
|
'this.ir = 0;',
|
|
'']),
|
|
LinesToStr([ // this.$main
|
|
'for (var $l1 = 0; $l1 <= 255; $l1++) $mod.i = $l1;',
|
|
'for (var $in2 = $mod.a1, $l3 = 0, $end4 = rtl.length($in2) - 1; $l3 <= $end4; $l3++) $mod.i = $in2[$l3];',
|
|
'for (var $in5 = $mod.a2, $l6 = 0, $end7 = rtl.length($in5) - 1; $l6 <= $end7; $l6++) $mod.i = $in5[$l6];',
|
|
'for (var $l8 = 11; $l8 <= 13; $l8++) $mod.i = $l8;',
|
|
'for (var $l9 = 0; $l9 <= 255; $l9++) $mod.i = $l9;',
|
|
'for (var $l10 = 3; $l10 <= 7; $l10++) $mod.i = $l10;',
|
|
'for (var $l11 in $mod.soi) {',
|
|
' $mod.i = +$l11;',
|
|
' $mod.i2 = $mod.i;',
|
|
'};',
|
|
'for (var $l12 = 3; $l12 <= 7; $l12++) $mod.i = $l12;',
|
|
'for (var $l13 in $mod.soir) $mod.i = +$l13;',
|
|
'for (var $l14 = 3; $l14 <= 7; $l14++) $mod.ir = $l14;',
|
|
'for (var $l15 = 3; $l15 <= 7; $l15++) $mod.ir = $l15;',
|
|
'for (var $l16 in $mod.soir) $mod.ir = +$l16;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestCharConst;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'const',
|
|
' c: char = ''1'';',
|
|
'begin',
|
|
' c:=#0;',
|
|
' c:=#1;',
|
|
' c:=#9;',
|
|
' c:=#10;',
|
|
' c:=#13;',
|
|
' c:=#31;',
|
|
' c:=#32;',
|
|
' c:=#$A;',
|
|
' c:=#$0A;',
|
|
' c:=#$b;',
|
|
' c:=#$0b;',
|
|
' c:=^A;',
|
|
' c:=''"'';',
|
|
' c:=default(char);',
|
|
' c:=#$00E4;', // ä
|
|
' c:=''ä'';',
|
|
' c:=#$E4;', // ä
|
|
' c:=#$D800;', // invalid UTF-16
|
|
' c:=#$DFFF;', // invalid UTF-16
|
|
' c:=#$FFFF;', // last UCS-2
|
|
' c:=high(c);', // last UCS-2
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestCharConst',
|
|
LinesToStr([
|
|
'this.c="1";'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.c="\x00";',
|
|
'$mod.c="\x01";',
|
|
'$mod.c="\t";',
|
|
'$mod.c="\n";',
|
|
'$mod.c="\r";',
|
|
'$mod.c="\x1F";',
|
|
'$mod.c=" ";',
|
|
'$mod.c="\n";',
|
|
'$mod.c="\n";',
|
|
'$mod.c="\x0B";',
|
|
'$mod.c="\x0B";',
|
|
'$mod.c="\x01";',
|
|
'$mod.c=''"'';',
|
|
'$mod.c="\x00";',
|
|
'$mod.c = "ä";',
|
|
'$mod.c = "ä";',
|
|
'$mod.c = "ä";',
|
|
'$mod.c="\uD800";',
|
|
'$mod.c="\uDFFF";',
|
|
'$mod.c="\uFFFF";',
|
|
'$mod.c="\uFFFF";',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestChar_Compare;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' c: char;');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add(' b:=c=''1'';');
|
|
Add(' b:=''2''=c;');
|
|
Add(' b:=''3''=''4'';');
|
|
Add(' b:=c<>''5'';');
|
|
Add(' b:=''6''<>c;');
|
|
Add(' b:=c>''7'';');
|
|
Add(' b:=''8''>c;');
|
|
Add(' b:=c>=''9'';');
|
|
Add(' b:=''A''>=c;');
|
|
Add(' b:=c<''B'';');
|
|
Add(' b:=''C''<c;');
|
|
Add(' b:=c<=''D'';');
|
|
Add(' b:=''E''<=c;');
|
|
ConvertProgram;
|
|
CheckSource('TestChar_Compare',
|
|
LinesToStr([
|
|
'this.c="";',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.b = $mod.c === "1";',
|
|
'$mod.b = "2" === $mod.c;',
|
|
'$mod.b = "3" === "4";',
|
|
'$mod.b = $mod.c !== "5";',
|
|
'$mod.b = "6" !== $mod.c;',
|
|
'$mod.b = $mod.c > "7";',
|
|
'$mod.b = "8" > $mod.c;',
|
|
'$mod.b = $mod.c >= "9";',
|
|
'$mod.b = "A" >= $mod.c;',
|
|
'$mod.b = $mod.c < "B";',
|
|
'$mod.b = "C" < $mod.c;',
|
|
'$mod.b = $mod.c <= "D";',
|
|
'$mod.b = "E" <= $mod.c;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestChar_BuiltInProcs;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' c: char;',
|
|
' i: longint;',
|
|
' s: string;',
|
|
'begin',
|
|
' i:=ord(c);',
|
|
' i:=ord(s[i]);',
|
|
' c:=chr(i);',
|
|
' c:=pred(c);',
|
|
' c:=succ(c);',
|
|
' c:=low(c);',
|
|
' c:=high(c);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestChar_BuiltInProcs',
|
|
LinesToStr([
|
|
'this.c = "";',
|
|
'this.i = 0;',
|
|
'this.s = "";'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.i = $mod.c.charCodeAt();',
|
|
'$mod.i = $mod.s.charCodeAt($mod.i-1);',
|
|
'$mod.c = String.fromCharCode($mod.i);',
|
|
'$mod.c = String.fromCharCode($mod.c.charCodeAt() - 1);',
|
|
'$mod.c = String.fromCharCode($mod.c.charCodeAt() + 1);',
|
|
'$mod.c = "\x00";',
|
|
'$mod.c = "\uFFFF";',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestStringConst;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$H+}',
|
|
'var',
|
|
' s: string = ''abc'';',
|
|
'begin',
|
|
' s:='''';',
|
|
' s:=#13#10;',
|
|
' s:=#9''foo'';',
|
|
' s:=#$A9;',
|
|
' s:=''foo''#13''bar'';',
|
|
' s:=''"'';',
|
|
' s:=''"''''"'';',
|
|
' s:=#$20AC;', // euro
|
|
' s:=#$10437;', // outside BMP
|
|
' s:=default(string);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestStringConst',
|
|
LinesToStr([
|
|
'this.s="abc";'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.s="";',
|
|
'$mod.s="\r\n";',
|
|
'$mod.s="\tfoo";',
|
|
'$mod.s="©";',
|
|
'$mod.s="foo\rbar";',
|
|
'$mod.s=''"'';',
|
|
'$mod.s=''"\''"'';',
|
|
'$mod.s="€";',
|
|
'$mod.s="'#$F0#$90#$90#$B7'";',
|
|
'$mod.s="";'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestStringConstSurrogate;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' s: string;',
|
|
'begin',
|
|
' s:=''😊'';', // 1F60A
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestStringConstSurrogate',
|
|
LinesToStr([
|
|
'this.s="";'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.s="😊";'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestString_Length;
|
|
begin
|
|
StartProgram(false);
|
|
Add('const c = ''foo'';');
|
|
Add('var');
|
|
Add(' s: string;');
|
|
Add(' i: longint;');
|
|
Add('begin');
|
|
Add(' i:=length(s);');
|
|
Add(' i:=length(s+s);');
|
|
Add(' i:=length(''abc'');');
|
|
Add(' i:=length(c);');
|
|
ConvertProgram;
|
|
CheckSource('TestString_Length',
|
|
LinesToStr([
|
|
'this.c = "foo";',
|
|
'this.s = "";',
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.i = $mod.s.length;',
|
|
'$mod.i = ($mod.s+$mod.s).length;',
|
|
'$mod.i = "abc".length;',
|
|
'$mod.i = $mod.c.length;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestString_Compare;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' s, t: string;');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add(' b:=s=t;');
|
|
Add(' b:=s<>t;');
|
|
Add(' b:=s>t;');
|
|
Add(' b:=s>=t;');
|
|
Add(' b:=s<t;');
|
|
Add(' b:=s<=t;');
|
|
ConvertProgram;
|
|
CheckSource('TestString_Compare',
|
|
LinesToStr([ // statements
|
|
'this.s = "";',
|
|
'this.t = "";',
|
|
'this.b =false;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
'$mod.b = $mod.s === $mod.t;',
|
|
'$mod.b = $mod.s !== $mod.t;',
|
|
'$mod.b = $mod.s > $mod.t;',
|
|
'$mod.b = $mod.s >= $mod.t;',
|
|
'$mod.b = $mod.s < $mod.t;',
|
|
'$mod.b = $mod.s <= $mod.t;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestString_SetLength;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure DoIt(var s: string);',
|
|
'begin',
|
|
' SetLength(s,2);',
|
|
'end;',
|
|
'var s: string;',
|
|
'begin',
|
|
' SetLength(s,3);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestString_SetLength',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (s) {',
|
|
' s.set(rtl.strSetLength(s.get(), 2));',
|
|
'};',
|
|
'this.s = "";',
|
|
'']),
|
|
LinesToStr([ // this.$main
|
|
'$mod.s = rtl.strSetLength($mod.s, 3);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestString_CharAt;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' s: string;',
|
|
' c: char;',
|
|
' b: boolean;',
|
|
'begin',
|
|
' b:= s[1] = c;',
|
|
' b:= c = s[1];',
|
|
' b:= c <> s[1];',
|
|
' b:= c > s[1];',
|
|
' b:= c >= s[1];',
|
|
' b:= c < s[2];',
|
|
' b:= c <= s[1];',
|
|
' s[1] := c;',
|
|
' s[2+3] := c;']);
|
|
ConvertProgram;
|
|
CheckSource('TestString_CharAt',
|
|
LinesToStr([ // statements
|
|
'this.s = "";',
|
|
'this.c = "";',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
'$mod.b = $mod.s.charAt(0) === $mod.c;',
|
|
'$mod.b = $mod.c === $mod.s.charAt(0);',
|
|
'$mod.b = $mod.c !== $mod.s.charAt(0);',
|
|
'$mod.b = $mod.c > $mod.s.charAt(0);',
|
|
'$mod.b = $mod.c >= $mod.s.charAt(0);',
|
|
'$mod.b = $mod.c < $mod.s.charAt(1);',
|
|
'$mod.b = $mod.c <= $mod.s.charAt(0);',
|
|
'$mod.s = rtl.setCharAt($mod.s, 0, $mod.c);',
|
|
'$mod.s = rtl.setCharAt($mod.s, (2 + 3) - 1, $mod.c);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestStringHMinusFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$H-}',
|
|
'var s: string;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckHint(mtWarning,nWarnIllegalCompilerDirectiveX,'Warning: test1.pp(3,6) : Illegal compiler directive "H-"');
|
|
end;
|
|
|
|
procedure TTestModule.TestStr;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' b: boolean;');
|
|
Add(' i: longint;');
|
|
Add(' d: double;');
|
|
Add(' s: string;');
|
|
Add('begin');
|
|
Add(' str(b,s);');
|
|
Add(' str(i,s);');
|
|
Add(' str(d,s);');
|
|
Add(' str(i:3,s);');
|
|
Add(' str(d:3:2,s);');
|
|
Add(' Str(12.456:12:1,s);');
|
|
Add(' Str(12.456:12,s);');
|
|
Add(' s:=str(b);');
|
|
Add(' s:=str(i);');
|
|
Add(' s:=str(d);');
|
|
Add(' s:=str(i,i);');
|
|
Add(' s:=str(i:3);');
|
|
Add(' s:=str(d:3:2);');
|
|
Add(' s:=str(i:4,i);');
|
|
Add(' s:=str(i,i:5);');
|
|
Add(' s:=str(i:4,i:5);');
|
|
Add(' s:=str(s,s);');
|
|
Add(' s:=str(s,''foo'');');
|
|
ConvertProgram;
|
|
CheckSource('TestStr',
|
|
LinesToStr([ // statements
|
|
'this.b = false;',
|
|
'this.i = 0;',
|
|
'this.d = 0.0;',
|
|
'this.s = "";',
|
|
'']),
|
|
LinesToStr([ // this.$main
|
|
'$mod.s = ""+$mod.b;',
|
|
'$mod.s = ""+$mod.i;',
|
|
'$mod.s = rtl.floatToStr($mod.d);',
|
|
'$mod.s = rtl.spaceLeft(""+$mod.i,3);',
|
|
'$mod.s = rtl.floatToStr($mod.d,3,2);',
|
|
'$mod.s = rtl.floatToStr(12.456,12,1);',
|
|
'$mod.s = rtl.floatToStr(12.456,12);',
|
|
'$mod.s = ""+$mod.b;',
|
|
'$mod.s = ""+$mod.i;',
|
|
'$mod.s = rtl.floatToStr($mod.d);',
|
|
'$mod.s = (""+$mod.i)+$mod.i;',
|
|
'$mod.s = rtl.spaceLeft(""+$mod.i,3);',
|
|
'$mod.s = rtl.floatToStr($mod.d,3,2);',
|
|
'$mod.s = rtl.spaceLeft("" + $mod.i, 4) + $mod.i;',
|
|
'$mod.s = ("" + $mod.i) + rtl.spaceLeft("" + $mod.i, 5);',
|
|
'$mod.s = rtl.spaceLeft("" + $mod.i, 4) + rtl.spaceLeft("" + $mod.i, 5);',
|
|
'$mod.s = $mod.s + $mod.s;',
|
|
'$mod.s = $mod.s + "foo";',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestBaseType_AnsiStringFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var s: AnsiString');
|
|
SetExpectedPasResolverError('identifier not found "AnsiString"',PasResolveEval.nIdentifierNotFound);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestBaseType_WideStringFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var s: WideString');
|
|
SetExpectedPasResolverError('identifier not found "WideString"',PasResolveEval.nIdentifierNotFound);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestBaseType_ShortStringFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var s: ShortString');
|
|
SetExpectedPasResolverError('identifier not found "ShortString"',PasResolveEval.nIdentifierNotFound);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestBaseType_RawByteStringFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var s: RawByteString');
|
|
SetExpectedPasResolverError('identifier not found "RawByteString"',PasResolveEval.nIdentifierNotFound);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestTypeShortstring_Fail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type t = string[12];');
|
|
Add('var s: t;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError('illegal qualifier "["',nIllegalQualifier);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestCharSet_Custom;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TCharRg = ''a''..''z'';',
|
|
' TSetOfCharRg = set of TCharRg;',
|
|
' TCharRg2 = ''m''..''p'';',
|
|
'const',
|
|
' crg: TCharRg = ''b'';',
|
|
'var',
|
|
' c: char;',
|
|
' crg2: TCharRg2;',
|
|
' s: TSetOfCharRg;',
|
|
'begin',
|
|
' c:=crg;',
|
|
' crg:=c;',
|
|
' crg2:=crg;',
|
|
' if c=crg then ;',
|
|
' if crg=c then ;',
|
|
' if crg=crg2 then ;',
|
|
' if c in s then ;',
|
|
' if crg2 in s then ;',
|
|
' c:=default(TCharRg);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestCharSet_Custom',
|
|
LinesToStr([ // statements
|
|
'this.crg = "b";',
|
|
'this.c = "";',
|
|
'this.crg2 = "m";',
|
|
'this.s = {};',
|
|
'']),
|
|
LinesToStr([ // this.$main
|
|
'$mod.c = $mod.crg;',
|
|
'$mod.crg = $mod.c;',
|
|
'$mod.crg2 = $mod.crg;',
|
|
'if ($mod.c === $mod.crg) ;',
|
|
'if ($mod.crg === $mod.c) ;',
|
|
'if ($mod.crg === $mod.crg2) ;',
|
|
'if ($mod.c.charCodeAt() in $mod.s) ;',
|
|
'if ($mod.crg2.charCodeAt() in $mod.s) ;',
|
|
'$mod.c = "a";',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestForCharDo;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var c: char;',
|
|
'begin',
|
|
' for c:=''a'' to ''c'' do ;',
|
|
' for c:=c downto ''a'' do ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestForCharDo',
|
|
LinesToStr([ // statements
|
|
'this.c = "";']),
|
|
LinesToStr([ // this.$main
|
|
'for (var $l1 = 97; $l1 <= 99; $l1++) $mod.c = String.fromCharCode($l1);',
|
|
'for (var $l2 = $mod.c.charCodeAt(); $l2 >= 97; $l2--) $mod.c = String.fromCharCode($l2);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestForCharInDo;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TSetOfChar = set of char;',
|
|
' TCharRg = ''a''..''z'';',
|
|
' TSetOfCharRg = set of TCharRg;',
|
|
'const Foo = ''foo'';',
|
|
'var',
|
|
' c,c2: char;',
|
|
' s: string;',
|
|
' a1: array of char;',
|
|
' a2: array[1..3] of char;',
|
|
' soc: TSetOfChar;',
|
|
' socr: TSetOfCharRg;',
|
|
' cr: TCharRg;',
|
|
'begin',
|
|
' for c in foo do ;',
|
|
' for c in s do ;',
|
|
' for c in char do ;',
|
|
' for c in a1 do ;',
|
|
' for c in a2 do ;',
|
|
' for c in [''1''..''3''] do ;',
|
|
' for c in TSetOfChar do ;',
|
|
' for c in TCharRg do ;',
|
|
' for c in soc do c2:=c;',
|
|
' for c in TSetOfCharRg do ;',
|
|
' for c in socr do ;',
|
|
' for cr in TCharRg do ;',
|
|
' for cr in TSetOfCharRg do ;',
|
|
' for cr in socr do ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestForCharInDo',
|
|
LinesToStr([ // statements
|
|
'this.Foo = "foo";',
|
|
'this.c = "";',
|
|
'this.c2 = "";',
|
|
'this.s = "";',
|
|
'this.a1 = [];',
|
|
'this.a2 = rtl.arraySetLength(null, "", 3);',
|
|
'this.soc = {};',
|
|
'this.socr = {};',
|
|
'this.cr = "a";',
|
|
'']),
|
|
LinesToStr([ // this.$main
|
|
'for (var $in1 = $mod.Foo, $l2 = 0, $end3 = $in1.length - 1; $l2 <= $end3; $l2++) $mod.c = $in1.charAt($l2);',
|
|
'for (var $in4 = $mod.s, $l5 = 0, $end6 = $in4.length - 1; $l5 <= $end6; $l5++) $mod.c = $in4.charAt($l5);',
|
|
'for (var $l7 = 0; $l7 <= 65535; $l7++) $mod.c = String.fromCharCode($l7);',
|
|
'for (var $in8 = $mod.a1, $l9 = 0, $end10 = rtl.length($in8) - 1; $l9 <= $end10; $l9++) $mod.c = $in8[$l9];',
|
|
'for (var $in11 = $mod.a2, $l12 = 0, $end13 = rtl.length($in11) - 1; $l12 <= $end13; $l12++) $mod.c = $in11[$l12];',
|
|
'for (var $l14 = 49; $l14 <= 51; $l14++) $mod.c = String.fromCharCode($l14);',
|
|
'for (var $l15 = 0; $l15 <= 65535; $l15++) $mod.c = String.fromCharCode($l15);',
|
|
'for (var $l16 = 97; $l16 <= 122; $l16++) $mod.c = String.fromCharCode($l16);',
|
|
'for (var $l17 in $mod.soc) {',
|
|
' $mod.c = String.fromCharCode($l17);',
|
|
' $mod.c2 = $mod.c;',
|
|
'};',
|
|
'for (var $l18 = 97; $l18 <= 122; $l18++) $mod.c = String.fromCharCode($l18);',
|
|
'for (var $l19 in $mod.socr) $mod.c = String.fromCharCode($l19);',
|
|
'for (var $l20 = 97; $l20 <= 122; $l20++) $mod.cr = String.fromCharCode($l20);',
|
|
'for (var $l21 = 97; $l21 <= 122; $l21++) $mod.cr = String.fromCharCode($l21);',
|
|
'for (var $l22 in $mod.socr) $mod.cr = String.fromCharCode($l22);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcTwoArgs;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure Test(a,b: longint);');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestProcTwoArgs',
|
|
LinesToStr([ // statements
|
|
'this.Test = function (a,b) {',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProc_DefaultValue;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure p1(i: longint = 1);');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('procedure p2(i: longint = 1; c: char = ''a'');');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('procedure p3(d: double = 1.0; b: boolean = false; s: string = ''abc'');');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('begin');
|
|
Add(' p1;');
|
|
Add(' p1();');
|
|
Add(' p1(11);');
|
|
Add(' p2;');
|
|
Add(' p2();');
|
|
Add(' p2(12);');
|
|
Add(' p2(13,''b'');');
|
|
Add(' p3();');
|
|
ConvertProgram;
|
|
CheckSource('TestProc_DefaultValue',
|
|
LinesToStr([ // statements
|
|
'this.p1 = function (i) {',
|
|
'};',
|
|
'this.p2 = function (i,c) {',
|
|
'};',
|
|
'this.p3 = function (d,b,s) {',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
' $mod.p1(1);',
|
|
' $mod.p1(1);',
|
|
' $mod.p1(11);',
|
|
' $mod.p2(1,"a");',
|
|
' $mod.p2(1,"a");',
|
|
' $mod.p2(12,"a");',
|
|
' $mod.p2(13,"b");',
|
|
' $mod.p3(1.0,false,"abc");'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestFunctionInt;
|
|
begin
|
|
StartProgram(false);
|
|
Add('function MyTest(Bar: longint): longint;');
|
|
Add('begin');
|
|
Add(' Result:=2*bar');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestFunctionInt',
|
|
LinesToStr([ // statements
|
|
'this.MyTest = function (Bar) {',
|
|
' var Result = 0;',
|
|
' Result = 2*Bar;',
|
|
' return Result;',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestFunctionString;
|
|
begin
|
|
StartProgram(false);
|
|
Add('function Test(Bar: string): string;');
|
|
Add('begin');
|
|
Add(' Result:=bar+BAR');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestFunctionString',
|
|
LinesToStr([ // statements
|
|
'this.Test = function (Bar) {',
|
|
' var Result = "";',
|
|
' Result = Bar+Bar;',
|
|
' return Result;',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestIfThen;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var b: boolean;',
|
|
'begin',
|
|
' if b then ;',
|
|
' if b then else ;']);
|
|
ConvertProgram;
|
|
CheckSource('TestIfThen',
|
|
LinesToStr([ // statements
|
|
'this.b = false;',
|
|
'']),
|
|
LinesToStr([ // this.$main
|
|
'if ($mod.b) ;',
|
|
'if ($mod.b) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestForLoop;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' vI, vJ, vN: longint;');
|
|
Add('begin');
|
|
Add(' VJ:=0;');
|
|
Add(' VN:=3;');
|
|
Add(' for VI:=1 to VN do');
|
|
Add(' begin');
|
|
Add(' VJ:=VJ+VI;');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestForLoop',
|
|
LinesToStr([ // statements
|
|
'this.vI = 0;',
|
|
'this.vJ = 0;',
|
|
'this.vN = 0;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
' $mod.vJ = 0;',
|
|
' $mod.vN = 3;',
|
|
' for (var $l1 = 1, $end2 = $mod.vN; $l1 <= $end2; $l1++) {',
|
|
' $mod.vI = $l1;',
|
|
' $mod.vJ = $mod.vJ + $mod.vI;',
|
|
' };',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestForLoopInsideFunction;
|
|
begin
|
|
StartProgram(false);
|
|
Add('function SumNumbers(Count: longint): longint;');
|
|
Add('var');
|
|
Add(' vI, vJ: longint;');
|
|
Add('begin');
|
|
Add(' vj:=0;');
|
|
Add(' for vi:=1 to count do');
|
|
Add(' begin');
|
|
Add(' vj:=vj+vi;');
|
|
Add(' end;');
|
|
Add('end;');
|
|
Add('begin');
|
|
Add(' sumnumbers(3);');
|
|
ConvertProgram;
|
|
CheckSource('TestForLoopInsideFunction',
|
|
LinesToStr([ // statements
|
|
'this.SumNumbers = function (Count) {',
|
|
' var Result = 0;',
|
|
' var vI = 0;',
|
|
' var vJ = 0;',
|
|
' vJ = 0;',
|
|
' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
|
|
' vI = $l1;',
|
|
' vJ = vJ + vI;',
|
|
' };',
|
|
' return Result;',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
' $mod.SumNumbers(3);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestForLoop_ReadVarAfter;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' vI: longint;');
|
|
Add('begin');
|
|
Add(' for vi:=1 to 2 do ;');
|
|
Add(' if vi=3 then ;');
|
|
ConvertProgram;
|
|
CheckSource('TestForLoop',
|
|
LinesToStr([ // statements
|
|
'this.vI = 0;'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
' for ($mod.vI = 1; $mod.vI <= 2; $mod.vI++) ;',
|
|
' if ($mod.vI===3) ;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestForLoop_Nested;
|
|
begin
|
|
StartProgram(false);
|
|
Add('function SumNumbers(Count: longint): longint;');
|
|
Add('var');
|
|
Add(' vI, vJ, vK: longint;');
|
|
Add('begin');
|
|
Add(' VK:=0;');
|
|
Add(' for VI:=1 to count do');
|
|
Add(' begin');
|
|
Add(' for vj:=1 to vi do');
|
|
Add(' begin');
|
|
Add(' vk:=VK+VI;');
|
|
Add(' end;');
|
|
Add(' end;');
|
|
Add('end;');
|
|
Add('begin');
|
|
Add(' sumnumbers(3);');
|
|
ConvertProgram;
|
|
CheckSource('TestForLoopInFunction',
|
|
LinesToStr([ // statements
|
|
'this.SumNumbers = function (Count) {',
|
|
' var Result = 0;',
|
|
' var vI = 0;',
|
|
' var vJ = 0;',
|
|
' var vK = 0;',
|
|
' vK = 0;',
|
|
' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
|
|
' vI = $l1;',
|
|
' for (var $l3 = 1, $end4 = vI; $l3 <= $end4; $l3++) {',
|
|
' vJ = $l3;',
|
|
' vK = vK + vI;',
|
|
' };',
|
|
' };',
|
|
' return Result;',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
' $mod.SumNumbers(3);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestRepeatUntil;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' vI, vJ, vN: longint;');
|
|
Add('begin');
|
|
Add(' vn:=3;');
|
|
Add(' vj:=0;');
|
|
Add(' VI:=0;');
|
|
Add(' repeat');
|
|
Add(' VI:=vi+1;');
|
|
Add(' vj:=VJ+vI;');
|
|
Add(' until vi>=vn');
|
|
ConvertProgram;
|
|
CheckSource('TestRepeatUntil',
|
|
LinesToStr([ // statements
|
|
'this.vI = 0;',
|
|
'this.vJ = 0;',
|
|
'this.vN = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
' $mod.vN = 3;',
|
|
' $mod.vJ = 0;',
|
|
' $mod.vI = 0;',
|
|
' do{',
|
|
' $mod.vI = $mod.vI + 1;',
|
|
' $mod.vJ = $mod.vJ + $mod.vI;',
|
|
' }while(!($mod.vI>=$mod.vN));'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestAsmBlock;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' vI: longint;',
|
|
'begin',
|
|
' vi:=1;',
|
|
' asm',
|
|
' if (vI===1) {',
|
|
' vI=2;',
|
|
//' console.log(''end;'');', ToDo
|
|
' }',
|
|
' if (vI===2){ vI=3; }',
|
|
' end;',
|
|
' VI:=4;']);
|
|
ConvertProgram;
|
|
CheckSource('TestAsmBlock',
|
|
LinesToStr([ // statements
|
|
'this.vI = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.vI = 1;',
|
|
'if (vI===1) {',
|
|
' vI=2;',
|
|
'}',
|
|
'if (vI===2){ vI=3; }',
|
|
';',
|
|
'$mod.vI = 4;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestAsmPas_Impl;
|
|
begin
|
|
StartUnit(false);
|
|
Add('interface');
|
|
Add('const cIntf: longint = 1;');
|
|
Add('var vIntf: longint;');
|
|
Add('implementation');
|
|
Add('const cImpl: longint = 2;');
|
|
Add('var vImpl: longint;');
|
|
Add('procedure DoIt;');
|
|
Add('const cLoc: longint = 3;');
|
|
Add('var vLoc: longint;');
|
|
Add('begin;');
|
|
Add(' asm');
|
|
//Add(' pas(vIntf)=pas(cIntf);');
|
|
//Add(' pas(vImpl)=pas(cImpl);');
|
|
//Add(' pas(vLoc)=pas(cLoc);');
|
|
Add(' end;');
|
|
Add('end;');
|
|
ConvertUnit;
|
|
CheckSource('TestAsmPas_Impl',
|
|
LinesToStr([
|
|
'var $impl = $mod.$impl;',
|
|
'this.cIntf = 1;',
|
|
'this.vIntf = 0;',
|
|
'']),
|
|
'', // this.$init
|
|
LinesToStr([ // implementation
|
|
'$impl.cImpl = 2;',
|
|
'$impl.vImpl = 0;',
|
|
'var cLoc = 3;',
|
|
'$impl.DoIt = function () {',
|
|
' var vLoc = 0;',
|
|
'};',
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestTryFinally;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var i: longint;');
|
|
Add('begin');
|
|
Add(' try');
|
|
Add(' i:=0; i:=2 div i;');
|
|
Add(' finally');
|
|
Add(' i:=3');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestTryFinally',
|
|
LinesToStr([ // statements
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'try {',
|
|
' $mod.i = 0;',
|
|
' $mod.i = Math.floor(2 / $mod.i);',
|
|
'} finally {',
|
|
' $mod.i = 3;',
|
|
'};'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestTryExcept;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class end;');
|
|
Add(' Exception = class Msg: string; end;');
|
|
Add(' EInvalidCast = class(Exception) end;');
|
|
Add('var vI: longint;');
|
|
Add('begin');
|
|
Add(' try');
|
|
Add(' vi:=1;');
|
|
Add(' except');
|
|
Add(' vi:=2');
|
|
Add(' end;');
|
|
Add(' try');
|
|
Add(' vi:=3;');
|
|
Add(' except');
|
|
Add(' raise;');
|
|
Add(' end;');
|
|
Add(' try');
|
|
Add(' VI:=4;');
|
|
Add(' except');
|
|
Add(' on einvalidcast do');
|
|
Add(' raise;');
|
|
Add(' on E: exception do');
|
|
Add(' if e.msg='''' then');
|
|
Add(' raise e;');
|
|
Add(' else');
|
|
Add(' vi:=5');
|
|
Add(' end;');
|
|
Add(' try');
|
|
Add(' VI:=6;');
|
|
Add(' except');
|
|
Add(' on einvalidcast do ;');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestTryExcept',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.Msg = "";',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "EInvalidCast", $mod.Exception, function () {',
|
|
'});',
|
|
'this.vI = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'try {',
|
|
' $mod.vI = 1;',
|
|
'} catch ($e) {',
|
|
' $mod.vI = 2;',
|
|
'};',
|
|
'try {',
|
|
' $mod.vI = 3;',
|
|
'} catch ($e) {',
|
|
' throw $e;',
|
|
'};',
|
|
'try {',
|
|
' $mod.vI = 4;',
|
|
'} catch ($e) {',
|
|
' if ($mod.EInvalidCast.isPrototypeOf($e)){',
|
|
' throw $e',
|
|
' } else if ($mod.Exception.isPrototypeOf($e)) {',
|
|
' var E = $e;',
|
|
' if (E.Msg === "") throw E;',
|
|
' } else {',
|
|
' $mod.vI = 5;',
|
|
' }',
|
|
'};',
|
|
'try {',
|
|
' $mod.vI = 6;',
|
|
'} catch ($e) {',
|
|
' if ($mod.EInvalidCast.isPrototypeOf($e)){' ,
|
|
' } else throw $e',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestTryExcept_ReservedWords;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class end;',
|
|
' Exception = class',
|
|
' Symbol: string;',
|
|
' end;',
|
|
'var &try: longint;',
|
|
'begin',
|
|
' try',
|
|
' &try:=4;',
|
|
' except',
|
|
' on Error: exception do',
|
|
' if errOR.symBol='''' then',
|
|
' raise ERRor;',
|
|
' end;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestTryExcept_ReservedWords',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.Symbol = "";',
|
|
' };',
|
|
'});',
|
|
'this.Try = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'try {',
|
|
' $mod.Try = 4;',
|
|
'} catch ($e) {',
|
|
' if ($mod.Exception.isPrototypeOf($e)) {',
|
|
' var error = $e;',
|
|
' if (error.Symbol === "") throw error;',
|
|
' } else throw $e',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestIfThenRaiseElse;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' constructor Create;',
|
|
' end;',
|
|
'constructor TObject.Create;',
|
|
'begin',
|
|
'end;',
|
|
'var b: boolean;',
|
|
'begin',
|
|
' if b then',
|
|
' raise TObject.Create',
|
|
' else',
|
|
' b:=false;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestIfThenRaiseElse',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' };',
|
|
'});',
|
|
'this.b = false;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'if ($mod.b) {',
|
|
' throw $mod.TObject.$create("Create")}',
|
|
' else $mod.b = false;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestCaseOf;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'const e: longint; external name ''$e'';',
|
|
'var vI: longint;',
|
|
'begin',
|
|
' case vi of',
|
|
' 1: ;',
|
|
' 2: vi:=3;',
|
|
' e: ;',
|
|
' else',
|
|
' VI:=4',
|
|
' end;']);
|
|
ConvertProgram;
|
|
CheckSource('TestCaseOf',
|
|
LinesToStr([ // statements
|
|
'this.vI = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'var $tmp1 = $mod.vI;',
|
|
'if ($tmp1 === 1) {}',
|
|
'else if ($tmp1 === 2) {',
|
|
' $mod.vI = 3}',
|
|
' else if ($tmp1 === $e) {}',
|
|
'else {',
|
|
' $mod.vI = 4;',
|
|
'};'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestCaseOf_UseSwitch;
|
|
begin
|
|
StartProgram(false);
|
|
Converter.UseSwitchStatement:=true;
|
|
Add('var Vi: longint;');
|
|
Add('begin');
|
|
Add(' case vi of');
|
|
Add(' 1: ;');
|
|
Add(' 2: VI:=3;');
|
|
Add(' else');
|
|
Add(' vi:=4');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestCaseOf_UseSwitch',
|
|
LinesToStr([ // statements
|
|
'this.Vi = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'switch ($mod.Vi) {',
|
|
'case 1:',
|
|
' break;',
|
|
'case 2:',
|
|
' $mod.Vi = 3;',
|
|
' break;',
|
|
'default:',
|
|
' $mod.Vi = 4;',
|
|
'};'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestCaseOfNoElse;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var Vi: longint;');
|
|
Add('begin');
|
|
Add(' case vi of');
|
|
Add(' 1: begin vi:=2; VI:=3; end;');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestCaseOfNoElse',
|
|
LinesToStr([ // statements
|
|
'this.Vi = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'var $tmp1 = $mod.Vi;',
|
|
'if ($tmp1 === 1) {',
|
|
' $mod.Vi = 2;',
|
|
' $mod.Vi = 3;',
|
|
'};'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestCaseOfNoElse_UseSwitch;
|
|
begin
|
|
StartProgram(false);
|
|
Converter.UseSwitchStatement:=true;
|
|
Add('var vI: longint;');
|
|
Add('begin');
|
|
Add(' case vi of');
|
|
Add(' 1: begin VI:=2; vi:=3; end;');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestCaseOfNoElse_UseSwitch',
|
|
LinesToStr([ // statements
|
|
'this.vI = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'switch ($mod.vI) {',
|
|
'case 1:',
|
|
' $mod.vI = 2;',
|
|
' $mod.vI = 3;',
|
|
' break;',
|
|
'};'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestCaseOfRange;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var vI: longint;');
|
|
Add('begin');
|
|
Add(' case vi of');
|
|
Add(' 1..3: vi:=14;');
|
|
Add(' 4,5: vi:=16;');
|
|
Add(' 6..7,9..10: ;');
|
|
Add(' else ;');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestCaseOfRange',
|
|
LinesToStr([ // statements
|
|
'this.vI = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'var $tmp1 = $mod.vI;',
|
|
'if (($tmp1 >= 1) && ($tmp1 <= 3)){',
|
|
' $mod.vI = 14',
|
|
'} else if (($tmp1 === 4) || ($tmp1 === 5)){',
|
|
' $mod.vI = 16',
|
|
'} else if ((($tmp1 >= 6) && ($tmp1 <= 7)) || (($tmp1 >= 9) && ($tmp1 <= 10))) ;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestCaseOfString;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var s,h: string;',
|
|
'begin',
|
|
' case s of',
|
|
' ''foo'': s:=h;',
|
|
' ''a''..''z'': h:=s;',
|
|
' end;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestCaseOfString',
|
|
LinesToStr([ // statements
|
|
'this.s = "";',
|
|
'this.h = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'var $tmp1 = $mod.s;',
|
|
'if ($tmp1 === "foo") {',
|
|
' $mod.s = $mod.h}',
|
|
' else if (($tmp1.length === 1) && (($tmp1 >= "a") && ($tmp1 <= "z"))) $mod.h = $mod.s;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestCaseOfExternalClassConst;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TBird = class external name ''Bird''',
|
|
' const e: longint;',
|
|
' end;',
|
|
'var vI: longint;',
|
|
'begin',
|
|
' case vi of',
|
|
' 1: vi:=3;',
|
|
' TBird.e: ;',
|
|
' end;']);
|
|
ConvertProgram;
|
|
CheckSource('TestCaseOfExternalClassConst',
|
|
LinesToStr([ // statements
|
|
'this.vI = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'var $tmp1 = $mod.vI;',
|
|
'if ($tmp1 === 1) {',
|
|
' $mod.vI = 3}',
|
|
' else if ($tmp1 === Bird.e) ;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_Dynamic;
|
|
begin
|
|
StartProgram(false);
|
|
Add(['type',
|
|
' TArrayInt = array of longint;',
|
|
'var',
|
|
' Arr: TArrayInt;',
|
|
' i: longint;',
|
|
' b: boolean;',
|
|
'begin',
|
|
' SetLength(arr,3);',
|
|
' arr[0]:=4;',
|
|
' arr[1]:=length(arr)+arr[0];',
|
|
' arr[i]:=5;',
|
|
' arr[arr[i]]:=arr[6];',
|
|
' i:=low(arr);',
|
|
' i:=high(arr);',
|
|
' b:=Assigned(arr);',
|
|
' Arr:=default(TArrayInt);']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_Dynamic',
|
|
LinesToStr([ // statements
|
|
'this.Arr = [];',
|
|
'this.i = 0;',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Arr = rtl.arraySetLength($mod.Arr,0,3);',
|
|
'$mod.Arr[0] = 4;',
|
|
'$mod.Arr[1] = rtl.length($mod.Arr) + $mod.Arr[0];',
|
|
'$mod.Arr[$mod.i] = 5;',
|
|
'$mod.Arr[$mod.Arr[$mod.i]] = $mod.Arr[6];',
|
|
'$mod.i = 0;',
|
|
'$mod.i = rtl.length($mod.Arr) - 1;',
|
|
'$mod.b = rtl.length($mod.Arr) > 0;',
|
|
'$mod.Arr = [];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_Dynamic_Nil;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TArrayInt = array of longint;');
|
|
Add('var');
|
|
Add(' Arr: TArrayInt;');
|
|
Add('procedure DoIt(const i: TArrayInt; j: TArrayInt); begin end;');
|
|
Add('begin');
|
|
Add(' arr:=nil;');
|
|
Add(' if arr=nil then;');
|
|
Add(' if nil=arr then;');
|
|
Add(' if arr<>nil then;');
|
|
Add(' if nil<>arr then;');
|
|
Add(' DoIt(nil,nil);');
|
|
ConvertProgram;
|
|
CheckSource('TestArray_Dynamic',
|
|
LinesToStr([ // statements
|
|
'this.Arr = [];',
|
|
'this.DoIt = function(i,j){',
|
|
'};'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Arr = [];',
|
|
'if (rtl.length($mod.Arr) === 0) ;',
|
|
'if (rtl.length($mod.Arr) === 0) ;',
|
|
'if (rtl.length($mod.Arr) > 0) ;',
|
|
'if (rtl.length($mod.Arr) > 0) ;',
|
|
'$mod.DoIt([],[]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_DynMultiDimensional;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TArrayInt = array of longint;');
|
|
Add(' TArrayArrayInt = array of TArrayInt;');
|
|
Add('var');
|
|
Add(' Arr: TArrayInt;');
|
|
Add(' Arr2: TArrayArrayInt;');
|
|
Add(' i: longint;');
|
|
Add('begin');
|
|
Add(' arr2:=nil;');
|
|
Add(' if arr2=nil then;');
|
|
Add(' if nil=arr2 then;');
|
|
Add(' i:=low(arr2);');
|
|
Add(' i:=low(arr2[1]);');
|
|
Add(' i:=high(arr2);');
|
|
Add(' i:=high(arr2[2]);');
|
|
Add(' arr2[3]:=arr;');
|
|
Add(' arr2[4][5]:=i;');
|
|
Add(' i:=arr2[6][7];');
|
|
Add(' arr2[8,9]:=i;');
|
|
Add(' i:=arr2[10,11];');
|
|
Add(' SetLength(arr2,14);');
|
|
Add(' SetLength(arr2[15],16);');
|
|
ConvertProgram;
|
|
CheckSource('TestArray_Dynamic',
|
|
LinesToStr([ // statements
|
|
'this.Arr = [];',
|
|
'this.Arr2 = [];',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Arr2 = [];',
|
|
'if (rtl.length($mod.Arr2) === 0) ;',
|
|
'if (rtl.length($mod.Arr2) === 0) ;',
|
|
'$mod.i = 0;',
|
|
'$mod.i = 0;',
|
|
'$mod.i = rtl.length($mod.Arr2) - 1;',
|
|
'$mod.i = rtl.length($mod.Arr2[2]) - 1;',
|
|
'$mod.Arr2[3] = $mod.Arr;',
|
|
'$mod.Arr2[4][5] = $mod.i;',
|
|
'$mod.i = $mod.Arr2[6][7];',
|
|
'$mod.Arr2[8][9] = $mod.i;',
|
|
'$mod.i = $mod.Arr2[10][11];',
|
|
'$mod.Arr2 = rtl.arraySetLength($mod.Arr2, [], 14);',
|
|
'$mod.Arr2[15] = rtl.arraySetLength($mod.Arr2[15], 0, 16);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_StaticInt;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TArrayInt = array[2..4] of longint;');
|
|
Add('var');
|
|
Add(' Arr: TArrayInt;');
|
|
Add(' Arr2: TArrayInt = (5,6,7);');
|
|
Add(' i: longint;');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add(' arr[2]:=4;');
|
|
Add(' arr[3]:=arr[2]+arr[3];');
|
|
Add(' arr[i]:=5;');
|
|
Add(' arr[arr[i]]:=arr[high(arr)];');
|
|
Add(' i:=low(arr);');
|
|
Add(' i:=high(arr);');
|
|
Add(' b:=arr[2]=arr[3];');
|
|
Add(' arr:=default(TArrayInt);');
|
|
ConvertProgram;
|
|
CheckSource('TestArray_StaticInt',
|
|
LinesToStr([ // statements
|
|
'this.Arr = rtl.arraySetLength(null,0,3);',
|
|
'this.Arr2 = [5, 6, 7];',
|
|
'this.i = 0;',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Arr[0] = 4;',
|
|
'$mod.Arr[1] = $mod.Arr[0] + $mod.Arr[1];',
|
|
'$mod.Arr[$mod.i-2] = 5;',
|
|
'$mod.Arr[$mod.Arr[$mod.i-2]-2] = $mod.Arr[2];',
|
|
'$mod.i = 2;',
|
|
'$mod.i = 4;',
|
|
'$mod.b = $mod.Arr[0] === $mod.Arr[1];',
|
|
'$mod.Arr = rtl.arraySetLength(null,0,3).slice(0);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_StaticBool;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TBools = array[boolean] of boolean;');
|
|
Add(' TBool2 = array[true..true] of boolean;');
|
|
Add('var');
|
|
Add(' Arr: TBools;');
|
|
Add(' Arr2: TBool2;');
|
|
Add(' Arr3: TBools = (true,false);');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add(' b:=low(arr);');
|
|
Add(' b:=high(arr);');
|
|
Add(' arr[true]:=false;');
|
|
Add(' arr[false]:=arr[b] or arr[true];');
|
|
Add(' arr[b]:=true;');
|
|
Add(' arr[arr[b]]:=arr[high(arr)];');
|
|
Add(' b:=arr[false]=arr[true];');
|
|
Add(' b:=low(arr2);');
|
|
Add(' b:=high(arr2);');
|
|
Add(' arr2[true]:=true;');
|
|
Add(' arr2[true]:=arr2[true] and arr2[b];');
|
|
Add(' arr2[b]:=false;');
|
|
ConvertProgram;
|
|
CheckSource('TestArray_StaticBool',
|
|
LinesToStr([ // statements
|
|
'this.Arr = rtl.arraySetLength(null,false,2);',
|
|
'this.Arr2 = rtl.arraySetLength(null,false,1);',
|
|
'this.Arr3 = [true, false];',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.b = false;',
|
|
'$mod.b = true;',
|
|
'$mod.Arr[1] = false;',
|
|
'$mod.Arr[0] = $mod.Arr[+$mod.b] || $mod.Arr[1];',
|
|
'$mod.Arr[+$mod.b] = true;',
|
|
'$mod.Arr[+$mod.Arr[+$mod.b]] = $mod.Arr[1];',
|
|
'$mod.b = $mod.Arr[0] === $mod.Arr[1];',
|
|
'$mod.b = true;',
|
|
'$mod.b = true;',
|
|
'$mod.Arr2[0] = true;',
|
|
'$mod.Arr2[0] = $mod.Arr2[0] && $mod.Arr2[1-$mod.b];',
|
|
'$mod.Arr2[1-$mod.b] = false;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_StaticChar;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TChars = array[char] of char;',
|
|
' TChars2 = array[''a''..''z''] of char;',
|
|
'var',
|
|
' Arr: TChars;',
|
|
' Arr2: TChars2;',
|
|
' Arr3: array[2..4] of char = (''p'',''a'',''s'');',
|
|
' Arr4: array[11..13] of char = ''pas'';',
|
|
' Arr5: array[21..22] of char = ''äö'';',
|
|
' Arr6: array[31..32] of char = ''ä''+''ö'';',
|
|
' c: char;',
|
|
' b: boolean;',
|
|
'begin',
|
|
' c:=low(arr);',
|
|
' c:=high(arr);',
|
|
' arr[''B'']:=''a'';',
|
|
' arr[''D'']:=arr[c];',
|
|
' arr[c]:=arr[''d''];',
|
|
' arr[arr[c]]:=arr[high(arr)];',
|
|
' b:=arr[low(arr)]=arr[''e''];',
|
|
' c:=low(arr2);',
|
|
' c:=high(arr2);',
|
|
' arr2[''b'']:=''f'';',
|
|
' arr2[''a'']:=arr2[c];',
|
|
' arr2[c]:=arr2[''g''];']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_StaticChar',
|
|
LinesToStr([ // statements
|
|
'this.Arr = rtl.arraySetLength(null, "", 65536);',
|
|
'this.Arr2 = rtl.arraySetLength(null, "", 26);',
|
|
'this.Arr3 = ["p", "a", "s"];',
|
|
'this.Arr4 = ["p", "a", "s"];',
|
|
'this.Arr5 = ["ä", "ö"];',
|
|
'this.Arr6 = ["ä", "ö"];',
|
|
'this.c = "";',
|
|
'this.b = false;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.c = "\x00";',
|
|
'$mod.c = "\uFFFF";',
|
|
'$mod.Arr[66] = "a";',
|
|
'$mod.Arr[68] = $mod.Arr[$mod.c.charCodeAt()];',
|
|
'$mod.Arr[$mod.c.charCodeAt()] = $mod.Arr[100];',
|
|
'$mod.Arr[$mod.Arr[$mod.c.charCodeAt()].charCodeAt()] = $mod.Arr[65535];',
|
|
'$mod.b = $mod.Arr[0] === $mod.Arr[101];',
|
|
'$mod.c = "a";',
|
|
'$mod.c = "z";',
|
|
'$mod.Arr2[1] = "f";',
|
|
'$mod.Arr2[0] = $mod.Arr2[$mod.c.charCodeAt() - 97];',
|
|
'$mod.Arr2[$mod.c.charCodeAt() - 97] = $mod.Arr2[6];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_StaticMultiDim;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TArrayInt = array[1..3] of longint;',
|
|
' TArrayArrayInt = array[5..6] of TArrayInt;',
|
|
'var',
|
|
' Arr: TArrayInt;',
|
|
' Arr2: TArrayArrayInt;',
|
|
' Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
|
|
' i: longint;',
|
|
'begin',
|
|
' i:=low(arr);',
|
|
' i:=low(arr2);',
|
|
' i:=low(arr2[5]);',
|
|
' i:=high(arr);',
|
|
' i:=high(arr2);',
|
|
' i:=high(arr2[6]);',
|
|
' arr2[5]:=arr;',
|
|
' arr2[6][2]:=i;',
|
|
' i:=arr2[6][3];',
|
|
' arr2[6,3]:=i;',
|
|
' i:=arr2[5,2];',
|
|
' arr2:=arr2;',// clone multi dim static array
|
|
//' arr3:=arr3;',// clone anonymous multi dim static array
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_StaticMultiDim',
|
|
LinesToStr([ // statements
|
|
'this.TArrayArrayInt$clone = function (a) {',
|
|
' var r = [];',
|
|
' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
|
|
' return r;',
|
|
'};',
|
|
'this.Arr = rtl.arraySetLength(null, 0, 3);',
|
|
'this.Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
|
|
'this.Arr3 = [[11, 12, 13], [21, 22, 23]];',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.i = 1;',
|
|
'$mod.i = 5;',
|
|
'$mod.i = 1;',
|
|
'$mod.i = 3;',
|
|
'$mod.i = 6;',
|
|
'$mod.i = 3;',
|
|
'$mod.Arr2[0] = $mod.Arr.slice(0);',
|
|
'$mod.Arr2[1][1] = $mod.i;',
|
|
'$mod.i = $mod.Arr2[1][2];',
|
|
'$mod.Arr2[1][2] = $mod.i;',
|
|
'$mod.i = $mod.Arr2[0][1];',
|
|
'$mod.Arr2 = $mod.TArrayArrayInt$clone($mod.Arr2);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArrayOfRecord;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TRec = record',
|
|
' Int: longint;',
|
|
' end;',
|
|
' TArrayRec = array of TRec;',
|
|
'var',
|
|
' Arr: TArrayRec;',
|
|
' r: TRec;',
|
|
' i: longint;',
|
|
'begin',
|
|
' SetLength(arr,3);',
|
|
' arr[0].int:=4;',
|
|
' arr[1].int:=length(arr)+arr[2].int;',
|
|
' arr[arr[i].int].int:=arr[5].int;',
|
|
' arr[7]:=r;',
|
|
' r:=arr[8];',
|
|
' i:=low(arr);',
|
|
' i:=high(arr);']);
|
|
ConvertProgram;
|
|
CheckSource('TestArrayOfRecord',
|
|
LinesToStr([ // statements
|
|
'this.TRec = function (s) {',
|
|
' if (s) {',
|
|
' this.Int = s.Int;',
|
|
' } else {',
|
|
' this.Int = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.Int === b.Int;',
|
|
' };',
|
|
'};',
|
|
'this.Arr = [];',
|
|
'this.r = new $mod.TRec();',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Arr = rtl.arraySetLength($mod.Arr,$mod.TRec,3);',
|
|
'$mod.Arr[0].Int = 4;',
|
|
'$mod.Arr[1].Int = rtl.length($mod.Arr)+$mod.Arr[2].Int;',
|
|
'$mod.Arr[$mod.Arr[$mod.i].Int].Int = $mod.Arr[5].Int;',
|
|
'$mod.Arr[7] = new $mod.TRec($mod.r);',
|
|
'$mod.r = new $mod.TRec($mod.Arr[8]);',
|
|
'$mod.i = 0;',
|
|
'$mod.i = rtl.length($mod.Arr)-1;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_StaticRecord;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TRec = record',
|
|
' Int: longint;',
|
|
' end;',
|
|
' TArrayRec = array[1..2] of TRec;',
|
|
'var',
|
|
' Arr: TArrayRec;',
|
|
'begin',
|
|
' arr[1].int:=length(arr)+low(arr)+high(arr);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_StaticRecord',
|
|
LinesToStr([ // statements
|
|
'this.TRec = function (s) {',
|
|
' if (s) {',
|
|
' this.Int = s.Int;',
|
|
' } else {',
|
|
' this.Int = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.Int === b.Int;',
|
|
' };',
|
|
'};',
|
|
'this.TArrayRec$clone = function (a) {',
|
|
' var r = [];',
|
|
' for (var i = 0; i < 2; i++) r.push(new $mod.TRec(a[i]));',
|
|
' return r;',
|
|
'};',
|
|
'this.Arr = rtl.arraySetLength(null, $mod.TRec, 2);',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Arr[0].Int = (2 + 1) + 2;']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArrayOfSet;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TFlag = (big,small);',
|
|
' TSetOfFlag = set of tflag;',
|
|
' TArrayFlag = array of TSetOfFlag;',
|
|
'procedure DoIt(const a: Tarrayflag);',
|
|
'begin',
|
|
'end;',
|
|
'var',
|
|
' f: TFlag;',
|
|
' s: TSetOfFlag;',
|
|
' Arr: TArrayFlag;',
|
|
' i: longint;',
|
|
'begin',
|
|
' SetLength(arr,3);',
|
|
' arr[0]:=s;',
|
|
' arr[1]:=[big];',
|
|
' arr[2]:=[big]+s;',
|
|
' arr[3]:=s+[big];',
|
|
' arr[4]:=arr[5];',
|
|
' s:=arr[6];',
|
|
' i:=low(arr);',
|
|
' i:=high(arr);',
|
|
' DoIt(arr);',
|
|
' DoIt([s]);',
|
|
' DoIt([[],s]);',
|
|
' DoIt([s,[]]);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArrayOfSet',
|
|
LinesToStr([ // statements
|
|
'this.TFlag = {',
|
|
' "0": "big",',
|
|
' big: 0,',
|
|
' "1": "small",',
|
|
' small: 1',
|
|
'};',
|
|
'this.DoIt = function (a) {',
|
|
'};',
|
|
'this.f = 0;',
|
|
'this.s = {};',
|
|
'this.Arr = [];',
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Arr = rtl.arraySetLength($mod.Arr, {}, 3);',
|
|
'$mod.Arr[0] = rtl.refSet($mod.s);',
|
|
'$mod.Arr[1] = rtl.createSet($mod.TFlag.big);',
|
|
'$mod.Arr[2] = rtl.unionSet(rtl.createSet($mod.TFlag.big), $mod.s);',
|
|
'$mod.Arr[3] = rtl.unionSet($mod.s, rtl.createSet($mod.TFlag.big));',
|
|
'$mod.Arr[4] = rtl.refSet($mod.Arr[5]);',
|
|
'$mod.s = rtl.refSet($mod.Arr[6]);',
|
|
'$mod.i = 0;',
|
|
'$mod.i = rtl.length($mod.Arr) - 1;',
|
|
'$mod.DoIt($mod.Arr);',
|
|
'$mod.DoIt([rtl.refSet($mod.s)]);',
|
|
'$mod.DoIt([{}, rtl.refSet($mod.s)]);',
|
|
'$mod.DoIt([rtl.refSet($mod.s), {}]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_DynAsParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type integer = longint;',
|
|
'type TArrInt = array of integer;',
|
|
'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
|
|
'var vJ: TArrInt;',
|
|
'begin',
|
|
' vg:=vg;',
|
|
' vj:=vh;',
|
|
' vi:=vi;',
|
|
' doit(vg,vg,vg);',
|
|
' doit(vh,vh,vj);',
|
|
' doit(vi,vi,vi);',
|
|
' doit(vj,vj,vj);',
|
|
'end;',
|
|
'var i: TArrInt;',
|
|
'begin',
|
|
' doit(i,i,i);']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_DynAsParams',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
' var vJ = [];',
|
|
' vG = vG;',
|
|
' vJ = vH;',
|
|
' vI.set(vI.get());',
|
|
' $mod.DoIt(vG, vG, {',
|
|
' get: function () {',
|
|
' return vG;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vG = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(vH, vH, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(vI.get(), vI.get(), vI);',
|
|
' $mod.DoIt(vJ, vJ, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
'};',
|
|
'this.i = [];'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt($mod.i,$mod.i,{',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_StaticAsParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type integer = longint;',
|
|
'type TArrInt = array[1..2] of integer;',
|
|
'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
|
|
'var vJ: TArrInt;',
|
|
'begin',
|
|
' vg:=vg;',
|
|
' vj:=vh;',
|
|
' vi:=vi;',
|
|
' doit(vg,vg,vg);',
|
|
' doit(vh,vh,vj);',
|
|
' doit(vi,vi,vi);',
|
|
' doit(vj,vj,vj);',
|
|
'end;',
|
|
'var i: TArrInt;',
|
|
'begin',
|
|
' doit(i,i,i);']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_StaticAsParams',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
' var vJ = rtl.arraySetLength(null, 0, 2);',
|
|
' vG = vG.slice(0);',
|
|
' vJ = vH.slice(0);',
|
|
' vI.set(vI.get().slice(0));',
|
|
' $mod.DoIt(vG.slice(0), vG, {',
|
|
' get: function () {',
|
|
' return vG;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vG = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(vH.slice(0), vH, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(vI.get().slice(0), vI.get(), vI);',
|
|
' $mod.DoIt(vJ.slice(0), vJ, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
'};',
|
|
'this.i = rtl.arraySetLength(null, 0, 2);'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt($mod.i.slice(0),$mod.i,{',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestArrayElement_AsParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type integer = longint;');
|
|
Add('type TArrayInt = array of integer;');
|
|
Add('procedure DoIt(vG: Integer; const vH: Integer; var vI: Integer);');
|
|
Add('var vJ: tarrayint;');
|
|
Add('begin');
|
|
Add(' vi:=vi;');
|
|
Add(' doit(vi,vi,vi);');
|
|
Add(' doit(vj[1+1],vj[1+2],vj[1+3]);');
|
|
Add('end;');
|
|
Add('var a: TArrayInt;');
|
|
Add('begin');
|
|
Add(' doit(a[1+4],a[1+5],a[1+6]);');
|
|
ConvertProgram;
|
|
CheckSource('TestArrayElement_AsParams',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
' var vJ = [];',
|
|
' vI.set(vI.get());',
|
|
' $mod.DoIt(vI.get(), vI.get(), vI);',
|
|
' $mod.DoIt(vJ[1+1], vJ[1+2], {',
|
|
' a:1+3,',
|
|
' p:vJ,',
|
|
' get: function () {',
|
|
' return this.p[this.a];',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p[this.a] = v;',
|
|
' }',
|
|
' });',
|
|
'};',
|
|
'this.a = [];'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt($mod.a[1+4],$mod.a[1+5],{',
|
|
' a: 1+6,',
|
|
' p: $mod.a,',
|
|
' get: function () {',
|
|
' return this.p[this.a];',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p[this.a] = v;',
|
|
' }',
|
|
'});'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestArrayElementFromFuncResult_AsParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type Integer = longint;');
|
|
Add('type TArrayInt = array of integer;');
|
|
Add('function GetArr(vB: integer = 0): tarrayint;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('begin');
|
|
Add(' doit(getarr[1+1],getarr[1+2],getarr[1+3]);');
|
|
Add(' doit(getarr()[2+1],getarr()[2+2],getarr()[2+3]);');
|
|
Add(' doit(getarr(7)[3+1],getarr(8)[3+2],getarr(9)[3+3]);');
|
|
ConvertProgram;
|
|
CheckSource('TestArrayElementFromFuncResult_AsParams',
|
|
LinesToStr([ // statements
|
|
'this.GetArr = function (vB) {',
|
|
' var Result = [];',
|
|
' return Result;',
|
|
'};',
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
'};'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt($mod.GetArr(0)[1+1],$mod.GetArr(0)[1+2],{',
|
|
' a: 1+3,',
|
|
' p: $mod.GetArr(0),',
|
|
' get: function () {',
|
|
' return this.p[this.a];',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p[this.a] = v;',
|
|
' }',
|
|
'});',
|
|
'$mod.DoIt($mod.GetArr(0)[2+1],$mod.GetArr(0)[2+2],{',
|
|
' a: 2+3,',
|
|
' p: $mod.GetArr(0),',
|
|
' get: function () {',
|
|
' return this.p[this.a];',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p[this.a] = v;',
|
|
' }',
|
|
'});',
|
|
'$mod.DoIt($mod.GetArr(7)[3+1],$mod.GetArr(8)[3+2],{',
|
|
' a: 3+3,',
|
|
' p: $mod.GetArr(9),',
|
|
' get: function () {',
|
|
' return this.p[this.a];',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p[this.a] = v;',
|
|
' }',
|
|
'});',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArrayEnumTypeRange;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (red,blue);',
|
|
' TEnumArray = array[TEnum] of longint;',
|
|
'var',
|
|
' e: TEnum;',
|
|
' i: longint;',
|
|
' a: TEnumArray;',
|
|
' numbers: TEnumArray = (1,2);',
|
|
' names: array[TEnum] of string = (''red'',''blue'');',
|
|
'begin',
|
|
' e:=low(a);',
|
|
' e:=high(a);',
|
|
' i:=a[red];',
|
|
' a[e]:=a[e];']);
|
|
ConvertProgram;
|
|
CheckSource('TestArrayEnumTypeRange',
|
|
LinesToStr([ // statements
|
|
' this.TEnum = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "blue",',
|
|
' blue: 1',
|
|
'};',
|
|
'this.e = 0;',
|
|
'this.i = 0;',
|
|
'this.a = rtl.arraySetLength(null,0,2);',
|
|
'this.numbers = [1, 2];',
|
|
'this.names = ["red", "blue"];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.e = $mod.TEnum.red;',
|
|
'$mod.e = $mod.TEnum.blue;',
|
|
'$mod.i = $mod.a[$mod.TEnum.red];',
|
|
'$mod.a[$mod.e] = $mod.a[$mod.e];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_SetLengthOutArg;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type TArrInt = array of longint;',
|
|
'procedure DoIt(out a: TArrInt);',
|
|
'begin',
|
|
' SetLength(a,2);',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_SetLengthOutArg',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (a) {',
|
|
' a.set(rtl.arraySetLength(a.get(), 0, 2));',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_SetLengthProperty;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TArrInt = array of longint;');
|
|
Add(' TObject = class');
|
|
Add(' function GetColors: TArrInt; external name ''GetColors'';');
|
|
Add(' procedure SetColors(const Value: TArrInt); external name ''SetColors'';');
|
|
Add(' property Colors: TArrInt read GetColors write SetColors;');
|
|
Add(' end;');
|
|
Add('var Obj: TObject;');
|
|
Add('begin');
|
|
Add(' SetLength(Obj.Colors,2);');
|
|
ConvertProgram;
|
|
CheckSource('TestArray_SetLengthProperty',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.Obj.SetColors(rtl.arraySetLength($mod.Obj.GetColors(), 0, 2));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_SetLengthMultiDim;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TArrArrInt = array of array of longint;',
|
|
'var',
|
|
' a: TArrArrInt;',
|
|
'begin',
|
|
' SetLength(a,2);',
|
|
' SetLength(a,3,4);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_SetLengthMultiDim',
|
|
LinesToStr([ // statements
|
|
'this.a = [];']),
|
|
LinesToStr([
|
|
'$mod.a = rtl.arraySetLength($mod.a, [], 2);',
|
|
'$mod.a = rtl.arraySetLength($mod.a, 0, 3, 4);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_OpenArrayOfString;
|
|
begin
|
|
StartProgram(false);
|
|
Add('procedure DoIt(const a: array of String);');
|
|
Add('var');
|
|
Add(' i: longint;');
|
|
Add(' s: string;');
|
|
Add('begin');
|
|
Add(' for i:=low(a) to high(a) do s:=a[length(a)-i-1];');
|
|
Add('end;');
|
|
Add('var s: string;');
|
|
Add('begin');
|
|
Add(' DoIt([]);');
|
|
Add(' DoIt([s,''foo'','''',s+s]);');
|
|
ConvertProgram;
|
|
CheckSource('TestArray_OpenArrayOfString',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (a) {',
|
|
' var i = 0;',
|
|
' var s = "";',
|
|
' for (var $l1 = 0, $end2 = rtl.length(a) - 1; $l1 <= $end2; $l1++) {',
|
|
' i = $l1;',
|
|
' s = a[(rtl.length(a) - i) - 1];',
|
|
' };',
|
|
'};',
|
|
'this.s = "";',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.DoIt([]);',
|
|
'$mod.DoIt([$mod.s, "foo", "", $mod.s + $mod.s]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_Concat;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' integer = longint;',
|
|
' TFlag = (big,small);',
|
|
' TFlags = set of TFlag;',
|
|
' TRec = record',
|
|
' i: integer;',
|
|
' end;',
|
|
' TArrInt = array of integer;',
|
|
' TArrRec = array of TRec;',
|
|
' TArrFlag = array of TFlag;',
|
|
' TArrSet = array of TFlags;',
|
|
' TArrJSValue = array of jsvalue;',
|
|
'var',
|
|
' ArrInt: tarrint;',
|
|
' ArrRec: tarrrec;',
|
|
' ArrFlag: tarrflag;',
|
|
' ArrSet: tarrset;',
|
|
' ArrJSValue: tarrjsvalue;',
|
|
'begin',
|
|
' arrint:=concat(arrint);',
|
|
' arrint:=concat(arrint,arrint);',
|
|
' arrint:=concat(arrint,arrint,arrint);',
|
|
' arrrec:=concat(arrrec);',
|
|
' arrrec:=concat(arrrec,arrrec);',
|
|
' arrrec:=concat(arrrec,arrrec,arrrec);',
|
|
' arrset:=concat(arrset);',
|
|
' arrset:=concat(arrset,arrset);',
|
|
' arrset:=concat(arrset,arrset,arrset);',
|
|
' arrjsvalue:=concat(arrjsvalue);',
|
|
' arrjsvalue:=concat(arrjsvalue,arrjsvalue);',
|
|
' arrjsvalue:=concat(arrjsvalue,arrjsvalue,arrjsvalue);',
|
|
' arrint:=concat([1],arrint);',
|
|
' arrflag:=concat([big]);',
|
|
' arrflag:=concat([big],arrflag);',
|
|
' arrflag:=concat(arrflag,[small]);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_Concat',
|
|
LinesToStr([ // statements
|
|
'this.TFlag = {',
|
|
' "0": "big",',
|
|
' big: 0,',
|
|
' "1": "small",',
|
|
' small: 1',
|
|
'};',
|
|
'this.TRec = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.i === b.i;',
|
|
' };',
|
|
'};',
|
|
'this.ArrInt = [];',
|
|
'this.ArrRec = [];',
|
|
'this.ArrFlag = [];',
|
|
'this.ArrSet = [];',
|
|
'this.ArrJSValue = [];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.ArrInt = $mod.ArrInt;',
|
|
'$mod.ArrInt = rtl.arrayConcatN($mod.ArrInt, $mod.ArrInt);',
|
|
'$mod.ArrInt = rtl.arrayConcatN($mod.ArrInt, $mod.ArrInt, $mod.ArrInt);',
|
|
'$mod.ArrRec = $mod.ArrRec;',
|
|
'$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec);',
|
|
'$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec, $mod.ArrRec);',
|
|
'$mod.ArrSet = $mod.ArrSet;',
|
|
'$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet);',
|
|
'$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet, $mod.ArrSet);',
|
|
'$mod.ArrJSValue = $mod.ArrJSValue;',
|
|
'$mod.ArrJSValue = rtl.arrayConcatN($mod.ArrJSValue, $mod.ArrJSValue);',
|
|
'$mod.ArrJSValue = rtl.arrayConcatN($mod.ArrJSValue, $mod.ArrJSValue, $mod.ArrJSValue);',
|
|
'$mod.ArrInt = rtl.arrayConcatN([1], $mod.ArrInt);',
|
|
'$mod.ArrFlag = [$mod.TFlag.big];',
|
|
'$mod.ArrFlag = rtl.arrayConcatN([$mod.TFlag.big], $mod.ArrFlag);',
|
|
'$mod.ArrFlag = rtl.arrayConcatN($mod.ArrFlag, [$mod.TFlag.small]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_Copy;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' integer = longint;',
|
|
' TFlag = (big,small);',
|
|
' TFlags = set of TFlag;',
|
|
' TRec = record',
|
|
' i: integer;',
|
|
' end;',
|
|
' TArrInt = array of integer;',
|
|
' TArrRec = array of TRec;',
|
|
' TArrSet = array of TFlags;',
|
|
' TArrJSValue = array of jsvalue;',
|
|
'var',
|
|
' ArrInt: tarrint;',
|
|
' ArrRec: tarrrec;',
|
|
' ArrSet: tarrset;',
|
|
' ArrJSValue: tarrjsvalue;',
|
|
'begin',
|
|
' arrint:=copy(arrint);',
|
|
' arrint:=copy(arrint,2);',
|
|
' arrint:=copy(arrint,3,4);',
|
|
' arrint:=copy([1,1],1,2);',
|
|
' arrrec:=copy(arrrec);',
|
|
' arrrec:=copy(arrrec,5);',
|
|
' arrrec:=copy(arrrec,6,7);',
|
|
' arrset:=copy(arrset);',
|
|
' arrset:=copy(arrset,8);',
|
|
' arrset:=copy(arrset,9,10);',
|
|
' arrjsvalue:=copy(arrjsvalue);',
|
|
' arrjsvalue:=copy(arrjsvalue,11);',
|
|
' arrjsvalue:=copy(arrjsvalue,12,13);',
|
|
' ']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_Copy',
|
|
LinesToStr([ // statements
|
|
'this.TFlag = {',
|
|
' "0": "big",',
|
|
' big: 0,',
|
|
' "1": "small",',
|
|
' small: 1',
|
|
'};',
|
|
'this.TRec = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.i === b.i;',
|
|
' };',
|
|
'};',
|
|
'this.ArrInt = [];',
|
|
'this.ArrRec = [];',
|
|
'this.ArrSet = [];',
|
|
'this.ArrJSValue = [];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 0);',
|
|
'$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 2);',
|
|
'$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 3, 4);',
|
|
'$mod.ArrInt = rtl.arrayCopy(0, [1, 1], 1, 2);',
|
|
'$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 0);',
|
|
'$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 5);',
|
|
'$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 6, 7);',
|
|
'$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 0);',
|
|
'$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 8);',
|
|
'$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 9, 10);',
|
|
'$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 0);',
|
|
'$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 11);',
|
|
'$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 12, 13);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_InsertDelete;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' integer = longint;',
|
|
' TFlag = (big,small);',
|
|
' TFlags = set of TFlag;',
|
|
' TRec = record',
|
|
' i: integer;',
|
|
' end;',
|
|
' TArrInt = array of integer;',
|
|
' TArrRec = array of TRec;',
|
|
' TArrSet = array of TFlags;',
|
|
' TArrJSValue = array of jsvalue;',
|
|
' TArrArrInt = array of TArrInt;',
|
|
'var',
|
|
' ArrInt: tarrint;',
|
|
' ArrRec: tarrrec;',
|
|
' ArrSet: tarrset;',
|
|
' ArrJSValue: tarrjsvalue;',
|
|
' ArrArrInt: TArrArrInt;',
|
|
'begin',
|
|
' Insert(1,arrint,2);',
|
|
' Insert(arrint[3],arrint,4);',
|
|
' Insert(arrrec[5],arrrec,6);',
|
|
' Insert(arrset[7],arrset,7);',
|
|
' Insert(arrjsvalue[8],arrjsvalue,9);',
|
|
' Insert(10,arrjsvalue,11);',
|
|
' Insert([23],arrarrint,22);',
|
|
' Delete(arrint,12,13);',
|
|
' Delete(arrrec,14,15);',
|
|
' Delete(arrset,17,18);',
|
|
' Delete(arrjsvalue,19,10);']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_InsertDelete',
|
|
LinesToStr([ // statements
|
|
'this.TFlag = {',
|
|
' "0": "big",',
|
|
' big: 0,',
|
|
' "1": "small",',
|
|
' small: 1',
|
|
'};',
|
|
'this.TRec = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.i === b.i;',
|
|
' };',
|
|
'};',
|
|
'this.ArrInt = [];',
|
|
'this.ArrRec = [];',
|
|
'this.ArrSet = [];',
|
|
'this.ArrJSValue = [];',
|
|
'this.ArrArrInt = [];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.ArrInt.splice(2, 0, 1);',
|
|
'$mod.ArrInt.splice(4, 0, $mod.ArrInt[3]);',
|
|
'$mod.ArrRec.splice(6, 0, $mod.ArrRec[5]);',
|
|
'$mod.ArrSet.splice(7, 0, $mod.ArrSet[7]);',
|
|
'$mod.ArrJSValue.splice(9, 0, $mod.ArrJSValue[8]);',
|
|
'$mod.ArrJSValue.splice(11, 0, 10);',
|
|
'$mod.ArrArrInt.splice(22, 0, [23]);',
|
|
'$mod.ArrInt.splice(12, 13);',
|
|
'$mod.ArrRec.splice(14, 15);',
|
|
'$mod.ArrSet.splice(17, 18);',
|
|
'$mod.ArrJSValue.splice(19, 10);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_DynArrayConstObjFPC;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch arrayoperators}',
|
|
'type',
|
|
' integer = longint;',
|
|
' TArrInt = array of integer;',
|
|
' TArrStr = array of string;',
|
|
'const',
|
|
' Ints: TArrInt = (1,2,3);',
|
|
' Aliases: TarrStr = (''foo'',''b'');',
|
|
' OneInt: TArrInt = (7);',
|
|
' OneStr: array of integer = (7);',
|
|
' Chars: array of char = ''aoc'';',
|
|
' Names: array of string = (''a'',''foo'');',
|
|
' NameCount = low(Names)+high(Names)+length(Names);',
|
|
'var i: integer;',
|
|
'begin',
|
|
' Ints:=[];',
|
|
' Ints:=[1,1];',
|
|
' Ints:=[1]+[2];',
|
|
' Ints:=[2];',
|
|
' Ints:=[]+ints;',
|
|
' Ints:=Ints+[];',
|
|
' Ints:=Ints+OneInt;',
|
|
' Ints:=Ints+[1,1];',
|
|
' Ints:=[i,i]+Ints;',
|
|
' Ints:=[1]+[i]+[3];',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_DynArrayConstObjFPC',
|
|
LinesToStr([ // statements
|
|
'this.Ints = [1, 2, 3];',
|
|
'this.Aliases = ["foo", "b"];',
|
|
'this.OneInt = [7];',
|
|
'this.OneStr = [7];',
|
|
'this.Chars = ["a", "o", "c"];',
|
|
'this.Names = ["a", "foo"];',
|
|
'this.NameCount = (0 + (rtl.length($mod.Names) - 1)) + rtl.length($mod.Names);',
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Ints = [];',
|
|
'$mod.Ints = [1, 1];',
|
|
'$mod.Ints = rtl.arrayConcatN([1], [2]);',
|
|
'$mod.Ints = [2];',
|
|
'$mod.Ints = rtl.arrayConcatN([], $mod.Ints);',
|
|
'$mod.Ints = rtl.arrayConcatN($mod.Ints, []);',
|
|
'$mod.Ints = rtl.arrayConcatN($mod.Ints, $mod.OneInt);',
|
|
'$mod.Ints = rtl.arrayConcatN($mod.Ints, [1, 1]);',
|
|
'$mod.Ints = rtl.arrayConcatN([$mod.i, $mod.i], $mod.Ints);',
|
|
'$mod.Ints = rtl.arrayConcatN(rtl.arrayConcatN([1], [$mod.i]), [3]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_DynArrayConstDelphi;
|
|
begin
|
|
StartProgram(false);
|
|
// Note: const c = [1,1]; defines a set!
|
|
Add([
|
|
'{$mode delphi}',
|
|
'type',
|
|
' integer = longint;',
|
|
' TArrInt = array of integer;',
|
|
' TArrStr = array of string;',
|
|
'const',
|
|
' Ints: TArrInt = [1,1,2];',
|
|
' Aliases: TarrStr = [''foo'',''b''];',
|
|
' OneInt: TArrInt = [7];',
|
|
' OneStr: array of integer = [7]+[8];',
|
|
' Chars: array of char = ''aoc'';',
|
|
' Names: array of string = [''a'',''a''];',
|
|
' NameCount = low(Names)+high(Names)+length(Names);',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_DynArrayConstDelphi',
|
|
LinesToStr([ // statements
|
|
'this.Ints = [1, 1, 2];',
|
|
'this.Aliases = ["foo", "b"];',
|
|
'this.OneInt = [7];',
|
|
'this.OneStr = rtl.arrayConcatN([7],[8]);',
|
|
'this.Chars = ["a", "o", "c"];',
|
|
'this.Names = ["a", "a"];',
|
|
'this.NameCount = (0 + (rtl.length($mod.Names) - 1)) + rtl.length($mod.Names);',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_ArrayLitAsParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch arrayoperators}',
|
|
'type',
|
|
' integer = longint;',
|
|
' TArrInt = array of integer;',
|
|
' TArrSet = array of (red,green,blue);',
|
|
'procedure DoOpenInt(a: array of integer); forward;',
|
|
'procedure DoInt(a: TArrInt);',
|
|
'begin',
|
|
' DoInt(a+[1]);',
|
|
' DoInt([1]+a);',
|
|
' DoOpenInt(a);',
|
|
' DoOpenInt(a+[1]);',
|
|
' DoOpenInt([1]+a);',
|
|
'end;',
|
|
'procedure DoOpenInt(a: array of integer);',
|
|
'begin',
|
|
' DoOpenInt(a+[1]);',
|
|
' DoOpenInt([1]+a);',
|
|
' DoInt(a);',
|
|
' DoInt(a+[1]);',
|
|
' DoInt([1]+a);',
|
|
'end;',
|
|
'procedure DoSet(a: TArrSet);',
|
|
'begin',
|
|
' DoSet(a+[red]);',
|
|
' DoSet([blue]+a);',
|
|
'end;',
|
|
'var',
|
|
' i: TArrInt;',
|
|
' s: TArrSet;',
|
|
'begin',
|
|
' DoInt([1]);',
|
|
' DoInt([1]+[2]);',
|
|
' DoInt(i+[1]);',
|
|
' DoInt([1]+i);',
|
|
' DoOpenInt([1]);',
|
|
' DoOpenInt([1]+[2]);',
|
|
' DoOpenInt(i+[1]);',
|
|
' DoOpenInt([1]+i);',
|
|
' DoSet([red]);',
|
|
' DoSet([blue]+[green]);',
|
|
' DoSet(s+[blue]);',
|
|
' DoSet([red]+s);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_ArrayLitAsParam',
|
|
LinesToStr([ // statements
|
|
'this.TArrSet$a = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "green",',
|
|
' green: 1,',
|
|
' "2": "blue",',
|
|
' blue: 2',
|
|
'};',
|
|
'this.DoInt = function (a) {',
|
|
' $mod.DoInt(rtl.arrayConcatN(a, [1]));',
|
|
' $mod.DoInt(rtl.arrayConcatN([1], a));',
|
|
' $mod.DoOpenInt(a);',
|
|
' $mod.DoOpenInt(rtl.arrayConcatN(a, [1]));',
|
|
' $mod.DoOpenInt(rtl.arrayConcatN([1], a));',
|
|
'};',
|
|
'this.DoOpenInt = function (a) {',
|
|
' $mod.DoOpenInt(rtl.arrayConcatN(a, [1]));',
|
|
' $mod.DoOpenInt(rtl.arrayConcatN([1], a));',
|
|
' $mod.DoInt(a);',
|
|
' $mod.DoInt(rtl.arrayConcatN(a, [1]));',
|
|
' $mod.DoInt(rtl.arrayConcatN([1], a));',
|
|
'};',
|
|
'this.DoSet = function (a) {',
|
|
' $mod.DoSet(rtl.arrayConcatN(a, [$mod.TArrSet$a.red]));',
|
|
' $mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.blue], a));',
|
|
'};',
|
|
'this.i = [];',
|
|
'this.s = [];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoInt([1]);',
|
|
'$mod.DoInt(rtl.arrayConcatN([1], [2]));',
|
|
'$mod.DoInt(rtl.arrayConcatN($mod.i, [1]));',
|
|
'$mod.DoInt(rtl.arrayConcatN([1], $mod.i));',
|
|
'$mod.DoOpenInt([1]);',
|
|
'$mod.DoOpenInt(rtl.arrayConcatN([1], [2]));',
|
|
'$mod.DoOpenInt(rtl.arrayConcatN($mod.i, [1]));',
|
|
'$mod.DoOpenInt(rtl.arrayConcatN([1], $mod.i));',
|
|
'$mod.DoSet([$mod.TArrSet$a.red]);',
|
|
'$mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.blue], [$mod.TArrSet$a.green]));',
|
|
'$mod.DoSet(rtl.arrayConcatN($mod.s, [$mod.TArrSet$a.blue]));',
|
|
'$mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.red], $mod.s));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_ArrayLitMultiDimAsParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch arrayoperators}',
|
|
'type',
|
|
' integer = longint;',
|
|
' TArrInt = array of integer;',
|
|
' TArrArrInt = array of TArrInt;',
|
|
'procedure DoInt(a: TArrArrInt);',
|
|
'begin',
|
|
' DoInt(a+[[1]]);',
|
|
' DoInt([[1]]+a);',
|
|
' DoInt(a);',
|
|
'end;',
|
|
'var',
|
|
' i: TArrInt;',
|
|
' a: TArrArrInt;',
|
|
'begin',
|
|
' a:=[[1]];',
|
|
' a:=[i];',
|
|
' a:=a+[i];',
|
|
' a:=[i]+a;',
|
|
' a:=[[1]+i];',
|
|
' a:=[[1]+[2]];',
|
|
' a:=[i+[2]];',
|
|
' DoInt([[1]]);',
|
|
' DoInt([[1]+[2],[3,4],[5]]);',
|
|
' DoInt([i+[1]]+a);',
|
|
' DoInt([i]+a);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_ArrayLitMultiDimAsParam',
|
|
LinesToStr([ // statements
|
|
'this.DoInt = function (a) {',
|
|
' $mod.DoInt(rtl.arrayConcatN(a, [[1]]));',
|
|
' $mod.DoInt(rtl.arrayConcatN([[1]], a));',
|
|
' $mod.DoInt(a);',
|
|
'};',
|
|
'this.i = [];',
|
|
'this.a = [];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.a = [[1]];',
|
|
'$mod.a = [$mod.i];',
|
|
'$mod.a = rtl.arrayConcatN($mod.a, [$mod.i]);',
|
|
'$mod.a = rtl.arrayConcatN([$mod.i], $mod.a);',
|
|
'$mod.a = [rtl.arrayConcatN([1], $mod.i)];',
|
|
'$mod.a = [rtl.arrayConcatN([1], [2])];',
|
|
'$mod.a = [rtl.arrayConcatN($mod.i, [2])];',
|
|
'$mod.DoInt([[1]]);',
|
|
'$mod.DoInt([rtl.arrayConcatN([1], [2]), [3, 4], [5]]);',
|
|
'$mod.DoInt(rtl.arrayConcatN([rtl.arrayConcatN($mod.i, [1])], $mod.a));',
|
|
'$mod.DoInt(rtl.arrayConcatN([$mod.i], $mod.a));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_ArrayLitStaticAsParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch arrayoperators}',
|
|
'type',
|
|
' integer = longint;',
|
|
' TArrInt = array[1..2] of integer;',
|
|
' TArrArrInt = array of TArrInt;',
|
|
'procedure DoInt(a: TArrArrInt);',
|
|
'begin',
|
|
' DoInt(a+[[1,2]]);',
|
|
' DoInt([[1,2]]+a);',
|
|
' DoInt(a);',
|
|
'end;',
|
|
'var',
|
|
' i: TArrInt;',
|
|
' a: TArrArrInt;',
|
|
'begin',
|
|
' a:=[[1,1]];',
|
|
' a:=[i];',
|
|
' a:=a+[i];',
|
|
' a:=[i]+a;',
|
|
' DoInt([[1,1]]);',
|
|
' DoInt([[1,2],[3,4]]);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_ArrayLitStaticAsParam',
|
|
LinesToStr([ // statements
|
|
'this.DoInt = function (a) {',
|
|
' $mod.DoInt(rtl.arrayConcatN(a, [[1, 2]]));',
|
|
' $mod.DoInt(rtl.arrayConcatN([[1, 2]], a));',
|
|
' $mod.DoInt(a);',
|
|
'};',
|
|
'this.i = rtl.arraySetLength(null, 0, 2);',
|
|
'this.a = [];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.a = [[1, 1]];',
|
|
'$mod.a = [$mod.i.slice(0)];',
|
|
'$mod.a = rtl.arrayConcatN($mod.a, [$mod.i.slice(0)]);',
|
|
'$mod.a = rtl.arrayConcatN([$mod.i.slice(0)], $mod.a);',
|
|
'$mod.DoInt([[1, 1]]);',
|
|
'$mod.DoInt([[1, 2], [3, 4]]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestArray_ForInArrOfString;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
'type',
|
|
' TMonthNameArray = array [1..12] of string;',
|
|
' TMonthNames = TMonthNameArray;',
|
|
' TObject = class',
|
|
' private',
|
|
' function GetLongMonthNames: TMonthNames; virtual; abstract;',
|
|
' public',
|
|
' Property LongMonthNames : TMonthNames Read GetLongMonthNames;',
|
|
' end;',
|
|
'var f: TObject;',
|
|
' Month: string;',
|
|
'begin',
|
|
' for Month in f.LongMonthNames do ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestArray_ForInArrOfString',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.f = null;',
|
|
'this.Month = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'for (var $in1 = $mod.f.GetLongMonthNames(), $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) $mod.Month = $in1[$l2];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_TypeCastArrayToExternalClass;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TJSObject = class external name ''Object''',
|
|
' end;',
|
|
' TJSArray = class external name ''Array''',
|
|
' class function isArray(Value: JSValue) : boolean;',
|
|
' function concat() : TJSArray; varargs;',
|
|
' end;',
|
|
'var',
|
|
' aObj: TJSArray;',
|
|
' a: array of longint;',
|
|
' o: TJSObject;',
|
|
'begin',
|
|
' if TJSArray.isArray(65) then ;',
|
|
' aObj:=TJSArray(a).concat(a);',
|
|
' o:=TJSObject(a);']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_TypeCastArrayToExternalClass',
|
|
LinesToStr([ // statements
|
|
'this.aObj = null;',
|
|
'this.a = [];',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'if (Array.isArray(65)) ;',
|
|
'$mod.aObj = $mod.a.concat($mod.a);',
|
|
'$mod.o = $mod.a;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_TypeCastArrayFromExternalClass;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TArrStr = array of string;',
|
|
' TJSArray = class external name ''Array''',
|
|
' end;',
|
|
' TJSObject = class external name ''Object''',
|
|
' end;',
|
|
'var',
|
|
' aObj: TJSArray;',
|
|
' a: TArrStr;',
|
|
' jo: TJSObject;',
|
|
'begin',
|
|
' a:=TArrStr(aObj);',
|
|
' TArrStr(aObj)[1]:=TArrStr(aObj)[2];',
|
|
' a:=TarrStr(jo);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_TypeCastArrayFromExternalClass',
|
|
LinesToStr([ // statements
|
|
'this.aObj = null;',
|
|
'this.a = [];',
|
|
'this.jo = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.a = $mod.aObj;',
|
|
'$mod.aObj[1] = $mod.aObj[2];',
|
|
'$mod.a = $mod.jo;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_Empty;
|
|
begin
|
|
StartProgram(false);
|
|
Add(['type',
|
|
' TRecA = record',
|
|
' end;',
|
|
'var a,b: TRecA;',
|
|
'begin',
|
|
' if a=b then ;']);
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_Empty',
|
|
LinesToStr([ // statements
|
|
'this.TRecA = function (s) {',
|
|
' this.$equal = function (b) {',
|
|
' return true;',
|
|
' };',
|
|
'};',
|
|
'this.a = new $mod.TRecA();',
|
|
'this.b = new $mod.TRecA();'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'if ($mod.a.$equal($mod.b)) ;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_Var;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TRecA = record');
|
|
Add(' Bold: longint;');
|
|
Add(' end;');
|
|
Add('var Rec: TRecA;');
|
|
Add('begin');
|
|
Add(' rec.bold:=123');
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_Var',
|
|
LinesToStr([ // statements
|
|
'this.TRecA = function (s) {',
|
|
' if (s) {',
|
|
' this.Bold = s.Bold;',
|
|
' } else {',
|
|
' this.Bold = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.Bold === b.Bold;',
|
|
' };',
|
|
'};',
|
|
'this.Rec = new $mod.TRecA();'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Rec.Bold = 123;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_VarExternal;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TRecA = record',
|
|
' i: byte;',
|
|
' length_: longint external name ''length'';',
|
|
' end;',
|
|
'var Rec: TRecA;',
|
|
'begin',
|
|
' rec.length_ := rec.length_',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_VarExternal',
|
|
LinesToStr([ // statements
|
|
'this.TRecA = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' this.length = s.length;',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.i === b.i) && (this.length === b.length);',
|
|
' };',
|
|
'};',
|
|
'this.Rec = new $mod.TRecA();',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Rec.length = $mod.Rec.length;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestWithRecordDo;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TRec = record');
|
|
Add(' vI: longint;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' Int: longint;');
|
|
Add(' r: TRec;');
|
|
Add('begin');
|
|
Add(' with r do');
|
|
Add(' int:=vi;');
|
|
Add(' with r do begin');
|
|
Add(' int:=vi;');
|
|
Add(' vi:=int;');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestWithRecordDo',
|
|
LinesToStr([ // statements
|
|
'this.TRec = function (s) {',
|
|
' if (s) {',
|
|
' this.vI = s.vI;',
|
|
' } else {',
|
|
' this.vI = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.vI === b.vI;',
|
|
' };',
|
|
'};',
|
|
'this.Int = 0;',
|
|
'this.r = new $mod.TRec();'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'var $with1 = $mod.r;',
|
|
'$mod.Int = $with1.vI;',
|
|
'var $with2 = $mod.r;',
|
|
'$mod.Int = $with2.vI;',
|
|
'$with2.vI = $mod.Int;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_Assign;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TEnum = (red,green);');
|
|
Add(' TEnums = set of TEnum;');
|
|
Add(' TSmallRec = record');
|
|
Add(' N: longint;');
|
|
Add(' end;');
|
|
Add(' TBigRec = record');
|
|
Add(' Int: longint;');
|
|
Add(' D: double;');
|
|
Add(' Arr: array of longint;');
|
|
Add(' Arr2: array[1..2] of longint;');
|
|
Add(' Small: TSmallRec;');
|
|
Add(' Enums: TEnums;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' r, s: TBigRec;');
|
|
Add('begin');
|
|
Add(' r:=s;');
|
|
Add(' r:=default(TBigRec);');
|
|
Add(' r:=default(s);');
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_Assign',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "green",',
|
|
' green: 1',
|
|
'};',
|
|
'this.TSmallRec = function (s) {',
|
|
' if(s){',
|
|
' this.N = s.N;',
|
|
' } else {',
|
|
' this.N = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.N === b.N;',
|
|
' };',
|
|
'};',
|
|
'this.TBigRec = function (s) {',
|
|
' if(s){',
|
|
' this.Int = s.Int;',
|
|
' this.D = s.D;',
|
|
' this.Arr = s.Arr;',
|
|
' this.Arr2 = s.Arr2.slice(0);',
|
|
' this.Small = new $mod.TSmallRec(s.Small);',
|
|
' this.Enums = rtl.refSet(s.Enums);',
|
|
' } else {',
|
|
' this.Int = 0;',
|
|
' this.D = 0.0;',
|
|
' this.Arr = [];',
|
|
' this.Arr2 = rtl.arraySetLength(null, 0, 2);',
|
|
' this.Small = new $mod.TSmallRec();',
|
|
' this.Enums = {};',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.Int === b.Int) && ((this.D === b.D) && ((this.Arr === b.Arr)',
|
|
' && (rtl.arrayEq(this.Arr2, b.Arr2)',
|
|
' && (this.Small.$equal(b.Small) && rtl.eqSet(this.Enums, b.Enums)))));',
|
|
' };',
|
|
'};',
|
|
'this.r = new $mod.TBigRec();',
|
|
'this.s = new $mod.TBigRec();'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.r = new $mod.TBigRec($mod.s);',
|
|
'$mod.r = new $mod.TBigRec();',
|
|
'$mod.r = new $mod.TBigRec();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_PassAsArgClone;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TRecA = record');
|
|
Add(' Bold: longint;');
|
|
Add(' end;');
|
|
Add('procedure DoDefault(r: treca); begin end;');
|
|
Add('procedure DoConst(const r: treca); begin end;');
|
|
Add('var Rec: treca;');
|
|
Add('begin');
|
|
Add(' dodefault(rec);');
|
|
Add(' doconst(rec);');
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_PassAsArgClone',
|
|
LinesToStr([ // statements
|
|
'this.TRecA = function (s) {',
|
|
' if (s) {',
|
|
' this.Bold = s.Bold;',
|
|
' } else {',
|
|
' this.Bold = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.Bold === b.Bold;',
|
|
' };',
|
|
'};',
|
|
'this.DoDefault = function (r) {',
|
|
'};',
|
|
'this.DoConst = function (r) {',
|
|
'};',
|
|
'this.Rec = new $mod.TRecA();'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoDefault(new $mod.TRecA($mod.Rec));',
|
|
'$mod.DoConst($mod.Rec);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_AsParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TRecord = record');
|
|
Add(' i: integer;');
|
|
Add(' end;');
|
|
Add('procedure DoIt(vG: TRecord; const vH: TRecord; var vI: TRecord);');
|
|
Add('var vJ: TRecord;');
|
|
Add('begin');
|
|
Add(' vg:=vg;');
|
|
Add(' vj:=vh;');
|
|
Add(' vi:=vi;');
|
|
Add(' doit(vg,vg,vg);');
|
|
Add(' doit(vh,vh,vj);');
|
|
Add(' doit(vi,vi,vi);');
|
|
Add(' doit(vj,vj,vj);');
|
|
Add('end;');
|
|
Add('var i: TRecord;');
|
|
Add('begin');
|
|
Add(' doit(i,i,i);');
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_AsParams',
|
|
LinesToStr([ // statements
|
|
'this.TRecord = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.i === b.i;',
|
|
' };',
|
|
'};',
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
' var vJ = new $mod.TRecord();',
|
|
' vG = new $mod.TRecord(vG);',
|
|
' vJ = new $mod.TRecord(vH);',
|
|
' vI.set(new $mod.TRecord(vI.get()));',
|
|
' $mod.DoIt(new $mod.TRecord(vG), vG, {',
|
|
' get: function () {',
|
|
' return vG;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vG = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(new $mod.TRecord(vH), vH, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(new $mod.TRecord(vI.get()), vI.get(), vI);',
|
|
' $mod.DoIt(new $mod.TRecord(vJ), vJ, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
'};',
|
|
'this.i = new $mod.TRecord();'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt(new $mod.TRecord($mod.i),$mod.i,{',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecordElement_AsParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TRecord = record');
|
|
Add(' i: integer;');
|
|
Add(' end;');
|
|
Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
|
|
Add('var vJ: TRecord;');
|
|
Add('begin');
|
|
Add(' doit(vj.i,vj.i,vj.i);');
|
|
Add('end;');
|
|
Add('var r: TRecord;');
|
|
Add('begin');
|
|
Add(' doit(r.i,r.i,r.i);');
|
|
ConvertProgram;
|
|
CheckSource('TestRecordElement_AsParams',
|
|
LinesToStr([ // statements
|
|
'this.TRecord = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.i === b.i;',
|
|
' };',
|
|
'};',
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
' var vJ = new $mod.TRecord();',
|
|
' $mod.DoIt(vJ.i, vJ.i, {',
|
|
' p: vJ,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
' });',
|
|
'};',
|
|
'this.r = new $mod.TRecord();'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt($mod.r.i,$mod.r.i,{',
|
|
' p: $mod.r,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecordElementFromFuncResult_AsParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TRecord = record');
|
|
Add(' i: integer;');
|
|
Add(' end;');
|
|
Add('function GetRec(vB: integer = 0): TRecord;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('procedure DoIt(vG: integer; const vH: integer);');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('begin');
|
|
Add(' doit(getrec.i,getrec.i);');
|
|
Add(' doit(getrec().i,getrec().i);');
|
|
Add(' doit(getrec(1).i,getrec(2).i);');
|
|
ConvertProgram;
|
|
CheckSource('TestRecordElementFromFuncResult_AsParams',
|
|
LinesToStr([ // statements
|
|
'this.TRecord = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.i === b.i;',
|
|
' };',
|
|
'};',
|
|
'this.GetRec = function (vB) {',
|
|
' var Result = new $mod.TRecord();',
|
|
' return Result;',
|
|
'};',
|
|
'this.DoIt = function (vG,vH) {',
|
|
'};'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
|
|
'$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
|
|
'$mod.DoIt($mod.GetRec(1).i,$mod.GetRec(2).i);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecordElementFromWith_AsParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TRecord = record');
|
|
Add(' i: integer;');
|
|
Add(' end;');
|
|
Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('var r: trecord;');
|
|
Add('begin');
|
|
Add(' with r do ');
|
|
Add(' doit(i,i,i);');
|
|
ConvertProgram;
|
|
CheckSource('TestRecordElementFromWith_AsParams',
|
|
LinesToStr([ // statements
|
|
'this.TRecord = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.i === b.i;',
|
|
' };',
|
|
'};',
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
'};',
|
|
'this.r = new $mod.TRecord();'
|
|
]),
|
|
LinesToStr([
|
|
'var $with1 = $mod.r;',
|
|
'$mod.DoIt($with1.i,$with1.i,{',
|
|
' p: $with1,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_Equal;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TFlag = (red,blue);');
|
|
Add(' TFlags = set of TFlag;');
|
|
Add(' TProc = procedure;');
|
|
Add(' TRecord = record');
|
|
Add(' i: integer;');
|
|
Add(' Event: TProc;');
|
|
Add(' f: TFlags;');
|
|
Add(' end;');
|
|
Add(' TNested = record');
|
|
Add(' r: TRecord;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' b: boolean;');
|
|
Add(' r,s: trecord;');
|
|
Add('begin');
|
|
Add(' b:=r=s;');
|
|
Add(' b:=r<>s;');
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_Equal',
|
|
LinesToStr([ // statements
|
|
'this.TFlag = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "blue",',
|
|
' blue: 1',
|
|
'};',
|
|
'this.TRecord = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' this.Event = s.Event;',
|
|
' this.f = rtl.refSet(s.f);',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' this.Event = null;',
|
|
' this.f = {};',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.i === b.i) && (rtl.eqCallback(this.Event, b.Event) && rtl.eqSet(this.f, b.f));',
|
|
' };',
|
|
'};',
|
|
'this.TNested = function (s) {',
|
|
' if (s) {',
|
|
' this.r = new $mod.TRecord(s.r);',
|
|
' } else {',
|
|
' this.r = new $mod.TRecord();',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.r.$equal(b.r);',
|
|
' };',
|
|
'};',
|
|
'this.b = false;',
|
|
'this.r = new $mod.TRecord();',
|
|
'this.s = new $mod.TRecord();'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.b = $mod.r.$equal($mod.s);',
|
|
'$mod.b = !$mod.r.$equal($mod.s);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_TypeCastJSValueToRecord;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TRecord = record');
|
|
Add(' i: longint;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' Jv: jsvalue;');
|
|
Add(' Rec: trecord;');
|
|
Add('begin');
|
|
Add(' rec:=trecord(jv);');
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_TypeCastJSValueToRecord',
|
|
LinesToStr([ // statements
|
|
'this.TRecord = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.i === b.i;',
|
|
' };',
|
|
'};',
|
|
'this.Jv = undefined;',
|
|
'this.Rec = new $mod.TRecord();'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.Rec = new $mod.TRecord(rtl.getObject($mod.Jv));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_VariantFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TRec = record',
|
|
' case word of',
|
|
' 0: (b0, b1: Byte);',
|
|
' 1: (i: word);',
|
|
' end;',
|
|
'begin']);
|
|
SetExpectedPasResolverError('variant record is not supported',
|
|
nXIsNotSupported);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_FieldArray;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TArrInt = array[3..4] of longint;',
|
|
' TArrArrInt = array[3..4] of longint;',
|
|
' TRec = record',
|
|
' a: array of longint;',
|
|
' s: array[1..2] of longint;',
|
|
' m: array[1..2,3..4] of longint;',
|
|
' o: TArrArrInt;',
|
|
' end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_FieldArray',
|
|
LinesToStr([ // statements
|
|
'this.TRec = function (s) {',
|
|
' if (s) {',
|
|
' this.a = s.a;',
|
|
' this.s = s.s.slice(0);',
|
|
' this.m = s.m.slice(0);',
|
|
' this.o = s.o.slice(0);',
|
|
' } else {',
|
|
' this.a = [];',
|
|
' this.s = rtl.arraySetLength(null, 0, 2);',
|
|
' this.m = rtl.arraySetLength(null, 0, 2, 2);',
|
|
' this.o = rtl.arraySetLength(null, 0, 2);',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.a === b.a) && (rtl.arrayEq(this.s, b.s) && (rtl.arrayEq(this.m, b.m) && rtl.arrayEq(this.o, b.o)));',
|
|
' };',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_Const;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TArrInt = array[3..4] of longint;',
|
|
' TPoint = record x,y: longint; end;',
|
|
' TRec = record',
|
|
' i: longint;',
|
|
' a: array of longint;',
|
|
' s: array[1..2] of longint;',
|
|
' m: array[1..2,3..4] of longint;',
|
|
' p: TPoint;',
|
|
' end;',
|
|
' TPoints = array of TPoint;',
|
|
'const',
|
|
' r: TRec = (',
|
|
' i:1;',
|
|
' a:(2,3);',
|
|
' s:(4,5);',
|
|
' m:( (11,12), (13,14) );',
|
|
' p: (x:21; y:22)',
|
|
' );',
|
|
' p: TPoints = ( (x:1;y:2), (x:3;y:4) );',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_Const',
|
|
LinesToStr([ // statements
|
|
'this.TPoint = function (s) {',
|
|
' if (s) {',
|
|
' this.x = s.x;',
|
|
' this.y = s.y;',
|
|
' } else {',
|
|
' this.x = 0;',
|
|
' this.y = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.x === b.x) && (this.y === b.y);',
|
|
' };',
|
|
'};',
|
|
'this.TRec = function (s) {',
|
|
' if (s) {',
|
|
' this.i = s.i;',
|
|
' this.a = s.a;',
|
|
' this.s = s.s.slice(0);',
|
|
' this.m = s.m.slice(0);',
|
|
' this.p = new $mod.TPoint(s.p);',
|
|
' } else {',
|
|
' this.i = 0;',
|
|
' this.a = [];',
|
|
' this.s = rtl.arraySetLength(null, 0, 2);',
|
|
' this.m = rtl.arraySetLength(null, 0, 2, 2);',
|
|
' this.p = new $mod.TPoint();',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.i === b.i) && ((this.a === b.a) && (rtl.arrayEq(this.s, b.s) && (rtl.arrayEq(this.m, b.m) && this.p.$equal(b.p))));',
|
|
' };',
|
|
'};',
|
|
'this.r = new $mod.TRec({',
|
|
' i: 1,',
|
|
' a: [2, 3],',
|
|
' s: [4, 5],',
|
|
' m: [[11, 12], [13, 14]],',
|
|
' p: new $mod.TPoint({',
|
|
' x: 21,',
|
|
' y: 22',
|
|
' })',
|
|
'});',
|
|
'this.p = [new $mod.TPoint({',
|
|
' x: 1,',
|
|
' y: 2',
|
|
'}), new $mod.TPoint({',
|
|
' x: 3,',
|
|
' y: 4',
|
|
'})];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_TypecastFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TPoint = record x,y: longint; end;',
|
|
' TRec = record l: longint end;',
|
|
'var p: TPoint;',
|
|
'begin',
|
|
' if TRec(p).l=2 then ;']);
|
|
SetExpectedPasResolverError('Illegal type conversion: "TPoint" to "record TRec"',
|
|
nIllegalTypeConversionTo);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestRecord_InFunction;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure DoIt;',
|
|
'type',
|
|
' TPoint = record x,y: longint; end;',
|
|
' TPoints = array of TPoint;',
|
|
'var',
|
|
' r: TPoint;',
|
|
' p: TPoints;',
|
|
'begin',
|
|
' SetLength(p,2);',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestRecord_InFunction',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function () {',
|
|
' function TPoint(s) {',
|
|
' if (s) {',
|
|
' this.x = s.x;',
|
|
' this.y = s.y;',
|
|
' } else {',
|
|
' this.x = 0;',
|
|
' this.y = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.x === b.x) && (this.y === b.y);',
|
|
' };',
|
|
' };',
|
|
' var r = new TPoint();',
|
|
' var p = [];',
|
|
' p = rtl.arraySetLength(p, TPoint, 2);',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TObjectDefaultConstructor;
|
|
begin
|
|
StartProgram(false);
|
|
Add(['type',
|
|
' TObject = class',
|
|
' public',
|
|
' constructor Create;',
|
|
' destructor Destroy;',
|
|
' end;',
|
|
' TBird = TObject;',
|
|
'constructor tobject.create;',
|
|
'begin end;',
|
|
'destructor tobject.destroy;',
|
|
'begin end;',
|
|
'var Obj: tobject;',
|
|
'begin',
|
|
' obj:=tobject.create;',
|
|
' obj:=tobject.create();',
|
|
' obj:=tbird.create;',
|
|
' obj:=tbird.create();',
|
|
' obj.destroy;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_TObjectDefaultConstructor',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function(){',
|
|
' };',
|
|
' this.Destroy = function(){',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj = $mod.TObject.$create("Create");',
|
|
'$mod.Obj = $mod.TObject.$create("Create");',
|
|
'$mod.Obj = $mod.TObject.$create("Create");',
|
|
'$mod.Obj = $mod.TObject.$create("Create");',
|
|
'$mod.Obj.$destroy("Destroy");',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TObjectConstructorWithParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' public');
|
|
Add(' constructor Create(Par: longint);');
|
|
Add(' end;');
|
|
Add('constructor tobject.create(par: longint);');
|
|
Add('begin end;');
|
|
Add('var Obj: tobject;');
|
|
Add('begin');
|
|
Add(' obj:=tobject.create(3);');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_TObjectConstructorWithParams',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function(Par){',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj = $mod.TObject.$create("Create",[3]);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TObjectConstructorWithDefaultParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' public');
|
|
Add(' constructor Create;');
|
|
Add(' end;');
|
|
Add(' TTest = class(TObject)');
|
|
Add(' public');
|
|
Add(' constructor Create(const Par: longint = 1);');
|
|
Add(' end;');
|
|
Add('constructor tobject.create;');
|
|
Add('begin end;');
|
|
Add('constructor ttest.create(const par: longint);');
|
|
Add('begin end;');
|
|
Add('var t: ttest;');
|
|
Add('begin');
|
|
Add(' t:=ttest.create;');
|
|
Add(' t:=ttest.create(2);');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_TObjectConstructorWithDefaultParam',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function(){',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TTest", $mod.TObject, function () {',
|
|
' this.Create$1 = function (Par) {',
|
|
' };',
|
|
'});',
|
|
'this.t = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.t = $mod.TTest.$create("Create$1", [1]);',
|
|
'$mod.t = $mod.TTest.$create("Create$1", [2]);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Var;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' public');
|
|
Add(' vI: longint;');
|
|
Add(' constructor Create(Par: longint);');
|
|
Add(' end;');
|
|
Add('constructor tobject.create(par: longint);');
|
|
Add('begin');
|
|
Add(' vi:=par+3');
|
|
Add('end;');
|
|
Add('var Obj: tobject;');
|
|
Add('begin');
|
|
Add(' obj:=tobject.create(4);');
|
|
Add(' obj.vi:=obj.VI+5;');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_Var',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.$init = function () {',
|
|
' this.vI = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function(Par){',
|
|
' this.vI = Par+3;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj = $mod.TObject.$create("Create",[4]);',
|
|
'$mod.Obj.vI = $mod.Obj.vI + 5;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Method;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' public');
|
|
Add(' vI: longint;');
|
|
Add(' Sub: TObject;');
|
|
Add(' constructor Create;');
|
|
Add(' function GetIt(Par: longint): tobject;');
|
|
Add(' end;');
|
|
Add('constructor tobject.create; begin end;');
|
|
Add('function tobject.getit(par: longint): tobject;');
|
|
Add('begin');
|
|
Add(' Self.vi:=par+3;');
|
|
Add(' Result:=self.sub;');
|
|
Add('end;');
|
|
Add('var Obj: tobject;');
|
|
Add('begin');
|
|
Add(' obj:=tobject.create;');
|
|
Add(' obj.getit(4);');
|
|
Add(' obj.sub.sub:=nil;');
|
|
Add(' obj.sub.getit(5);');
|
|
Add(' obj.sub.getit(6).SUB:=nil;');
|
|
Add(' obj.sub.getit(7).GETIT(8);');
|
|
Add(' obj.sub.getit(9).SuB.getit(10);');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_Method',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.$init = function () {',
|
|
' this.vI = 0;',
|
|
' this.Sub = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.Sub = undefined;',
|
|
' };',
|
|
' this.Create = function(){',
|
|
' };',
|
|
' this.GetIt = function(Par){',
|
|
' var Result = null;',
|
|
' this.vI = Par + 3;',
|
|
' Result = this.Sub;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj = $mod.TObject.$create("Create");',
|
|
'$mod.Obj.GetIt(4);',
|
|
'$mod.Obj.Sub.Sub=null;',
|
|
'$mod.Obj.Sub.GetIt(5);',
|
|
'$mod.Obj.Sub.GetIt(6).Sub=null;',
|
|
'$mod.Obj.Sub.GetIt(7).GetIt(8);',
|
|
'$mod.Obj.Sub.GetIt(9).Sub.GetIt(10);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Implementation;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'type',
|
|
' TObject = class',
|
|
' constructor Create;',
|
|
' end;',
|
|
'implementation',
|
|
'type',
|
|
' TIntClass = class',
|
|
' constructor Create; reintroduce;',
|
|
' class procedure DoGlob;',
|
|
' end;',
|
|
'constructor tintclass.create;',
|
|
'begin',
|
|
' inherited;',
|
|
' inherited create;',
|
|
' doglob;',
|
|
'end;',
|
|
'class procedure tintclass.doglob;',
|
|
'begin',
|
|
'end;',
|
|
'constructor tobject.create;',
|
|
'var',
|
|
' iC: tintclass;',
|
|
'begin',
|
|
' ic:=tintclass.create;',
|
|
' tintclass.doglob;',
|
|
' ic.doglob;',
|
|
'end;',
|
|
'initialization',
|
|
' tintclass.doglob;',
|
|
'']);
|
|
ConvertUnit;
|
|
CheckSource('TestClass_Implementation',
|
|
LinesToStr([ // statements
|
|
'var $impl = $mod.$impl;',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' var iC = null;',
|
|
' iC = $impl.TIntClass.$create("Create$1");',
|
|
' $impl.TIntClass.DoGlob();',
|
|
' iC.$class.DoGlob();',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$impl.TIntClass.DoGlob();',
|
|
'']),
|
|
LinesToStr([
|
|
'rtl.createClass($impl, "TIntClass", $mod.TObject, function () {',
|
|
' this.Create$1 = function () {',
|
|
' $mod.TObject.Create.apply(this, arguments);',
|
|
' $mod.TObject.Create.call(this);',
|
|
' this.$class.DoGlob();',
|
|
' };',
|
|
' this.DoGlob = function () {',
|
|
' };',
|
|
'});',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Inheritance;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' public');
|
|
Add(' constructor Create;');
|
|
Add(' end;');
|
|
Add(' TClassA = class');
|
|
Add(' end;');
|
|
Add(' TClassB = class(TObject)');
|
|
Add(' procedure ProcB;');
|
|
Add(' end;');
|
|
Add('constructor tobject.create; begin end;');
|
|
Add('procedure tclassb.procb; begin end;');
|
|
Add('var');
|
|
Add(' oO: TObject;');
|
|
Add(' oA: TClassA;');
|
|
Add(' oB: TClassB;');
|
|
Add('begin');
|
|
Add(' oO:=tobject.Create;');
|
|
Add(' oA:=tclassa.Create;');
|
|
Add(' ob:=tclassb.Create;');
|
|
Add(' if oo is tclassa then ;');
|
|
Add(' ob:=oo as tclassb;');
|
|
Add(' (oo as tclassb).procb;');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_Inheritance',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod,"TClassA",$mod.TObject,function(){',
|
|
'});',
|
|
'rtl.createClass($mod,"TClassB",$mod.TObject,function(){',
|
|
' this.ProcB = function () {',
|
|
' };',
|
|
'});',
|
|
'this.oO = null;',
|
|
'this.oA = null;',
|
|
'this.oB = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.oO = $mod.TObject.$create("Create");',
|
|
'$mod.oA = $mod.TClassA.$create("Create");',
|
|
'$mod.oB = $mod.TClassB.$create("Create");',
|
|
'if ($mod.TClassA.isPrototypeOf($mod.oO));',
|
|
'$mod.oB = rtl.as($mod.oO, $mod.TClassB);',
|
|
'rtl.as($mod.oO, $mod.TClassB).ProcB();'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TypeAlias;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IObject = interface',
|
|
' end;',
|
|
' IBird = type IObject;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = type TObject;',
|
|
'var',
|
|
' oObj: TObject;',
|
|
' oBird: TBird;',
|
|
' IntfObj: IObject;',
|
|
' IntfBird: IBird;',
|
|
'begin',
|
|
' oObj:=oBird;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_TypeAlias',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IObject", "{B92D5841-6F2A-306A-8000-000000000000}", [], null);',
|
|
'rtl.createInterface($mod, "IBird", "{4B0D080B-C0F6-387B-AE88-F10981585074}", [], $mod.IObject);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
'});',
|
|
'this.oObj = null;',
|
|
'this.oBird = null;',
|
|
'this.IntfObj = null;',
|
|
'this.IntfBird = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.oObj = $mod.oBird;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_AbstractMethod;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' public');
|
|
Add(' procedure DoIt; virtual; abstract;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_AbstractMethod',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_CallInherited_ProcNoParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' procedure DoAbstract; virtual; abstract;',
|
|
' procedure DoVirtual; virtual;',
|
|
' procedure DoIt;',
|
|
' end;',
|
|
' TA = class',
|
|
' procedure doabstract; override;',
|
|
' procedure dovirtual; override;',
|
|
' procedure DoSome;',
|
|
' end;',
|
|
'procedure tobject.dovirtual;',
|
|
'begin',
|
|
' inherited; // call non existing ancestor -> ignore silently',
|
|
'end;',
|
|
'procedure tobject.doit;',
|
|
'begin',
|
|
'end;',
|
|
'procedure ta.doabstract;',
|
|
'begin',
|
|
' inherited dovirtual; // call TObject.DoVirtual',
|
|
'end;',
|
|
'procedure ta.dovirtual;',
|
|
'begin',
|
|
' inherited; // call TObject.DoVirtual',
|
|
' inherited dovirtual; // call TObject.DoVirtual',
|
|
' inherited dovirtual(); // call TObject.DoVirtual',
|
|
' doit;',
|
|
' doit();',
|
|
'end;',
|
|
'procedure ta.dosome;',
|
|
'begin',
|
|
' inherited; // call non existing ancestor method -> silently ignore',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_CallInherited_ProcNoParams',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoVirtual = function () {',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TA", $mod.TObject, function () {',
|
|
' this.DoAbstract = function () {',
|
|
' $mod.TObject.DoVirtual.call(this);',
|
|
' };',
|
|
' this.DoVirtual = function () {',
|
|
' $mod.TObject.DoVirtual.apply(this, arguments);',
|
|
' $mod.TObject.DoVirtual.call(this);',
|
|
' $mod.TObject.DoVirtual.call(this);',
|
|
' this.DoIt();',
|
|
' this.DoIt();',
|
|
' };',
|
|
' this.DoSome = function () {',
|
|
' };',
|
|
'});'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_CallInherited_WithParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' procedure DoAbstract(pA: longint; pB: longint = 0); virtual; abstract;',
|
|
' procedure DoVirtual(pA: longint; pB: longint = 0); virtual;',
|
|
' procedure DoIt(pA: longint; pB: longint = 0);',
|
|
' procedure DoIt2(pA: longint = 1; pB: longint = 2);',
|
|
' function GetIt(pA: longint = 1; pB: longint = 2): longint;',
|
|
' end;',
|
|
' TClassA = class',
|
|
' procedure DoAbstract(pA: longint; pB: longint = 0); override;',
|
|
' procedure DoVirtual(pA: longint; pB: longint = 0); override;',
|
|
' function GetIt(pA: longint = 1; pB: longint = 2): longint;',
|
|
' end;',
|
|
'procedure tobject.dovirtual(pa: longint; pb: longint = 0);',
|
|
'begin',
|
|
'end;',
|
|
'procedure tobject.doit(pa: longint; pb: longint = 0);',
|
|
'begin',
|
|
'end;',
|
|
'procedure tobject.doit2(pa: longint; pb: longint = 0);',
|
|
'begin',
|
|
'end;',
|
|
'function tobject.getit(pa: longint; pb: longint = 0): longint;',
|
|
'begin',
|
|
'end;',
|
|
'procedure tclassa.doabstract(pa: longint; pb: longint = 0);',
|
|
'begin',
|
|
' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)',
|
|
' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)',
|
|
'end;',
|
|
'procedure tclassa.dovirtual(pa: longint; pb: longint = 0);',
|
|
'begin',
|
|
' inherited; // call TObject.DoVirtual(pA,pB)',
|
|
' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)',
|
|
' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)',
|
|
' doit(pa,pb);',
|
|
' doit(pa);',
|
|
' doit2(pa);',
|
|
' doit2;',
|
|
'end;',
|
|
'function tclassa.getit(pa: longint; pb: longint = 0): longint;',
|
|
'begin',
|
|
' pa:=inherited;',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_CallInherited_WithParams',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoVirtual = function (pA,pB) {',
|
|
' };',
|
|
' this.DoIt = function (pA,pB) {',
|
|
' };',
|
|
' this.DoIt2 = function (pA,pB) {',
|
|
' };',
|
|
' this.GetIt = function (pA, pB) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TClassA", $mod.TObject, function () {',
|
|
' this.DoAbstract = function (pA,pB) {',
|
|
' $mod.TObject.DoVirtual.call(this,pA,pB);',
|
|
' $mod.TObject.DoVirtual.call(this,pA,0);',
|
|
' };',
|
|
' this.DoVirtual = function (pA,pB) {',
|
|
' $mod.TObject.DoVirtual.apply(this, arguments);',
|
|
' $mod.TObject.DoVirtual.call(this,pA,pB);',
|
|
' $mod.TObject.DoVirtual.call(this,pA,0);',
|
|
' this.DoIt(pA,pB);',
|
|
' this.DoIt(pA,0);',
|
|
' this.DoIt2(pA,2);',
|
|
' this.DoIt2(1,2);',
|
|
' };',
|
|
' this.GetIt$1 = function (pA, pB) {',
|
|
' var Result = 0;',
|
|
' pA = $mod.TObject.GetIt.apply(this, arguments);',
|
|
' return Result;',
|
|
' };',
|
|
'});'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClasS_CallInheritedConstructor;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' constructor Create; virtual;');
|
|
Add(' constructor CreateWithB(b: boolean);');
|
|
Add(' end;');
|
|
Add(' TA = class');
|
|
Add(' constructor Create; override;');
|
|
Add(' constructor CreateWithC(c: char);');
|
|
Add(' procedure DoIt;');
|
|
Add(' class function DoSome: TObject;');
|
|
Add(' end;');
|
|
Add('constructor tobject.create;');
|
|
Add('begin');
|
|
Add(' inherited; // call non existing ancestor -> ignore silently');
|
|
Add('end;');
|
|
Add('constructor tobject.createwithb(b: boolean);');
|
|
Add('begin');
|
|
Add(' inherited; // call non existing ancestor -> ignore silently');
|
|
Add(' create; // normal call');
|
|
Add('end;');
|
|
Add('constructor ta.create;');
|
|
Add('begin');
|
|
Add(' inherited; // normal call TObject.Create');
|
|
Add(' inherited create; // normal call TObject.Create');
|
|
Add(' inherited createwithb(false); // normal call TObject.CreateWithB');
|
|
Add('end;');
|
|
Add('constructor ta.createwithc(c: char);');
|
|
Add('begin');
|
|
Add(' inherited create; // call TObject.Create');
|
|
Add(' inherited createwithb(true); // call TObject.CreateWithB');
|
|
Add(' doit;');
|
|
Add(' doit();');
|
|
Add(' dosome;');
|
|
Add('end;');
|
|
Add('procedure ta.doit;');
|
|
Add('begin');
|
|
Add(' create; // normal call');
|
|
Add(' createwithb(false); // normal call');
|
|
Add(' createwithc(''c''); // normal call');
|
|
Add('end;');
|
|
Add('class function ta.dosome: TObject;');
|
|
Add('begin');
|
|
Add(' Result:=create; // constructor');
|
|
Add(' Result:=createwithb(true); // constructor');
|
|
Add(' Result:=createwithc(''c''); // constructor');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_CallInheritedConstructor',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' };',
|
|
' this.CreateWithB = function (b) {',
|
|
' this.Create();',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TA", $mod.TObject, function () {',
|
|
' this.Create = function () {',
|
|
' $mod.TObject.Create.apply(this, arguments);',
|
|
' $mod.TObject.Create.call(this);',
|
|
' $mod.TObject.CreateWithB.call(this, false);',
|
|
' };',
|
|
' this.CreateWithC = function (c) {',
|
|
' $mod.TObject.Create.call(this);',
|
|
' $mod.TObject.CreateWithB.call(this, true);',
|
|
' this.DoIt();',
|
|
' this.DoIt();',
|
|
' this.$class.DoSome();',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' this.Create();',
|
|
' this.CreateWithB(false);',
|
|
' this.CreateWithC("c");',
|
|
' };',
|
|
' this.DoSome = function () {',
|
|
' var Result = null;',
|
|
' Result = this.$create("Create");',
|
|
' Result = this.$create("CreateWithB", [true]);',
|
|
' Result = this.$create("CreateWithC", ["c"]);',
|
|
' return Result;',
|
|
' };',
|
|
'});'
|
|
]),
|
|
LinesToStr([ // this.$main
|
|
''
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_ClassVar_Assign;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' public',
|
|
' class var vI: longint;',
|
|
' class var Sub: TObject;',
|
|
' constructor Create;',
|
|
' class function GetIt(Par: longint): tobject;',
|
|
' end;',
|
|
'constructor tobject.create;',
|
|
'begin',
|
|
' vi:=vi+1;',
|
|
' Self.vi:=Self.vi+1;',
|
|
' inc(vi);',
|
|
'end;',
|
|
'class function tobject.getit(par: longint): tobject;',
|
|
'begin',
|
|
' vi:=vi+par;',
|
|
' Self.vi:=Self.vi+par;',
|
|
' inc(vi);',
|
|
' Result:=self.sub;',
|
|
'end;',
|
|
'var Obj: tobject;',
|
|
'begin',
|
|
' obj:=tobject.create;',
|
|
' tobject.vi:=3;',
|
|
' if tobject.vi=4 then ;',
|
|
' tobject.sub:=nil;',
|
|
' obj.sub:=nil;',
|
|
' obj.sub.sub:=nil;']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_ClassVar_Assign',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.vI = 0;',
|
|
' this.Sub = null;',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function(){',
|
|
' $mod.TObject.vI = this.vI+1;',
|
|
' $mod.TObject.vI = this.vI+1;',
|
|
' $mod.TObject.vI += 1;',
|
|
' };',
|
|
' this.GetIt = function(Par){',
|
|
' var Result = null;',
|
|
' $mod.TObject.vI = this.vI + Par;',
|
|
' $mod.TObject.vI = this.vI + Par;',
|
|
' $mod.TObject.vI += 1;',
|
|
' Result = this.Sub;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj = $mod.TObject.$create("Create");',
|
|
'$mod.TObject.vI = 3;',
|
|
'if ($mod.TObject.vI === 4);',
|
|
'$mod.TObject.Sub=null;',
|
|
'$mod.TObject.Sub=null;',
|
|
'$mod.TObject.Sub=null;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_CallClassMethod;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' public');
|
|
Add(' class var vI: longint;');
|
|
Add(' class var Sub: TObject;');
|
|
Add(' constructor Create;');
|
|
Add(' function GetMore(Par: longint): longint;');
|
|
Add(' class function GetIt(Par: longint): tobject;');
|
|
Add(' end;');
|
|
Add('constructor tobject.create;');
|
|
Add('begin');
|
|
Add(' sub:=getit(3);');
|
|
Add(' vi:=getmore(4);');
|
|
Add(' sub:=Self.getit(5);');
|
|
Add(' vi:=Self.getmore(6);');
|
|
Add('end;');
|
|
Add('function tobject.getmore(par: longint): longint;');
|
|
Add('begin');
|
|
Add(' sub:=getit(11);');
|
|
Add(' vi:=getmore(12);');
|
|
Add(' sub:=self.getit(13);');
|
|
Add(' vi:=self.getmore(14);');
|
|
Add('end;');
|
|
Add('class function tobject.getit(par: longint): tobject;');
|
|
Add('begin');
|
|
Add(' sub:=getit(21);');
|
|
Add(' vi:=sub.getmore(22);');
|
|
Add(' sub:=self.getit(23);');
|
|
Add(' vi:=self.sub.getmore(24);');
|
|
Add('end;');
|
|
Add('var Obj: tobject;');
|
|
Add('begin');
|
|
Add(' obj:=tobject.create;');
|
|
Add(' tobject.getit(5);');
|
|
Add(' obj.getit(6);');
|
|
Add(' obj.sub.getit(7);');
|
|
Add(' obj.sub.getit(8).SUB:=nil;');
|
|
Add(' obj.sub.getit(9).GETIT(10);');
|
|
Add(' obj.sub.getit(11).SuB.getit(12);');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_CallClassMethod',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod,"TObject",null,function(){',
|
|
' this.vI = 0;',
|
|
' this.Sub = null;',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function(){',
|
|
' $mod.TObject.Sub = this.$class.GetIt(3);',
|
|
' $mod.TObject.vI = this.GetMore(4);',
|
|
' $mod.TObject.Sub = this.$class.GetIt(5);',
|
|
' $mod.TObject.vI = this.GetMore(6);',
|
|
' };',
|
|
' this.GetMore = function(Par){',
|
|
' var Result = 0;',
|
|
' $mod.TObject.Sub = this.$class.GetIt(11);',
|
|
' $mod.TObject.vI = this.GetMore(12);',
|
|
' $mod.TObject.Sub = this.$class.GetIt(13);',
|
|
' $mod.TObject.vI = this.GetMore(14);',
|
|
' return Result;',
|
|
' };',
|
|
' this.GetIt = function(Par){',
|
|
' var Result = null;',
|
|
' $mod.TObject.Sub = this.GetIt(21);',
|
|
' $mod.TObject.vI = this.Sub.GetMore(22);',
|
|
' $mod.TObject.Sub = this.GetIt(23);',
|
|
' $mod.TObject.vI = this.Sub.GetMore(24);',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj = $mod.TObject.$create("Create");',
|
|
'$mod.TObject.GetIt(5);',
|
|
'$mod.Obj.$class.GetIt(6);',
|
|
'$mod.Obj.Sub.$class.GetIt(7);',
|
|
'$mod.TObject.Sub=null;',
|
|
'$mod.Obj.Sub.$class.GetIt(9).$class.GetIt(10);',
|
|
'$mod.Obj.Sub.$class.GetIt(11).Sub.$class.GetIt(12);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Property;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' Fx: longint;');
|
|
Add(' Fy: longint;');
|
|
Add(' function GetInt: longint;');
|
|
Add(' procedure SetInt(Value: longint);');
|
|
Add(' procedure DoIt;');
|
|
Add(' property IntA: longint read Fx write Fy;');
|
|
Add(' property IntB: longint read GetInt write SetInt;');
|
|
Add(' end;');
|
|
Add('function tobject.getint: longint;');
|
|
Add('begin');
|
|
Add(' result:=fx;');
|
|
Add('end;');
|
|
Add('procedure tobject.setint(value: longint);');
|
|
Add('begin');
|
|
Add(' if value=fy then exit;');
|
|
Add(' fy:=value;');
|
|
Add('end;');
|
|
Add('procedure tobject.doit;');
|
|
Add('begin');
|
|
Add(' IntA:=IntA+1;');
|
|
Add(' Self.IntA:=Self.IntA+1;');
|
|
Add(' IntB:=IntB+1;');
|
|
Add(' Self.IntB:=Self.IntB+1;');
|
|
Add('end;');
|
|
Add('var Obj: tobject;');
|
|
Add('begin');
|
|
Add(' obj.inta:=obj.inta+1;');
|
|
Add(' if obj.intb=2 then;');
|
|
Add(' obj.intb:=obj.intb+2;');
|
|
Add(' obj.setint(obj.inta);');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_Property',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.Fx = 0;',
|
|
' this.Fy = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.GetInt = function () {',
|
|
' var Result = 0;',
|
|
' Result = this.Fx;',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetInt = function (Value) {',
|
|
' if (Value === this.Fy) return;',
|
|
' this.Fy = Value;',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' this.Fy = this.Fx + 1;',
|
|
' this.Fy = this.Fx + 1;',
|
|
' this.SetInt(this.GetInt() + 1);',
|
|
' this.SetInt(this.GetInt() + 1);',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj.Fy = $mod.Obj.Fx + 1;',
|
|
'if ($mod.Obj.GetInt() === 2);',
|
|
'$mod.Obj.SetInt($mod.Obj.GetInt() + 2);',
|
|
'$mod.Obj.SetInt($mod.Obj.Fx);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Property_ClassMethod;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' class var Fx: longint;');
|
|
Add(' class var Fy: longint;');
|
|
Add(' class function GetInt: longint;');
|
|
Add(' class procedure SetInt(Value: longint);');
|
|
Add(' class procedure DoIt;');
|
|
Add(' class property IntA: longint read Fx write Fy;');
|
|
Add(' class property IntB: longint read GetInt write SetInt;');
|
|
Add(' end;');
|
|
Add('class function tobject.getint: longint;');
|
|
Add('begin');
|
|
Add(' result:=fx;');
|
|
Add('end;');
|
|
Add('class procedure tobject.setint(value: longint);');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('class procedure tobject.doit;');
|
|
Add('begin');
|
|
Add(' IntA:=IntA+1;');
|
|
Add(' Self.IntA:=Self.IntA+1;');
|
|
Add(' IntB:=IntB+1;');
|
|
Add(' Self.IntB:=Self.IntB+1;');
|
|
Add('end;');
|
|
Add('var Obj: tobject;');
|
|
Add('begin');
|
|
Add(' tobject.inta:=tobject.inta+1;');
|
|
Add(' if tobject.intb=2 then;');
|
|
Add(' tobject.intb:=tobject.intb+2;');
|
|
Add(' tobject.setint(tobject.inta);');
|
|
Add(' obj.inta:=obj.inta+1;');
|
|
Add(' if obj.intb=2 then;');
|
|
Add(' obj.intb:=obj.intb+2;');
|
|
Add(' obj.setint(obj.inta);');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_Property_ClassMethod',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.Fx = 0;',
|
|
' this.Fy = 0;',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.GetInt = function () {',
|
|
' var Result = 0;',
|
|
' Result = this.Fx;',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetInt = function (Value) {',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' this.Fy = this.Fx + 1;',
|
|
' this.Fy = this.Fx + 1;',
|
|
' this.SetInt(this.GetInt() + 1);',
|
|
' this.SetInt(this.GetInt() + 1);',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.TObject.Fy = $mod.TObject.Fx + 1;',
|
|
'if ($mod.TObject.GetInt() === 2);',
|
|
'$mod.TObject.SetInt($mod.TObject.GetInt() + 2);',
|
|
'$mod.TObject.SetInt($mod.TObject.Fx);',
|
|
'$mod.Obj.$class.Fy = $mod.Obj.Fx + 1;',
|
|
'if ($mod.Obj.$class.GetInt() === 2);',
|
|
'$mod.Obj.$class.SetInt($mod.Obj.$class.GetInt() + 2);',
|
|
'$mod.Obj.$class.SetInt($mod.Obj.Fx);'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Property_Indexed;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' FItems: array of longint;');
|
|
Add(' function GetItems(Index: longint): longint;');
|
|
Add(' procedure SetItems(Index: longint; Value: longint);');
|
|
Add(' procedure DoIt;');
|
|
Add(' property Items[Index: longint]: longint read getitems write setitems;');
|
|
Add(' end;');
|
|
Add('function tobject.getitems(index: longint): longint;');
|
|
Add('begin');
|
|
Add(' Result:=fitems[index];');
|
|
Add('end;');
|
|
Add('procedure tobject.setitems(index: longint; value: longint);');
|
|
Add('begin');
|
|
Add(' fitems[index]:=value;');
|
|
Add('end;');
|
|
Add('procedure tobject.doit;');
|
|
Add('begin');
|
|
Add(' items[1]:=2;');
|
|
Add(' items[3]:=items[4];');
|
|
Add(' self.items[5]:=self.items[6];');
|
|
Add(' items[items[7]]:=items[items[8]];');
|
|
Add('end;');
|
|
Add('var Obj: tobject;');
|
|
Add('begin');
|
|
Add(' obj.Items[11]:=obj.Items[12];');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_Property_Indexed',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FItems = [];',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FItems = undefined;',
|
|
' };',
|
|
' this.GetItems = function (Index) {',
|
|
' var Result = 0;',
|
|
' Result = this.FItems[Index];',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetItems = function (Index, Value) {',
|
|
' this.FItems[Index] = Value;',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' this.SetItems(1, 2);',
|
|
' this.SetItems(3,this.GetItems(4));',
|
|
' this.SetItems(5,this.GetItems(6));',
|
|
' this.SetItems(this.GetItems(7), this.GetItems(this.GetItems(8)));',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj.SetItems(11,$mod.Obj.GetItems(12));'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Property_IndexSpec;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (red, blue);',
|
|
' TObject = class',
|
|
' function GetIntBool(Index: longint): boolean; virtual; abstract;',
|
|
' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
|
|
' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
|
|
' procedure SetEnumBool(Index: TEnum; b: boolean); virtual; abstract;',
|
|
' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
|
|
' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
|
|
' property B1: boolean index 1 read GetIntBool write SetIntBool;',
|
|
' property B2: boolean index TEnum.blue read GetEnumBool write SetEnumBool;',
|
|
' property B3: boolean index ord(red) read GetIntBool write SetIntBool;',
|
|
' property I1[A: String]: boolean index ord(blue) read GetStrIntBool write SetStrIntBool;',
|
|
' end;',
|
|
'procedure DoIt(b: boolean); begin end;',
|
|
'var',
|
|
' o: TObject;',
|
|
'begin',
|
|
' o.B1:=o.B1;',
|
|
' o.B2:=o.B2;',
|
|
' o.B3:=o.B3;',
|
|
' o.I1[''a'']:=o.I1[''b''];',
|
|
' doit(o.b1);',
|
|
' doit(o.b2);',
|
|
' doit(o.i1[''c'']);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_Property_IndexSpec',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "blue",',
|
|
' blue: 1',
|
|
'};',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.DoIt = function (b) {',
|
|
'};',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.o.SetIntBool(1, $mod.o.GetIntBool(1));',
|
|
'$mod.o.SetEnumBool($mod.TEnum.blue, $mod.o.GetEnumBool($mod.TEnum.blue));',
|
|
'$mod.o.SetIntBool(0, $mod.o.GetIntBool(0));',
|
|
'$mod.o.SetStrIntBool("a", 1, $mod.o.GetStrIntBool("b", 1));',
|
|
'$mod.DoIt($mod.o.GetIntBool(1));',
|
|
'$mod.DoIt($mod.o.GetEnumBool($mod.TEnum.blue));',
|
|
'$mod.DoIt($mod.o.GetStrIntBool("c", 1));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_PropertyOfTypeArray;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TArray = array of longint;');
|
|
Add(' TObject = class');
|
|
Add(' FItems: TArray;');
|
|
Add(' function GetItems: tarray;');
|
|
Add(' procedure SetItems(Value: tarray);');
|
|
Add(' property Items: tarray read getitems write setitems;');
|
|
Add(' end;');
|
|
Add('function tobject.getitems: tarray;');
|
|
Add('begin');
|
|
Add(' Result:=fitems;');
|
|
Add('end;');
|
|
Add('procedure tobject.setitems(value: tarray);');
|
|
Add('begin');
|
|
Add(' fitems:=value;');
|
|
Add(' fitems:=nil;');
|
|
Add(' Items:=nil;');
|
|
Add(' Items:=Items;');
|
|
Add(' Items[1]:=2;');
|
|
Add(' fitems[3]:=Items[4];');
|
|
Add(' Items[5]:=Items[6];');
|
|
Add(' Self.Items[7]:=8;');
|
|
Add(' Self.Items[9]:=Self.Items[10];');
|
|
Add(' Items[Items[11]]:=Items[Items[12]];');
|
|
Add('end;');
|
|
Add('var Obj: tobject;');
|
|
Add('begin');
|
|
Add(' obj.items:=nil;');
|
|
Add(' obj.items:=obj.items;');
|
|
Add(' obj.items[11]:=obj.items[12];');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_PropertyOfTypeArray',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FItems = [];',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FItems = undefined;',
|
|
' };',
|
|
' this.GetItems = function () {',
|
|
' var Result = [];',
|
|
' Result = this.FItems;',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetItems = function (Value) {',
|
|
' this.FItems = Value;',
|
|
' this.FItems = [];',
|
|
' this.SetItems([]);',
|
|
' this.SetItems(this.GetItems());',
|
|
' this.GetItems()[1] = 2;',
|
|
' this.FItems[3] = this.GetItems()[4];',
|
|
' this.GetItems()[5] = this.GetItems()[6];',
|
|
' this.GetItems()[7] = 8;',
|
|
' this.GetItems()[9] = this.GetItems()[10];',
|
|
' this.GetItems()[this.GetItems()[11]] = this.GetItems()[this.GetItems()[12]];',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj.SetItems([]);',
|
|
'$mod.Obj.SetItems($mod.Obj.GetItems());',
|
|
'$mod.Obj.GetItems()[11] = $mod.Obj.GetItems()[12];'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_PropertyDefault;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TArray = array of longint;',
|
|
' TObject = class',
|
|
' FItems: TArray;',
|
|
' function GetItems(Index: longint): longint;',
|
|
' procedure SetItems(Index, Value: longint);',
|
|
' property Items[Index: longint]: longint read getitems write setitems; default;',
|
|
' end;',
|
|
'function tobject.getitems(index: longint): longint;',
|
|
'begin',
|
|
'end;',
|
|
'procedure tobject.setitems(index, value: longint);',
|
|
'begin',
|
|
' Self[1]:=2;',
|
|
' Self[3]:=Self[index];',
|
|
' Self[index]:=Self[Self[value]];',
|
|
' Self[Self[4]]:=value;',
|
|
'end;',
|
|
'var Obj: tobject;',
|
|
'begin',
|
|
' obj[11]:=12;',
|
|
' obj[13]:=obj[14];',
|
|
' obj[obj[15]]:=obj[obj[15]];',
|
|
' TObject(obj)[16]:=TObject(obj)[17];']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_PropertyDefault',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FItems = [];',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FItems = undefined;',
|
|
' };',
|
|
' this.GetItems = function (Index) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetItems = function (Index, Value) {',
|
|
' this.SetItems(1, 2);',
|
|
' this.SetItems(3, this.GetItems(Index));',
|
|
' this.SetItems(Index, this.GetItems(this.GetItems(Value)));',
|
|
' this.SetItems(this.GetItems(4), Value);',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj.SetItems(11, 12);',
|
|
'$mod.Obj.SetItems(13, $mod.Obj.GetItems(14));',
|
|
'$mod.Obj.SetItems($mod.Obj.GetItems(15), $mod.Obj.GetItems($mod.Obj.GetItems(15)));',
|
|
'$mod.Obj.SetItems(16, $mod.Obj.GetItems(17));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_PropertyDefault2;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class end;',
|
|
' TAlphaList = class',
|
|
' function GetAlphas(Index: longint): Pointer; virtual; abstract;',
|
|
' procedure SetAlphas(Index: longint; Value: Pointer); virtual; abstract;',
|
|
' property Alphas[Index: longint]: Pointer read getAlphas write setAlphas; default;',
|
|
' end;',
|
|
' TBetaList = class',
|
|
' function GetBetas(Index: longint): Pointer; virtual; abstract;',
|
|
' procedure SetBetas(Index: longint; Value: Pointer); virtual; abstract;',
|
|
' property Betas[Index: longint]: Pointer read getBetas write setBetas; default;',
|
|
' end;',
|
|
' TBird = class',
|
|
' procedure DoIt;',
|
|
' end;',
|
|
'procedure TBird.DoIt;',
|
|
'var',
|
|
' List: TAlphaList;',
|
|
'begin',
|
|
' if TBetaList(List[2])[3]=nil then ;',
|
|
' TBetaList(List[4])[5]:=nil;',
|
|
'end;',
|
|
'var',
|
|
' List: TAlphaList;',
|
|
'begin',
|
|
' if TBetaList(List[2])[3]=nil then ;',
|
|
' TBetaList(List[4])[5]:=nil;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_PropertyDefault2',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TAlphaList", $mod.TObject, function () {',
|
|
'});',
|
|
'rtl.createClass($mod, "TBetaList", $mod.TObject, function () {',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' this.DoIt = function () {',
|
|
' var List = null;',
|
|
' if (List.GetAlphas(2).GetBetas(3) === null) ;',
|
|
' List.GetAlphas(4).SetBetas(5, null);',
|
|
' };',
|
|
'});',
|
|
'this.List = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'if ($mod.List.GetAlphas(2).GetBetas(3) === null) ;',
|
|
'$mod.List.GetAlphas(4).SetBetas(5, null);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_PropertyOverride;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TObject = class');
|
|
Add(' FItem: integer;');
|
|
Add(' function GetItem: integer; external name ''GetItem'';');
|
|
Add(' procedure SetItem(Value: integer); external name ''SetItem'';');
|
|
Add(' property Item: integer read getitem write setitem;');
|
|
Add(' end;');
|
|
Add(' TCar = class');
|
|
Add(' FBag: integer;');
|
|
Add(' function GetBag: integer; external name ''GetBag'';');
|
|
Add(' property Item read getbag;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add(' Car: tcar;');
|
|
Add('begin');
|
|
Add(' Obj.Item:=Obj.Item;');
|
|
Add(' Car.Item:=Car.Item;');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_PropertyOverride',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FItem = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.FBag = 0;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.Car = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj.SetItem($mod.Obj.GetItem());',
|
|
'$mod.Car.SetItem($mod.Car.GetBag());',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_PropertyIncVisibility;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit1.pp',
|
|
LinesToStr([
|
|
'type',
|
|
' TNumber = longint;',
|
|
' TInteger = longint;',
|
|
' TObject = class',
|
|
' private',
|
|
' function GetItems(Index: TNumber): TInteger; virtual; abstract;',
|
|
' procedure SetItems(Index: TInteger; Value: TNumber); virtual; abstract;',
|
|
' protected',
|
|
' property Items[Index: TNumber]: longint read GetItems write SetItems;',
|
|
' end;']),
|
|
LinesToStr([
|
|
'']));
|
|
|
|
StartProgram(true);
|
|
Add([
|
|
'uses unit1;',
|
|
'type',
|
|
' TBird = class',
|
|
' public',
|
|
' property Items;',
|
|
' end;',
|
|
'procedure DoIt(i: TInteger);',
|
|
'begin',
|
|
'end;',
|
|
'var b: TBird;',
|
|
'begin',
|
|
' b.Items[1]:=2;',
|
|
' b.Items[3]:=b.Items[4];',
|
|
' DoIt(b.Items[5]);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_PropertyIncVisibility',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TBird", pas.unit1.TObject, function () {',
|
|
'});',
|
|
'this.DoIt = function (i) {',
|
|
'};',
|
|
'this.b = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.b.SetItems(1, 2);',
|
|
'$mod.b.SetItems(3, $mod.b.GetItems(4));',
|
|
'$mod.DoIt($mod.b.GetItems(5));'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Assigned;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add(' if Assigned(obj) then ;');
|
|
Add(' b:=Assigned(obj) or false;');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_Assigned',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'if ($mod.Obj != null);',
|
|
'$mod.b = ($mod.Obj != null) || false;'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_WithClassDoCreate;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' aBool: boolean;');
|
|
Add(' Arr: array of boolean;');
|
|
Add(' constructor Create;');
|
|
Add(' end;');
|
|
Add('constructor TObject.Create; begin end;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add(' with tobject.create do begin');
|
|
Add(' b:=abool;');
|
|
Add(' abool:=b;');
|
|
Add(' b:=arr[1];');
|
|
Add(' arr[2]:=b;');
|
|
Add(' end;');
|
|
Add(' with tobject do');
|
|
Add(' obj:=create;');
|
|
Add(' with obj do begin');
|
|
Add(' create;');
|
|
Add(' b:=abool;');
|
|
Add(' abool:=b;');
|
|
Add(' b:=arr[3];');
|
|
Add(' arr[4]:=b;');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_WithClassDoCreate',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.aBool = false;',
|
|
' this.Arr = [];',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.Arr = undefined;',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'var $with1 = $mod.TObject.$create("Create");',
|
|
'$mod.b = $with1.aBool;',
|
|
'$with1.aBool = $mod.b;',
|
|
'$mod.b = $with1.Arr[1];',
|
|
'$with1.Arr[2] = $mod.b;',
|
|
'var $with2 = $mod.TObject;',
|
|
'$mod.Obj = $with2.$create("Create");',
|
|
'var $with3 = $mod.Obj;',
|
|
'$with3.Create();',
|
|
'$mod.b = $with3.aBool;',
|
|
'$with3.aBool = $mod.b;',
|
|
'$mod.b = $with3.Arr[3];',
|
|
'$with3.Arr[4] = $mod.b;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_WithClassInstDoProperty;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' FInt: longint;');
|
|
Add(' constructor Create;');
|
|
Add(' function GetSize: longint;');
|
|
Add(' procedure SetSize(Value: longint);');
|
|
Add(' property Int: longint read FInt write FInt;');
|
|
Add(' property Size: longint read GetSize write SetSize;');
|
|
Add(' end;');
|
|
Add('constructor TObject.Create; begin end;');
|
|
Add('function TObject.GetSize: longint; begin; end;');
|
|
Add('procedure TObject.SetSize(Value: longint); begin; end;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add(' i: longint;');
|
|
Add('begin');
|
|
Add(' with TObject.Create do begin');
|
|
Add(' i:=int;');
|
|
Add(' int:=i;');
|
|
Add(' i:=size;');
|
|
Add(' size:=i;');
|
|
Add(' end;');
|
|
Add(' with obj do begin');
|
|
Add(' i:=int;');
|
|
Add(' int:=i;');
|
|
Add(' i:=size;');
|
|
Add(' size:=i;');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_WithClassInstDoProperty',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FInt = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' };',
|
|
' this.GetSize = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetSize = function (Value) {',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'var $with1 = $mod.TObject.$create("Create");',
|
|
'$mod.i = $with1.FInt;',
|
|
'$with1.FInt = $mod.i;',
|
|
'$mod.i = $with1.GetSize();',
|
|
'$with1.SetSize($mod.i);',
|
|
'var $with2 = $mod.Obj;',
|
|
'$mod.i = $with2.FInt;',
|
|
'$with2.FInt = $mod.i;',
|
|
'$mod.i = $with2.GetSize();',
|
|
'$with2.SetSize($mod.i);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_WithClassInstDoPropertyWithParams;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' constructor Create;');
|
|
Add(' function GetItems(Index: longint): longint;');
|
|
Add(' procedure SetItems(Index, Value: longint);');
|
|
Add(' property Items[Index: longint]: longint read GetItems write SetItems;');
|
|
Add(' end;');
|
|
Add('constructor TObject.Create; begin end;');
|
|
Add('function tobject.getitems(index: longint): longint; begin; end;');
|
|
Add('procedure tobject.setitems(index, value: longint); begin; end;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add(' i: longint;');
|
|
Add('begin');
|
|
Add(' with TObject.Create do begin');
|
|
Add(' i:=Items[1];');
|
|
Add(' Items[2]:=i;');
|
|
Add(' end;');
|
|
Add(' with obj do begin');
|
|
Add(' i:=Items[3];');
|
|
Add(' Items[4]:=i;');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_WithClassInstDoPropertyWithParams',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' };',
|
|
' this.GetItems = function (Index) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetItems = function (Index, Value) {',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'var $with1 = $mod.TObject.$create("Create");',
|
|
'$mod.i = $with1.GetItems(1);',
|
|
'$with1.SetItems(2, $mod.i);',
|
|
'var $with2 = $mod.Obj;',
|
|
'$mod.i = $with2.GetItems(3);',
|
|
'$with2.SetItems(4, $mod.i);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_WithClassInstDoFunc;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' constructor Create;');
|
|
Add(' function GetSize: longint;');
|
|
Add(' procedure SetSize(Value: longint);');
|
|
Add(' end;');
|
|
Add('constructor TObject.Create; begin end;');
|
|
Add('function TObject.GetSize: longint; begin; end;');
|
|
Add('procedure TObject.SetSize(Value: longint); begin; end;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add(' i: longint;');
|
|
Add('begin');
|
|
Add(' with TObject.Create do begin');
|
|
Add(' i:=GetSize;');
|
|
Add(' i:=GetSize();');
|
|
Add(' SetSize(i);');
|
|
Add(' end;');
|
|
Add(' with obj do begin');
|
|
Add(' i:=GetSize;');
|
|
Add(' i:=GetSize();');
|
|
Add(' SetSize(i);');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_WithClassInstDoFunc',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' };',
|
|
' this.GetSize = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetSize = function (Value) {',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.i = 0;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'var $with1 = $mod.TObject.$create("Create");',
|
|
'$mod.i = $with1.GetSize();',
|
|
'$mod.i = $with1.GetSize();',
|
|
'$with1.SetSize($mod.i);',
|
|
'var $with2 = $mod.Obj;',
|
|
'$mod.i = $with2.GetSize();',
|
|
'$mod.i = $with2.GetSize();',
|
|
'$with2.SetSize($mod.i);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TypeCast;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' Next: TObject;');
|
|
Add(' constructor Create;');
|
|
Add(' end;');
|
|
Add(' TControl = class(TObject)');
|
|
Add(' Arr: array of TObject;');
|
|
Add(' function GetIt(vI: longint = 0): TObject;');
|
|
Add(' end;');
|
|
Add('constructor tobject.create; begin end;');
|
|
Add('function tcontrol.getit(vi: longint = 0): tobject; begin end;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add('begin');
|
|
Add(' obj:=tcontrol(obj).next;');
|
|
Add(' tcontrol(obj):=nil;');
|
|
Add(' obj:=tcontrol(obj);');
|
|
Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit);');
|
|
Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit());');
|
|
Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit(1));');
|
|
Add(' tcontrol(obj):=tcontrol(tcontrol(tcontrol(obj).getit).arr[2]);');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_TypeCast',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.Next = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.Next = undefined;',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TControl", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.Arr = [];',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.Arr = undefined;',
|
|
' $mod.TObject.$final.call(this);',
|
|
' };',
|
|
' this.GetIt = function (vI) {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj = $mod.Obj.Next;',
|
|
'$mod.Obj = null;',
|
|
'$mod.Obj = $mod.Obj;',
|
|
'$mod.Obj = $mod.Obj.GetIt(0);',
|
|
'$mod.Obj = $mod.Obj.GetIt(0);',
|
|
'$mod.Obj = $mod.Obj.GetIt(1);',
|
|
'$mod.Obj = $mod.Obj.GetIt(0).Arr[2];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TypeCastUntypedParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class end;');
|
|
Add('procedure ProcA(var A);');
|
|
Add('begin');
|
|
Add(' TObject(A):=nil;');
|
|
Add(' TObject(A):=TObject(A);');
|
|
Add(' if TObject(A)=nil then ;');
|
|
Add(' if nil=TObject(A) then ;');
|
|
Add('end;');
|
|
Add('procedure ProcB(out A);');
|
|
Add('begin');
|
|
Add(' TObject(A):=nil;');
|
|
Add(' TObject(A):=TObject(A);');
|
|
Add(' if TObject(A)=nil then ;');
|
|
Add(' if nil=TObject(A) then ;');
|
|
Add('end;');
|
|
Add('procedure ProcC(const A);');
|
|
Add('begin');
|
|
Add(' if TObject(A)=nil then ;');
|
|
Add(' if nil=TObject(A) then ;');
|
|
Add('end;');
|
|
Add('var o: TObject;');
|
|
Add('begin');
|
|
Add(' ProcA(o);');
|
|
Add(' ProcB(o);');
|
|
Add(' ProcC(o);');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_TypeCastUntypedParam',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.ProcA = function (A) {',
|
|
' A.set(null);',
|
|
' A.set(A.get());',
|
|
' if (A.get() === null);',
|
|
' if (null === A.get());',
|
|
'};',
|
|
'this.ProcB = function (A) {',
|
|
' A.set(null);',
|
|
' A.set(A.get());',
|
|
' if (A.get() === null);',
|
|
' if (null === A.get());',
|
|
'};',
|
|
'this.ProcC = function (A) {',
|
|
' if (A === null);',
|
|
' if (null === A);',
|
|
'};',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.ProcA({',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.o;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.o = v;',
|
|
' }',
|
|
'});',
|
|
'$mod.ProcB({',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.o;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.o = v;',
|
|
' }',
|
|
'});',
|
|
'$mod.ProcC($mod.o);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Overloads;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' procedure DoIt;');
|
|
Add(' procedure DoIt(vI: longint);');
|
|
Add(' end;');
|
|
Add('procedure TObject.DoIt;');
|
|
Add('begin');
|
|
Add(' DoIt;');
|
|
Add(' DoIt(1);');
|
|
Add('end;');
|
|
Add('procedure TObject.DoIt(vI: longint); begin end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_Overloads',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' this.DoIt();',
|
|
' this.DoIt$1(1);',
|
|
' };',
|
|
' this.DoIt$1 = function (vI) {',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_OverloadsAncestor;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class;');
|
|
Add(' TObject = class');
|
|
Add(' procedure DoIt(vA: longint);');
|
|
Add(' procedure DoIt(vA, vB: longint);');
|
|
Add(' end;');
|
|
Add(' TCar = class;');
|
|
Add(' TCar = class');
|
|
Add(' procedure DoIt(vA: longint);');
|
|
Add(' procedure DoIt(vA, vB: longint);');
|
|
Add(' end;');
|
|
Add('procedure tobject.doit(va: longint);');
|
|
Add('begin');
|
|
Add(' doit(1);');
|
|
Add(' doit(1,2);');
|
|
Add('end;');
|
|
Add('procedure tobject.doit(va, vb: longint); begin end;');
|
|
Add('procedure tcar.doit(va: longint);');
|
|
Add('begin');
|
|
Add(' doit(1);');
|
|
Add(' doit(1,2);');
|
|
Add(' inherited doit(1);');
|
|
Add(' inherited doit(1,2);');
|
|
Add('end;');
|
|
Add('procedure tcar.doit(va, vb: longint); begin end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_OverloadsAncestor',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (vA) {',
|
|
' this.DoIt(1);',
|
|
' this.DoIt$1(1,2);',
|
|
' };',
|
|
' this.DoIt$1 = function (vA, vB) {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
|
|
' this.DoIt$2 = function (vA) {',
|
|
' this.DoIt$2(1);',
|
|
' this.DoIt$3(1, 2);',
|
|
' $mod.TObject.DoIt.call(this, 1);',
|
|
' $mod.TObject.DoIt$1.call(this, 1, 2);',
|
|
' };',
|
|
' this.DoIt$3 = function (vA, vB) {',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_OverloadConstructor;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' constructor Create(vA: longint);');
|
|
Add(' constructor Create(vA, vB: longint);');
|
|
Add(' end;');
|
|
Add(' TCar = class');
|
|
Add(' constructor Create(vA: longint);');
|
|
Add(' constructor Create(vA, vB: longint);');
|
|
Add(' end;');
|
|
Add('constructor tobject.create(va: longint);');
|
|
Add('begin');
|
|
Add(' create(1);');
|
|
Add(' create(1,2);');
|
|
Add('end;');
|
|
Add('constructor tobject.create(va, vb: longint); begin end;');
|
|
Add('constructor tcar.create(va: longint);');
|
|
Add('begin');
|
|
Add(' create(1);');
|
|
Add(' create(1,2);');
|
|
Add(' inherited create(1);');
|
|
Add(' inherited create(1,2);');
|
|
Add('end;');
|
|
Add('constructor tcar.create(va, vb: longint); begin end;');
|
|
Add('begin');
|
|
Add(' tobject.create(1);');
|
|
Add(' tobject.create(1,2);');
|
|
Add(' tcar.create(1);');
|
|
Add(' tcar.create(1,2);');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_OverloadConstructor',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function (vA) {',
|
|
' this.Create(1);',
|
|
' this.Create$1(1,2);',
|
|
' };',
|
|
' this.Create$1 = function (vA, vB) {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
|
|
' this.Create$2 = function (vA) {',
|
|
' this.Create$2(1);',
|
|
' this.Create$3(1, 2);',
|
|
' $mod.TObject.Create.call(this, 1);',
|
|
' $mod.TObject.Create$1.call(this, 1, 2);',
|
|
' };',
|
|
' this.Create$3 = function (vA, vB) {',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.TObject.$create("Create", [1]);',
|
|
'$mod.TObject.$create("Create$1", [1, 2]);',
|
|
'$mod.TCar.$create("Create$2", [1]);',
|
|
'$mod.TCar.$create("Create$3", [1, 2]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_OverloadDelphiOverride;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$mode delphi}',
|
|
'type',
|
|
' TObject = class end;',
|
|
' TBird = class',
|
|
' function {#a}GetValue: longint; overload; virtual;',
|
|
' function {#b}GetValue(AValue: longint): longint; overload; virtual;',
|
|
' end;',
|
|
' TEagle = class(TBird)',
|
|
' function {#c}GetValue: longint; overload; override;',
|
|
' function {#d}GetValue(AValue: longint): longint; overload; override;',
|
|
' end;',
|
|
'function TBird.GetValue: longint;',
|
|
'begin',
|
|
' if 3={@a}GetValue then ;',
|
|
' if 4={@b}GetValue(5) then ;',
|
|
'end;',
|
|
'function TBird.GetValue(AValue: longint): longint;',
|
|
'begin',
|
|
'end;',
|
|
'function TEagle.GetValue: longint;',
|
|
'begin',
|
|
' if 13={@c}GetValue then ;',
|
|
' if 14={@d}GetValue(15) then ;',
|
|
' if 15=inherited {@a}GetValue then ;',
|
|
' if 16=inherited {@b}GetValue(17) then ;',
|
|
'end;',
|
|
'function TEagle.GetValue(AValue: longint): longint;',
|
|
'begin',
|
|
'end;',
|
|
'var',
|
|
' e: TEagle;',
|
|
'begin',
|
|
' if 23=e.{@c}GetValue then ;',
|
|
' if 24=e.{@d}GetValue(25) then ;']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_OverloadDelphiOverride',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' this.GetValue = function () {',
|
|
' var Result = 0;',
|
|
' if (3 === this.GetValue()) ;',
|
|
' if (4 === this.GetValue$1(5)) ;',
|
|
' return Result;',
|
|
' };',
|
|
' this.GetValue$1 = function (AValue) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TEagle", $mod.TBird, function () {',
|
|
' this.GetValue = function () {',
|
|
' var Result = 0;',
|
|
' if (13 === this.GetValue()) ;',
|
|
' if (14 === this.GetValue$1(15)) ;',
|
|
' if (15 === $mod.TBird.GetValue.call(this)) ;',
|
|
' if (16 === $mod.TBird.GetValue$1.call(this, 17)) ;',
|
|
' return Result;',
|
|
' };',
|
|
' this.GetValue$1 = function (AValue) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.e = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'if (23 === $mod.e.GetValue()) ;',
|
|
'if (24 === $mod.e.GetValue$1(25)) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_ReintroducedVar;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' strict private');
|
|
Add(' Some: longint;');
|
|
Add(' end;');
|
|
Add(' TMobile = class');
|
|
Add(' strict private');
|
|
Add(' Some: string;');
|
|
Add(' end;');
|
|
Add(' TCar = class(tmobile)');
|
|
Add(' procedure Some;');
|
|
Add(' procedure Some(vA: longint);');
|
|
Add(' end;');
|
|
Add('procedure tcar.some;');
|
|
Add('begin');
|
|
Add(' Some;');
|
|
Add(' Some(1);');
|
|
Add('end;');
|
|
Add('procedure tcar.some(va: longint); begin end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_ReintroducedVar',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.Some = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.Some$1 = "";',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
|
|
' this.Some$2 = function () {',
|
|
' this.Some$2();',
|
|
' this.Some$3(1);',
|
|
' };',
|
|
' this.Some$3 = function (vA) {',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_RaiseDescendant;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' constructor Create(Msg: string);',
|
|
' end;',
|
|
' Exception = class',
|
|
' end;',
|
|
' EConvertError = class(Exception)',
|
|
' end;',
|
|
'constructor TObject.Create(Msg: string); begin end;',
|
|
'function AssertConv(Msg: string = ''def''): EConvertError; begin end;',
|
|
'begin',
|
|
' raise Exception.Create(''Bar1'');',
|
|
' raise EConvertError.Create(''Bar2'');',
|
|
' raise AssertConv(''Bar2'');',
|
|
' raise AssertConv;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_RaiseDescendant',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function (Msg) {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
|
|
'});',
|
|
'rtl.createClass($mod, "EConvertError", $mod.Exception, function () {',
|
|
'});',
|
|
'this.AssertConv = function (Msg) {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'throw $mod.Exception.$create("Create",["Bar1"]);',
|
|
'throw $mod.EConvertError.$create("Create",["Bar2"]);',
|
|
'throw $mod.AssertConv("Bar2");',
|
|
'throw $mod.AssertConv("def");',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_ExternalMethod;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit2.pas',
|
|
LinesToStr([
|
|
'type',
|
|
' TObject = class',
|
|
' public',
|
|
' procedure Intern; external name ''$DoIntern'';',
|
|
' end;',
|
|
'']),
|
|
LinesToStr([
|
|
'']));
|
|
|
|
StartUnit(true);
|
|
Add('interface');
|
|
Add('uses unit2;');
|
|
Add('type');
|
|
Add(' TCar = class(TObject)');
|
|
Add(' public');
|
|
Add(' procedure Intern2; external name ''$DoIntern2'';');
|
|
Add(' procedure DoIt;');
|
|
Add(' end;');
|
|
Add('implementation');
|
|
Add('procedure tcar.doit;');
|
|
Add('begin');
|
|
Add(' Intern;');
|
|
Add(' Intern();');
|
|
Add(' Intern2;');
|
|
Add(' Intern2();');
|
|
Add('end;');
|
|
Add('var Obj: TCar;');
|
|
Add('begin');
|
|
Add(' obj.intern;');
|
|
Add(' obj.intern();');
|
|
Add(' obj.intern2;');
|
|
Add(' obj.intern2();');
|
|
Add(' obj.doit;');
|
|
Add(' obj.doit();');
|
|
Add(' with obj do begin');
|
|
Add(' Intern;');
|
|
Add(' Intern();');
|
|
Add(' Intern2;');
|
|
Add(' Intern2();');
|
|
Add(' end;');
|
|
ConvertUnit;
|
|
CheckSource('TestClass_ExternalMethod',
|
|
LinesToStr([
|
|
'var $impl = $mod.$impl;',
|
|
'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
|
|
' this.DoIt = function () {',
|
|
' this.$DoIntern();',
|
|
' this.$DoIntern();',
|
|
' this.$DoIntern2();',
|
|
' this.$DoIntern2();',
|
|
' };',
|
|
' });',
|
|
'']),
|
|
LinesToStr([ // this.$init
|
|
'$impl.Obj.$DoIntern();',
|
|
'$impl.Obj.$DoIntern();',
|
|
'$impl.Obj.$DoIntern2();',
|
|
'$impl.Obj.$DoIntern2();',
|
|
'$impl.Obj.DoIt();',
|
|
'$impl.Obj.DoIt();',
|
|
'var $with1 = $impl.Obj;',
|
|
'$with1.$DoIntern();',
|
|
'$with1.$DoIntern();',
|
|
'$with1.$DoIntern2();',
|
|
'$with1.$DoIntern2();',
|
|
'']),
|
|
LinesToStr([ // implementation
|
|
'$impl.Obj = null;',
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_ExternalVirtualNameMismatchFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' procedure DoIt; virtual; external name ''Foo'';');
|
|
Add(' end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError('Virtual method name must match external',
|
|
nVirtualMethodNameMustMatchExternal);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_ExternalOverrideFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' procedure DoIt; virtual; external name ''DoIt'';');
|
|
Add(' end;');
|
|
Add(' TCar = class');
|
|
Add(' procedure DoIt; override; external name ''DoIt'';');
|
|
Add(' end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError('Invalid procedure modifier override,external',
|
|
nInvalidXModifierY);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_ExternalVar;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit2.pas',
|
|
LinesToStr([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TObject = class',
|
|
' public',
|
|
' Intern: longint external name ''$Intern'';',
|
|
' Bracket: longint external name ''["A B"]'';',
|
|
' end;',
|
|
'']),
|
|
LinesToStr([
|
|
'']));
|
|
|
|
StartUnit(true);
|
|
Add([
|
|
'interface',
|
|
'uses unit2;',
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TCar = class(tobject)',
|
|
' public',
|
|
' Intern2: longint external name ''$Intern2'';',
|
|
' procedure DoIt;',
|
|
' end;',
|
|
'implementation',
|
|
'procedure tcar.doit;',
|
|
'begin',
|
|
' Intern:=Intern+1;',
|
|
' Intern2:=Intern2+2;',
|
|
' Bracket:=Bracket+3;',
|
|
'end;',
|
|
'var Obj: TCar;',
|
|
'begin',
|
|
' obj.intern:=obj.intern+1;',
|
|
' obj.intern2:=obj.intern2+2;',
|
|
' obj.Bracket:=obj.Bracket+3;',
|
|
' with obj do begin',
|
|
' intern:=intern+1;',
|
|
' intern2:=intern2+2;',
|
|
' Bracket:=Bracket+3;',
|
|
' end;']);
|
|
ConvertUnit;
|
|
CheckSource('TestClass_ExternalVar',
|
|
LinesToStr([
|
|
'var $impl = $mod.$impl;',
|
|
'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
|
|
' this.DoIt = function () {',
|
|
' this.$Intern = this.$Intern + 1;',
|
|
' this.$Intern2 = this.$Intern2 + 2;',
|
|
' this["A B"] = this["A B"] + 3;',
|
|
' };',
|
|
' });',
|
|
'']),
|
|
LinesToStr([
|
|
'$impl.Obj.$Intern = $impl.Obj.$Intern + 1;',
|
|
'$impl.Obj.$Intern2 = $impl.Obj.$Intern2 + 2;',
|
|
'$impl.Obj["A B"] = $impl.Obj["A B"] + 3;',
|
|
'var $with1 = $impl.Obj;',
|
|
'$with1.$Intern = $with1.$Intern + 1;',
|
|
'$with1.$Intern2 = $with1.$Intern2 + 2;',
|
|
'$with1["A B"] = $with1["A B"] + 3;',
|
|
'']),
|
|
LinesToStr([ // implementation
|
|
'$impl.Obj = null;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_Const;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TClass = class of TObject;');
|
|
Add(' TObject = class');
|
|
Add(' public');
|
|
Add(' const cI: integer = 3;');
|
|
Add(' procedure DoIt;');
|
|
Add(' class procedure DoMore;');
|
|
Add(' end;');
|
|
Add('implementation');
|
|
Add('procedure tobject.doit;');
|
|
Add('begin');
|
|
Add(' if cI=4 then;');
|
|
Add(' if 5=cI then;');
|
|
Add(' if Self.cI=6 then;');
|
|
Add(' if 7=Self.cI then;');
|
|
Add(' with Self do begin');
|
|
Add(' if cI=11 then;');
|
|
Add(' if 12=cI then;');
|
|
Add(' end;');
|
|
Add('end;');
|
|
Add('class procedure tobject.domore;');
|
|
Add('begin');
|
|
Add(' if cI=8 then;');
|
|
Add(' if Self.cI=9 then;');
|
|
Add(' if 10=cI then;');
|
|
Add(' if 11=Self.cI then;');
|
|
Add(' with Self do begin');
|
|
Add(' if cI=13 then;');
|
|
Add(' if 14=cI then;');
|
|
Add(' end;');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' Obj: TObject;');
|
|
Add(' Cla: TClass;');
|
|
Add('begin');
|
|
Add(' if TObject.cI=21 then ;');
|
|
Add(' if Obj.cI=22 then ;');
|
|
Add(' if Cla.cI=23 then ;');
|
|
Add(' with obj do if ci=24 then;');
|
|
Add(' with TObject do if ci=25 then;');
|
|
Add(' with Cla do if ci=26 then;');
|
|
ConvertProgram;
|
|
CheckSource('TestClass_Const',
|
|
LinesToStr([
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.cI = 3;',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' if (this.cI === 4) ;',
|
|
' if (5 === this.cI) ;',
|
|
' if (this.cI === 6) ;',
|
|
' if (7 === this.cI) ;',
|
|
' if (this.cI === 11) ;',
|
|
' if (12 === this.cI) ;',
|
|
' };',
|
|
' this.DoMore = function () {',
|
|
' if (this.cI === 8) ;',
|
|
' if (this.cI === 9) ;',
|
|
' if (10 === this.cI) ;',
|
|
' if (11 === this.cI) ;',
|
|
' if (this.cI === 13) ;',
|
|
' if (14 === this.cI) ;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.Cla = null;',
|
|
'']),
|
|
LinesToStr([
|
|
'if ($mod.TObject.cI === 21) ;',
|
|
'if ($mod.Obj.cI === 22) ;',
|
|
'if ($mod.Cla.cI === 23) ;',
|
|
'var $with1 = $mod.Obj;',
|
|
'if ($with1.cI === 24) ;',
|
|
'var $with2 = $mod.TObject;',
|
|
'if ($with2.cI === 25) ;',
|
|
'var $with3 = $mod.Cla;',
|
|
'if ($with3.cI === 26) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_LocalVarSelfFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' constructor Create;',
|
|
' end;',
|
|
'constructor tobject.create;',
|
|
'var self: longint;',
|
|
'begin',
|
|
'end',
|
|
'begin',
|
|
'']);
|
|
SetExpectedPasResolverError('Duplicate identifier "self" at (0)',nDuplicateIdentifier);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_ArgSelfFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' procedure DoIt(Self: longint);',
|
|
' end;',
|
|
'procedure tobject.doit(self: longint);',
|
|
'begin',
|
|
'end',
|
|
'begin',
|
|
'']);
|
|
SetExpectedPasResolverError('Duplicate identifier "Self" at test1.pp(5,24)',nDuplicateIdentifier);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_NestedProcSelf;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' Key: longint;',
|
|
' class var State: longint;',
|
|
' procedure DoIt;',
|
|
' function GetSize: longint; virtual; abstract;',
|
|
' procedure SetSize(Value: longint); virtual; abstract;',
|
|
' property Size: longint read GetSize write SetSize;',
|
|
' end;',
|
|
'procedure tobject.doit;',
|
|
' procedure Sub;',
|
|
' begin',
|
|
' key:=key+2;',
|
|
' self.key:=self.key+3;',
|
|
' state:=state+4;',
|
|
' self.state:=self.state+5;',
|
|
' tobject.state:=tobject.state+6;',
|
|
' size:=size+7;',
|
|
' self.size:=self.size+8;',
|
|
' end;',
|
|
'begin',
|
|
' sub;',
|
|
' key:=key+12;',
|
|
' self.key:=self.key+13;',
|
|
' state:=state+14;',
|
|
' self.state:=self.state+15;',
|
|
' tobject.state:=tobject.state+16;',
|
|
' size:=size+17;',
|
|
' self.size:=self.size+18;',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_NestedProcSelf',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.State = 0;',
|
|
' this.$init = function () {',
|
|
' this.Key = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' var Self = this;',
|
|
' function Sub() {',
|
|
' Self.Key = Self.Key + 2;',
|
|
' Self.Key = Self.Key + 3;',
|
|
' $mod.TObject.State = Self.State + 4;',
|
|
' $mod.TObject.State = Self.State + 5;',
|
|
' $mod.TObject.State = $mod.TObject.State + 6;',
|
|
' Self.SetSize(Self.GetSize() + 7);',
|
|
' Self.SetSize(Self.GetSize() + 8);',
|
|
' };',
|
|
' Sub();',
|
|
' Self.Key = Self.Key + 12;',
|
|
' Self.Key = Self.Key + 13;',
|
|
' $mod.TObject.State = Self.State + 14;',
|
|
' $mod.TObject.State = Self.State + 15;',
|
|
' $mod.TObject.State = $mod.TObject.State + 16;',
|
|
' Self.SetSize(Self.GetSize() + 17);',
|
|
' Self.SetSize(Self.GetSize() + 18);',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_NestedProcSelf2;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' Key: longint;',
|
|
' class var State: longint;',
|
|
' function GetSize: longint; virtual; abstract;',
|
|
' procedure SetSize(Value: longint); virtual; abstract;',
|
|
' property Size: longint read GetSize write SetSize;',
|
|
' end;',
|
|
' TBird = class',
|
|
' procedure DoIt;',
|
|
' end;',
|
|
'procedure tbird.doit;',
|
|
' procedure Sub;',
|
|
' begin',
|
|
' key:=key+2;',
|
|
' self.key:=self.key+3;',
|
|
' state:=state+4;',
|
|
' self.state:=self.state+5;',
|
|
' tobject.state:=tobject.state+6;',
|
|
' size:=size+7;',
|
|
' self.size:=self.size+8;',
|
|
' end;',
|
|
'begin',
|
|
' sub;',
|
|
' key:=key+12;',
|
|
' self.key:=self.key+13;',
|
|
' state:=state+14;',
|
|
' self.state:=self.state+15;',
|
|
' tobject.state:=tobject.state+16;',
|
|
' size:=size+17;',
|
|
' self.size:=self.size+18;',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_NestedProcSelf2',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.State = 0;',
|
|
' this.$init = function () {',
|
|
' this.Key = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' this.DoIt = function () {',
|
|
' var Self = this;',
|
|
' function Sub() {',
|
|
' Self.Key = Self.Key + 2;',
|
|
' Self.Key = Self.Key + 3;',
|
|
' $mod.TObject.State = Self.State + 4;',
|
|
' $mod.TObject.State = Self.State + 5;',
|
|
' $mod.TObject.State = $mod.TObject.State + 6;',
|
|
' Self.SetSize(Self.GetSize() + 7);',
|
|
' Self.SetSize(Self.GetSize() + 8);',
|
|
' };',
|
|
' Sub();',
|
|
' Self.Key = Self.Key + 12;',
|
|
' Self.Key = Self.Key + 13;',
|
|
' $mod.TObject.State = Self.State + 14;',
|
|
' $mod.TObject.State = Self.State + 15;',
|
|
' $mod.TObject.State = $mod.TObject.State + 16;',
|
|
' Self.SetSize(Self.GetSize() + 17);',
|
|
' Self.SetSize(Self.GetSize() + 18);',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_NestedProcClassSelf;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' class var State: longint;',
|
|
' class procedure DoIt;',
|
|
' class function GetSize: longint; virtual; abstract;',
|
|
' class procedure SetSize(Value: longint); virtual; abstract;',
|
|
' class property Size: longint read GetSize write SetSize;',
|
|
' end;',
|
|
'class procedure tobject.doit;',
|
|
' procedure Sub;',
|
|
' begin',
|
|
' state:=state+2;',
|
|
' self.state:=self.state+3;',
|
|
' tobject.state:=tobject.state+4;',
|
|
' size:=size+5;',
|
|
' self.size:=self.size+6;',
|
|
' tobject.size:=tobject.size+7;',
|
|
' end;',
|
|
'begin',
|
|
' sub;',
|
|
' state:=state+12;',
|
|
' self.state:=self.state+13;',
|
|
' tobject.state:=tobject.state+14;',
|
|
' size:=size+15;',
|
|
' self.size:=self.size+16;',
|
|
' tobject.size:=tobject.size+17;',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_NestedProcClassSelf',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.State = 0;',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' var Self = this;',
|
|
' function Sub() {',
|
|
' $mod.TObject.State = Self.State + 2;',
|
|
' $mod.TObject.State = Self.State + 3;',
|
|
' $mod.TObject.State = $mod.TObject.State + 4;',
|
|
' Self.SetSize(Self.GetSize() + 5);',
|
|
' Self.SetSize(Self.GetSize() + 6);',
|
|
' $mod.TObject.SetSize($mod.TObject.GetSize() + 7);',
|
|
' };',
|
|
' Sub();',
|
|
' $mod.TObject.State = Self.State + 12;',
|
|
' $mod.TObject.State = Self.State + 13;',
|
|
' $mod.TObject.State = $mod.TObject.State + 14;',
|
|
' Self.SetSize(Self.GetSize() + 15);',
|
|
' Self.SetSize(Self.GetSize() + 16);',
|
|
' $mod.TObject.SetSize($mod.TObject.GetSize() + 17);',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_NestedProcCallInherited;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' function DoIt(k: boolean): longint; virtual;',
|
|
' end;',
|
|
' TBird = class',
|
|
' function DoIt(k: boolean): longint; override;',
|
|
' end;',
|
|
'function tobject.doit(k: boolean): longint;',
|
|
'begin',
|
|
'end;',
|
|
'function tbird.doit(k: boolean): longint;',
|
|
' procedure Sub;',
|
|
' begin',
|
|
' inherited DoIt(true);',
|
|
//' if inherited DoIt(false)=4 then ;',
|
|
' end;',
|
|
'begin',
|
|
' Sub;',
|
|
' inherited;',
|
|
' inherited DoIt(true);',
|
|
//' if inherited DoIt(false)=14 then ;',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_NestedProcCallInherited',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (k) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' this.DoIt = function (k) {',
|
|
' var Self = this;',
|
|
' var Result = 0;',
|
|
' function Sub() {',
|
|
' $mod.TObject.DoIt.call(Self, true);',
|
|
' };',
|
|
' Sub();',
|
|
' $mod.TObject.DoIt.apply(Self, arguments);',
|
|
' $mod.TObject.DoIt.call(Self, true);',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TObjectFree;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' Obj: tobject;',
|
|
' procedure Free;',
|
|
' procedure Release;',
|
|
' end;',
|
|
'procedure tobject.free;',
|
|
'begin',
|
|
'end;',
|
|
'procedure tobject.release;',
|
|
'begin',
|
|
' free;',
|
|
' if true then free;',
|
|
'end;',
|
|
'function DoIt(o: tobject): tobject;',
|
|
'var l: tobject;',
|
|
'begin',
|
|
' o.free;',
|
|
' o.free();',
|
|
' l.free;',
|
|
' l.free();',
|
|
' o.obj.free;',
|
|
' o.obj.free();',
|
|
' with o do obj.free;',
|
|
' with o do obj.free();',
|
|
' result.Free;',
|
|
' result.Free();',
|
|
'end;',
|
|
'var o: tobject;',
|
|
' a: array of tobject;',
|
|
'begin',
|
|
' o.free;',
|
|
' o.obj.free;',
|
|
' a[1+2].free;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_TObjectFree',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.Obj = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.Obj = undefined;',
|
|
' };',
|
|
' this.Free = function () {',
|
|
' };',
|
|
' this.Release = function () {',
|
|
' this.Free();',
|
|
' if (true) this.Free();',
|
|
' };',
|
|
'});',
|
|
'this.DoIt = function (o) {',
|
|
' var Result = null;',
|
|
' var l = null;',
|
|
' o = rtl.freeLoc(o);',
|
|
' o = rtl.freeLoc(o);',
|
|
' l = rtl.freeLoc(l);',
|
|
' l = rtl.freeLoc(l);',
|
|
' rtl.free(o, "Obj");',
|
|
' rtl.free(o, "Obj");',
|
|
' rtl.free(o, "Obj");',
|
|
' rtl.free(o, "Obj");',
|
|
' Result = rtl.freeLoc(Result);',
|
|
' Result = rtl.freeLoc(Result);',
|
|
' return Result;',
|
|
'};',
|
|
'this.o = null;',
|
|
'this.a = [];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'rtl.free($mod, "o");',
|
|
'rtl.free($mod.o, "Obj");',
|
|
'rtl.free($mod.a, 1 + 2);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TObjectFreeNewInstance;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' constructor Create;',
|
|
' procedure Free;',
|
|
' end;',
|
|
'constructor TObject.Create; begin end;',
|
|
'procedure tobject.free; begin end;',
|
|
'begin',
|
|
' with tobject.create do free;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_TObjectFreeNewInstance',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' };',
|
|
' this.Free = function () {',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'var $with1 = $mod.TObject.$create("Create");',
|
|
'$with1=rtl.freeLoc($with1);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TObjectFreeLowerCase;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' destructor Destroy;',
|
|
' procedure Free;',
|
|
' end;',
|
|
'destructor TObject.Destroy; begin end;',
|
|
'procedure tobject.free; begin end;',
|
|
'var o: tobject;',
|
|
'begin',
|
|
' o.free;',
|
|
'']);
|
|
Converter.UseLowerCase:=true;
|
|
ConvertProgram;
|
|
CheckSource('TestClass_TObjectFreeLowerCase',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "tobject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.tObjectDestroy = "destroy";',
|
|
' this.destroy = function () {',
|
|
' };',
|
|
' this.free = function () {',
|
|
' };',
|
|
'});',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'rtl.free($mod, "o");',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TObjectFreeFunctionFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' procedure Free;',
|
|
' function GetObj: tobject; virtual; abstract;',
|
|
' end;',
|
|
'procedure tobject.free;',
|
|
'begin',
|
|
'end;',
|
|
'var o: tobject;',
|
|
'begin',
|
|
' o.getobj.free;',
|
|
'']);
|
|
SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_TObjectFreePropertyFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' procedure Free;',
|
|
' FObj: TObject;',
|
|
' property Obj: tobject read FObj write FObj;',
|
|
' end;',
|
|
'procedure tobject.free;',
|
|
'begin',
|
|
'end;',
|
|
'var o: tobject;',
|
|
'begin',
|
|
' o.obj.free;',
|
|
'']);
|
|
SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClass_ForIn;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class end;',
|
|
' TItem = TObject;',
|
|
' TEnumerator = class',
|
|
' FCurrent: TItem;',
|
|
' property Current: TItem read FCurrent;',
|
|
' function MoveNext: boolean;',
|
|
' end;',
|
|
' TBird = class',
|
|
' function GetEnumerator: TEnumerator;',
|
|
' end;',
|
|
'function TEnumerator.MoveNext: boolean;',
|
|
'begin',
|
|
'end;',
|
|
'function TBird.GetEnumerator: TEnumerator;',
|
|
'begin',
|
|
'end;',
|
|
'var',
|
|
' b: TBird;',
|
|
' i, i2: TItem;',
|
|
'begin',
|
|
' for i in b do i2:=i;']);
|
|
ConvertProgram;
|
|
CheckSource('TestClass_ForIn',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TEnumerator", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.FCurrent = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FCurrent = undefined;',
|
|
' $mod.TObject.$final.call(this);',
|
|
' };',
|
|
' this.MoveNext = function () {',
|
|
' var Result = false;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' this.GetEnumerator = function () {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.b = null;',
|
|
'this.i = null;',
|
|
'this.i2 = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'var $in1 = $mod.b.GetEnumerator();',
|
|
'try {',
|
|
' while ($in1.MoveNext()){',
|
|
' $mod.i = $in1.FCurrent;',
|
|
' $mod.i2 = $mod.i;',
|
|
' }',
|
|
'} finally {',
|
|
' $in1 = rtl.freeLoc($in1)',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_Create;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' constructor Create;');
|
|
Add(' end;');
|
|
Add(' TClass = class of TObject;');
|
|
Add('constructor tobject.create; begin end;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add(' C: tclass;');
|
|
Add('begin');
|
|
Add(' obj:=C.create;');
|
|
Add(' with c do obj:=create;');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_Create',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.C = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj = $mod.C.$create("Create");',
|
|
'var $with1 = $mod.C;',
|
|
'$mod.Obj = $with1.$create("Create");',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_Call;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' class procedure DoIt;');
|
|
Add(' end;');
|
|
Add(' TClass = class of TObject;');
|
|
Add('class procedure tobject.doit; begin end;');
|
|
Add('var');
|
|
Add(' C: tclass;');
|
|
Add('begin');
|
|
Add(' c.doit;');
|
|
Add(' with c do doit;');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_Call',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' };',
|
|
'});',
|
|
'this.C = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.C.DoIt();',
|
|
'var $with1 = $mod.C;',
|
|
'$with1.DoIt();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_Assign;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TClass = class of TObject;');
|
|
Add(' TObject = class');
|
|
Add(' ClassType: TClass; ');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add(' C: tclass;');
|
|
Add('begin');
|
|
Add(' c:=nil;');
|
|
Add(' c:=obj.classtype;');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_Assign',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.ClassType = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.ClassType = undefined;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.C = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.C = null;',
|
|
'$mod.C = $mod.Obj.ClassType;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_Is;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TClass = class of TObject;');
|
|
Add(' TObject = class');
|
|
Add(' end;');
|
|
Add(' TCar = class');
|
|
Add(' end;');
|
|
Add(' TCars = class of TCar;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add(' C: tclass;');
|
|
Add(' Cars: tcars;');
|
|
Add('begin');
|
|
Add(' if c is tcar then ;');
|
|
Add(' if c is tcars then ;');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_Is',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.C = null;',
|
|
'this.Cars = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'if(rtl.is($mod.C,$mod.TCar));',
|
|
'if(rtl.is($mod.C,$mod.TCar));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_Compare;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TClass = class of TObject;');
|
|
Add(' TObject = class');
|
|
Add(' ClassType: TClass; ');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' b: boolean;');
|
|
Add(' Obj: tobject;');
|
|
Add(' C: tclass;');
|
|
Add('begin');
|
|
Add(' b:=c=nil;');
|
|
Add(' b:=nil=c;');
|
|
Add(' b:=c=obj.classtype;');
|
|
Add(' b:=obj.classtype=c;');
|
|
Add(' b:=c=TObject;');
|
|
Add(' b:=TObject=c;');
|
|
Add(' b:=c<>nil;');
|
|
Add(' b:=nil<>c;');
|
|
Add(' b:=c<>obj.classtype;');
|
|
Add(' b:=obj.classtype<>c;');
|
|
Add(' b:=c<>TObject;');
|
|
Add(' b:=TObject<>c;');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_Compare',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.ClassType = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.ClassType = undefined;',
|
|
' };',
|
|
'});',
|
|
'this.b = false;',
|
|
'this.Obj = null;',
|
|
'this.C = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.b = $mod.C === null;',
|
|
'$mod.b = null === $mod.C;',
|
|
'$mod.b = $mod.C === $mod.Obj.ClassType;',
|
|
'$mod.b = $mod.Obj.ClassType === $mod.C;',
|
|
'$mod.b = $mod.C === $mod.TObject;',
|
|
'$mod.b = $mod.TObject === $mod.C;',
|
|
'$mod.b = $mod.C !== null;',
|
|
'$mod.b = null !== $mod.C;',
|
|
'$mod.b = $mod.C !== $mod.Obj.ClassType;',
|
|
'$mod.b = $mod.Obj.ClassType !== $mod.C;',
|
|
'$mod.b = $mod.C !== $mod.TObject;',
|
|
'$mod.b = $mod.TObject !== $mod.C;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_ClassVar;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' class var id: longint;');
|
|
Add(' end;');
|
|
Add(' TClass = class of TObject;');
|
|
Add('var');
|
|
Add(' C: tclass;');
|
|
Add('begin');
|
|
Add(' C.id:=C.id;');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_ClassVar',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.id = 0;',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.C = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.TObject.id = $mod.C.id;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_ClassMethod;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' class function DoIt(i: longint = 0): longint;');
|
|
Add(' end;');
|
|
Add(' TClass = class of TObject;');
|
|
Add('class function tobject.doit(i: longint = 0): longint; begin end;');
|
|
Add('var');
|
|
Add(' i: longint;');
|
|
Add(' C: tclass;');
|
|
Add('begin');
|
|
Add(' C.DoIt;');
|
|
Add(' C.DoIt();');
|
|
Add(' i:=C.DoIt;');
|
|
Add(' i:=C.DoIt();');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_ClassMethod',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (i) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.i = 0;',
|
|
'this.C = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.C.DoIt(0);',
|
|
'$mod.C.DoIt(0);',
|
|
'$mod.i = $mod.C.DoIt(0);',
|
|
'$mod.i = $mod.C.DoIt(0);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_ClassProperty;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' class var FA: longint;');
|
|
Add(' class function GetA: longint;');
|
|
Add(' class procedure SetA(Value: longint);');
|
|
Add(' class property pA: longint read fa write fa;');
|
|
Add(' class property pB: longint read geta write seta;');
|
|
Add(' end;');
|
|
Add(' TObjectClass = class of tobject;');
|
|
Add('class function tobject.geta: longint; begin end;');
|
|
Add('class procedure tobject.seta(value: longint); begin end;');
|
|
Add('var');
|
|
Add(' b: boolean;');
|
|
Add(' Obj: tobject;');
|
|
Add(' Cla: tobjectclass;');
|
|
Add('begin');
|
|
Add(' obj.pa:=obj.pa;');
|
|
Add(' obj.pb:=obj.pb;');
|
|
Add(' b:=obj.pa=4;');
|
|
Add(' b:=obj.pb=obj.pb;');
|
|
Add(' b:=5=obj.pa;');
|
|
Add(' cla.pa:=6;');
|
|
Add(' cla.pa:=cla.pa;');
|
|
Add(' cla.pb:=cla.pb;');
|
|
Add(' b:=cla.pa=7;');
|
|
Add(' b:=cla.pb=cla.pb;');
|
|
Add(' b:=8=cla.pa;');
|
|
Add(' tobject.pa:=9;');
|
|
Add(' tobject.pb:=tobject.pb;');
|
|
Add(' b:=tobject.pa=10;');
|
|
Add(' b:=11=tobject.pa;');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_ClassProperty',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.FA = 0;',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.GetA = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetA = function (Value) {',
|
|
' };',
|
|
'});',
|
|
'this.b = false;',
|
|
'this.Obj = null;',
|
|
'this.Cla = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj.$class.FA = $mod.Obj.FA;',
|
|
'$mod.Obj.$class.SetA($mod.Obj.$class.GetA());',
|
|
'$mod.b = $mod.Obj.FA === 4;',
|
|
'$mod.b = $mod.Obj.$class.GetA() === $mod.Obj.$class.GetA();',
|
|
'$mod.b = 5 === $mod.Obj.FA;',
|
|
'$mod.Cla.FA = 6;',
|
|
'$mod.Cla.FA = $mod.Cla.FA;',
|
|
'$mod.Cla.SetA($mod.Cla.GetA());',
|
|
'$mod.b = $mod.Cla.FA === 7;',
|
|
'$mod.b = $mod.Cla.GetA() === $mod.Cla.GetA();',
|
|
'$mod.b = 8 === $mod.Cla.FA;',
|
|
'$mod.TObject.FA = 9;',
|
|
'$mod.TObject.SetA($mod.TObject.GetA());',
|
|
'$mod.b = $mod.TObject.FA === 10;',
|
|
'$mod.b = 11 === $mod.TObject.FA;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_ClassMethodSelf;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' class var GlobalId: longint;');
|
|
Add(' class procedure ProcA;');
|
|
Add(' end;');
|
|
Add('class procedure tobject.proca;');
|
|
Add('var b: boolean;');
|
|
Add('begin');
|
|
Add(' b:=self=nil;');
|
|
Add(' b:=self.globalid=3;');
|
|
Add(' b:=4=self.globalid;');
|
|
Add(' self.globalid:=5;');
|
|
Add(' self.proca;');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_ClassMethodSelf',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.GlobalId = 0;',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.ProcA = function () {',
|
|
' var b = false;',
|
|
' b = this === null;',
|
|
' b = this.GlobalId === 3;',
|
|
' b = 4 === this.GlobalId;',
|
|
' $mod.TObject.GlobalId = 5;',
|
|
' this.ProcA();',
|
|
' };',
|
|
'});'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_TypeCast;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' class procedure {#TObject_DoIt}DoIt;');
|
|
Add(' end;');
|
|
Add(' TClass = class of TObject;');
|
|
Add(' TMobile = class');
|
|
Add(' class procedure {#TMobile_DoIt}DoIt;');
|
|
Add(' end;');
|
|
Add(' TMobileClass = class of TMobile;');
|
|
Add(' TCar = class(TMobile)');
|
|
Add(' class procedure {#TCar_DoIt}DoIt;');
|
|
Add(' end;');
|
|
Add(' TCarClass = class of TCar;');
|
|
Add('class procedure TObject.DoIt;');
|
|
Add('begin');
|
|
Add(' TClass(Self).{@TObject_DoIt}DoIt;');
|
|
Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
|
|
Add('end;');
|
|
Add('class procedure TMobile.DoIt;');
|
|
Add('begin');
|
|
Add(' TClass(Self).{@TObject_DoIt}DoIt;');
|
|
Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
|
|
Add(' TCarClass(Self).{@TCar_DoIt}DoIt;');
|
|
Add('end;');
|
|
Add('class procedure TCar.DoIt; begin end;');
|
|
Add('var');
|
|
Add(' ObjC: TClass;');
|
|
Add(' MobileC: TMobileClass;');
|
|
Add(' CarC: TCarClass;');
|
|
Add('begin');
|
|
Add(' ObjC.{@TObject_DoIt}DoIt;');
|
|
Add(' MobileC.{@TMobile_DoIt}DoIt;');
|
|
Add(' CarC.{@TCar_DoIt}DoIt;');
|
|
Add(' TClass(ObjC).{@TObject_DoIt}DoIt;');
|
|
Add(' TMobileClass(ObjC).{@TMobile_DoIt}DoIt;');
|
|
Add(' TCarClass(ObjC).{@TCar_DoIt}DoIt;');
|
|
Add(' TClass(MobileC).{@TObject_DoIt}DoIt;');
|
|
Add(' TMobileClass(MobileC).{@TMobile_DoIt}DoIt;');
|
|
Add(' TCarClass(MobileC).{@TCar_DoIt}DoIt;');
|
|
Add(' TClass(CarC).{@TObject_DoIt}DoIt;');
|
|
Add(' TMobileClass(CarC).{@TMobile_DoIt}DoIt;');
|
|
Add(' TCarClass(CarC).{@TCar_DoIt}DoIt;');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_TypeCast',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' this.DoIt();',
|
|
' this.DoIt$1();',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
|
|
' this.DoIt$1 = function () {',
|
|
' this.DoIt();',
|
|
' this.DoIt$1();',
|
|
' this.DoIt$2();',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
|
|
' this.DoIt$2 = function () {',
|
|
' };',
|
|
'});',
|
|
'this.ObjC = null;',
|
|
'this.MobileC = null;',
|
|
'this.CarC = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.ObjC.DoIt();',
|
|
'$mod.MobileC.DoIt$1();',
|
|
'$mod.CarC.DoIt$2();',
|
|
'$mod.ObjC.DoIt();',
|
|
'$mod.ObjC.DoIt$1();',
|
|
'$mod.ObjC.DoIt$2();',
|
|
'$mod.MobileC.DoIt();',
|
|
'$mod.MobileC.DoIt$1();',
|
|
'$mod.MobileC.DoIt$2();',
|
|
'$mod.CarC.DoIt();',
|
|
'$mod.CarC.DoIt$1();',
|
|
'$mod.CarC.DoIt$2();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_ImplicitFunctionCall;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' function CurNow: longint; ');
|
|
Add(' class function Now: longint; ');
|
|
Add(' end;');
|
|
Add('function TObject.CurNow: longint; begin end;');
|
|
Add('class function TObject.Now: longint; begin end;');
|
|
Add('var');
|
|
Add(' Obj: tobject;');
|
|
Add(' vI: longint;');
|
|
Add('begin');
|
|
Add(' obj.curnow;');
|
|
Add(' vi:=obj.curnow;');
|
|
Add(' tobject.now;');
|
|
Add(' vi:=tobject.now;');
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_ImplicitFunctionCall',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.CurNow = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
' this.Now = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.vI = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj.CurNow();',
|
|
'$mod.vI = $mod.Obj.CurNow();',
|
|
'$mod.TObject.Now();',
|
|
'$mod.vI = $mod.TObject.Now();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassOf_Const;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = TObject;',
|
|
' TBirds = class of TBird;',
|
|
' TEagles = TBirds;',
|
|
' THawk = class(TBird);',
|
|
'const',
|
|
' Hawk: TEagles = THawk;',
|
|
' DefaultBirdClasses : Array [1..2] of TEagles = (',
|
|
' TBird,',
|
|
' THawk',
|
|
' );',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassOf_Const',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "THawk", $mod.TObject, function () {',
|
|
'});',
|
|
'this.Hawk = $mod.THawk;',
|
|
'this.DefaultBirdClasses = [$mod.TObject, $mod.THawk];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestNestedClass_Alias;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' type TNested = type longint;',
|
|
' end;',
|
|
'type TAlias = type tobject.tnested;',
|
|
'var i: tobject.tnested = 3;',
|
|
'var j: TAlias = 4;',
|
|
'begin',
|
|
' if typeinfo(TAlias)=nil then ;',
|
|
' if typeinfo(tobject.tnested)=nil then ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestNestedClass_Alias',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' $mod.$rtti.$inherited("TObject.TNested", rtl.longint, {});',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'$mod.$rtti.$inherited("TAlias", $mod.$rtti["TObject.TNested"], {});',
|
|
'this.i = 3;',
|
|
'this.j = 4;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'if ($mod.$rtti["TAlias"] === null) ;',
|
|
'if ($mod.$rtti["TObject.TNested"] === null) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestNestedClass_Record;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' type TPoint = record',
|
|
' x,y: byte;',
|
|
' end;',
|
|
' procedure DoIt(t: TPoint);',
|
|
' end;',
|
|
'procedure tobject.DoIt(t: TPoint);',
|
|
'var p: TPoint;',
|
|
'begin',
|
|
' t.x:=t.y;',
|
|
' p:=t;',
|
|
'end;',
|
|
'var',
|
|
' p: tobject.tpoint = (x:2; y:4);',
|
|
' o: TObject;',
|
|
'begin',
|
|
' p:=p;',
|
|
' o.doit(p);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestNestedClass_Record',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.TPoint = function (s) {',
|
|
' if (s) {',
|
|
' this.x = s.x;',
|
|
' this.y = s.y;',
|
|
' } else {',
|
|
' this.x = 0;',
|
|
' this.y = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.x === b.x) && (this.y === b.y);',
|
|
' };',
|
|
' };',
|
|
' $mod.$rtti.$Record("TObject.TPoint", {}).addFields("x", rtl.byte, "y", rtl.byte);',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (t) {',
|
|
' var p = new this.TPoint();',
|
|
' t.x = t.y;',
|
|
' p = new this.TPoint(t);',
|
|
' };',
|
|
'});',
|
|
'this.p = new $mod.TObject.TPoint({',
|
|
' x: 2,',
|
|
' y: 4',
|
|
'});',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = new $mod.TObject.TPoint($mod.p);',
|
|
'$mod.o.DoIt(new $mod.TObject.TPoint($mod.p));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestNestedClass_Class;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class end;',
|
|
' TBird = class',
|
|
' type TLeg = class',
|
|
' FId: longint;',
|
|
' constructor Create;',
|
|
' function Create(i: longint): TLeg;',
|
|
' end;',
|
|
' function DoIt(b: TBird): Tleg;',
|
|
' end;',
|
|
'constructor tbird.tleg.create;',
|
|
'begin',
|
|
' FId:=3;',
|
|
'end;',
|
|
'function tbird.tleg.Create(i: longint): TLeg;',
|
|
'begin',
|
|
' Create;',
|
|
' Result:=TLeg.Create;',
|
|
' Result:=TBird.TLeg.Create;',
|
|
' Result:=Create(3);',
|
|
' FId:=i;',
|
|
'end;',
|
|
'function tbird.DoIt(b: tbird): tleg;',
|
|
'begin',
|
|
' Result.Create;',
|
|
' Result:=TLeg.Create;',
|
|
' Result:=TBird.TLeg.Create;',
|
|
' Result:=Result.Create(3);',
|
|
'end;',
|
|
'var',
|
|
' b: Tbird.tleg;',
|
|
'begin',
|
|
' b.Create;',
|
|
' b:=TBird.TLeg.Create;',
|
|
' b:=b.Create(3);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestNestedClass_Class',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' rtl.createClass(this, "TLeg", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.FId = 0;',
|
|
' };',
|
|
' this.Create = function () {',
|
|
' this.FId = 3;',
|
|
' };',
|
|
' this.Create$1 = function (i) {',
|
|
' var Result = null;',
|
|
' this.Create();',
|
|
' Result = $mod.TBird.TLeg.$create("Create");',
|
|
' Result = $mod.TBird.TLeg.$create("Create");',
|
|
' Result = this.Create$1(3);',
|
|
' this.FId = i;',
|
|
' return Result;',
|
|
' };',
|
|
' });',
|
|
' this.DoIt = function (b) {',
|
|
' var Result = null;',
|
|
' Result.Create();',
|
|
' Result = this.TLeg.$create("Create");',
|
|
' Result = $mod.TBird.TLeg.$create("Create");',
|
|
' Result = Result.Create$1(3);',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.b = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.b.Create();',
|
|
'$mod.b = $mod.TBird.TLeg.$create("Create");',
|
|
'$mod.b = $mod.b.Create$1(3);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_Var;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TExtA = class external name ''ExtObj''',
|
|
' Id: longint external name ''$Id'';',
|
|
' B: longint;',
|
|
' end;',
|
|
'var Obj: TExtA;',
|
|
'begin',
|
|
' obj.id:=obj.id+1;',
|
|
' obj.B:=obj.B+1;']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_Var',
|
|
LinesToStr([ // statements
|
|
'this.Obj = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj.$Id = $mod.Obj.$Id + 1;',
|
|
'$mod.Obj.B = $mod.Obj.B + 1;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_Const;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TExtA = class external name ''ExtObj''',
|
|
' const Two: longint = 2;',
|
|
' const Three = 3;',
|
|
' const Id: longint;',
|
|
' end;',
|
|
' TExtB = class external name ''ExtB''',
|
|
' A: TExtA;',
|
|
' end;',
|
|
'var',
|
|
' A: texta;',
|
|
' B: textb;',
|
|
' i: longint;',
|
|
'begin',
|
|
' i:=a.two;',
|
|
' i:=texta.two;',
|
|
' i:=a.three;',
|
|
' i:=texta.three;',
|
|
' i:=a.id;',
|
|
' i:=texta.id;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_Const',
|
|
LinesToStr([ // statements
|
|
'this.A = null;',
|
|
'this.B = null;',
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.i = 2;',
|
|
'$mod.i = 2;',
|
|
'$mod.i = 3;',
|
|
'$mod.i = 3;',
|
|
'$mod.i = $mod.A.Id;',
|
|
'$mod.i = ExtObj.Id;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_Dollar;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TExtA = class external name ''$''',
|
|
' Id: longint external name ''$'';',
|
|
' function Bla(i: longint): longint; external name ''$'';',
|
|
' end;',
|
|
'function dollar(k: longint): longint; external name ''$'';',
|
|
'var Obj: TExtA;',
|
|
'begin',
|
|
' dollar(1);',
|
|
' obj.id:=obj.id+2;',
|
|
' obj.Bla(3);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_Dollar',
|
|
LinesToStr([ // statements
|
|
'this.Obj = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$(1);',
|
|
'$mod.Obj.$ = $mod.Obj.$ + 2;',
|
|
'$mod.Obj.$(3);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_DuplicateVarFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' Id: longint external name ''$Id'';');
|
|
Add(' end;');
|
|
Add(' TExtB = class external ''lib'' name ''ExtB''(TExtA)');
|
|
Add(' Id: longint;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError('Duplicate identifier "Id" at test1.pp(6,5)',nDuplicateIdentifier);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_Method;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtObj''');
|
|
Add(' procedure DoIt(Id: longint = 1); external name ''$Execute'';');
|
|
Add(' procedure DoSome(Id: longint = 1);');
|
|
Add(' end;');
|
|
Add('var Obj: texta;');
|
|
Add('begin');
|
|
Add(' obj.doit;');
|
|
Add(' obj.doit();');
|
|
Add(' obj.doit(2);');
|
|
Add(' with obj do begin');
|
|
Add(' doit;');
|
|
Add(' doit();');
|
|
Add(' doit(3);');
|
|
Add(' end;');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_Method',
|
|
LinesToStr([ // statements
|
|
'this.Obj = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj.$Execute(1);',
|
|
'$mod.Obj.$Execute(1);',
|
|
'$mod.Obj.$Execute(2);',
|
|
'var $with1 = $mod.Obj;',
|
|
'$with1.$Execute(1);',
|
|
'$with1.$Execute(1);',
|
|
'$with1.$Execute(3);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_ClassMethod;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TExtA = class external name ''ExtObj''',
|
|
' class procedure DoIt(Id: longint = 1); external name ''$Execute'';',
|
|
' end;',
|
|
' TExtB = TExtA;',
|
|
'begin',
|
|
' texta.doit;',
|
|
' texta.doit();',
|
|
' texta.doit(2);',
|
|
' with texta do begin',
|
|
' doit;',
|
|
' doit();',
|
|
' doit(3);',
|
|
' end;',
|
|
' textb.doit;',
|
|
' textb.doit();',
|
|
' textb.doit(4);',
|
|
' with textb do begin',
|
|
' doit;',
|
|
' doit();',
|
|
' doit(5);',
|
|
' end;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_ClassMethod',
|
|
LinesToStr([ // statements
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'ExtObj.$Execute(1);',
|
|
'ExtObj.$Execute(1);',
|
|
'ExtObj.$Execute(2);',
|
|
'ExtObj.$Execute(1);',
|
|
'ExtObj.$Execute(1);',
|
|
'ExtObj.$Execute(3);',
|
|
'ExtObj.$Execute(1);',
|
|
'ExtObj.$Execute(1);',
|
|
'ExtObj.$Execute(4);',
|
|
'ExtObj.$Execute(1);',
|
|
'ExtObj.$Execute(1);',
|
|
'ExtObj.$Execute(5);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_FunctionResultInTypeCast;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TBird = class external name ''Array''',
|
|
' end;',
|
|
'function GetPtr: Pointer;',
|
|
'begin',
|
|
'end;',
|
|
'procedure Write(const p);',
|
|
'begin',
|
|
'end;',
|
|
'procedure WriteLn; varargs;',
|
|
'begin',
|
|
'end;',
|
|
'begin',
|
|
' if TBird(GetPtr)=nil then ;',
|
|
' Write(GetPtr);',
|
|
' WriteLn(GetPtr);',
|
|
' Write(TBird(GetPtr));',
|
|
' WriteLn(TBird(GetPtr));',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestFunctionResultInTypeCast',
|
|
LinesToStr([ // statements
|
|
'this.GetPtr = function () {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
'};',
|
|
'this.Write = function (p) {',
|
|
'};',
|
|
'this.WriteLn = function () {',
|
|
'};',
|
|
'']),
|
|
LinesToStr([
|
|
'if ($mod.GetPtr() === null) ;',
|
|
'$mod.Write($mod.GetPtr());',
|
|
'$mod.WriteLn($mod.GetPtr());',
|
|
'$mod.Write($mod.GetPtr());',
|
|
'$mod.WriteLn($mod.GetPtr());',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_NonExternalOverride;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtObjA''');
|
|
Add(' procedure ProcA; virtual;');
|
|
Add(' procedure ProcB; virtual;');
|
|
Add(' end;');
|
|
Add(' TExtB = class external name ''ExtObjB'' (TExtA)');
|
|
Add(' end;');
|
|
Add(' TExtC = class (TExtB)');
|
|
Add(' procedure ProcA; override;');
|
|
Add(' end;');
|
|
Add('procedure TExtC.ProcA;');
|
|
Add('begin');
|
|
Add(' ProcA;');
|
|
Add(' Self.ProcA;');
|
|
Add(' ProcB;');
|
|
Add(' Self.ProcB;');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' A: texta;');
|
|
Add(' B: textb;');
|
|
Add(' C: textc;');
|
|
Add('begin');
|
|
Add(' a.proca;');
|
|
Add(' b.proca;');
|
|
Add(' c.proca;');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_NonExternalOverride',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TExtC", ExtObjB, "", function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.ProcA = function () {',
|
|
' this.ProcA();',
|
|
' this.ProcA();',
|
|
' this.ProcB();',
|
|
' this.ProcB();',
|
|
' };',
|
|
'});',
|
|
'this.A = null;',
|
|
'this.B = null;',
|
|
'this.C = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.A.ProcA();',
|
|
'$mod.B.ProcA();',
|
|
'$mod.C.ProcA();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_OverloadHint;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TExtA = class external name ''ExtObjA''',
|
|
' procedure DoIt;',
|
|
' procedure DoIt(i: longint);',
|
|
' end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckResolverUnexpectedHints(true);
|
|
CheckSource('TestExternalClass_OverloadHint',
|
|
LinesToStr([ // statements
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_Property;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' function getYear: longint;');
|
|
Add(' procedure setYear(Value: longint);');
|
|
Add(' property Year: longint read getyear write setyear;');
|
|
Add(' end;');
|
|
Add(' TExtB = class (TExtA)');
|
|
Add(' procedure OtherSetYear(Value: longint);');
|
|
Add(' property year write othersetyear;');
|
|
Add(' end;');
|
|
Add('procedure textb.othersetyear(value: longint);');
|
|
Add('begin');
|
|
Add(' setYear(Value+4);');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' A: texta;');
|
|
Add(' B: textb;');
|
|
Add('begin');
|
|
Add(' a.year:=a.year+1;');
|
|
Add(' b.year:=b.year+2;');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_NonExternalOverride',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.OtherSetYear = function (Value) {',
|
|
' this.setYear(Value+4);',
|
|
' };',
|
|
'});',
|
|
'this.A = null;',
|
|
'this.B = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.A.setYear($mod.A.getYear()+1);',
|
|
'$mod.B.OtherSetYear($mod.B.getYear()+2);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_ClassProperty;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' class function getYear: longint;');
|
|
Add(' class procedure setYear(Value: longint);');
|
|
Add(' class property Year: longint read getyear write setyear;');
|
|
Add(' end;');
|
|
Add(' TExtB = class (TExtA)');
|
|
Add(' class function GetCentury: longint;');
|
|
Add(' class procedure SetCentury(Value: longint);');
|
|
Add(' class property Century: longint read getcentury write setcentury;');
|
|
Add(' end;');
|
|
Add('class function textb.getcentury: longint;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('class procedure textb.setcentury(value: longint);');
|
|
Add('begin');
|
|
Add(' setyear(value+11);');
|
|
Add(' texta.year:=texta.year+12;');
|
|
Add(' year:=year+13;');
|
|
Add(' textb.century:=textb.century+14;');
|
|
Add(' century:=century+15;');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' A: texta;');
|
|
Add(' B: textb;');
|
|
Add('begin');
|
|
Add(' texta.year:=texta.year+1;');
|
|
Add(' textb.year:=textb.year+2;');
|
|
Add(' TextA.year:=TextA.year+3;');
|
|
Add(' b.year:=b.year+4;');
|
|
Add(' textb.century:=textb.century+5;');
|
|
Add(' b.century:=b.century+6;');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_ClassProperty',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.GetCentury = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetCentury = function (Value) {',
|
|
' this.setYear(Value + 11);',
|
|
' ExtA.setYear(ExtA.getYear() + 12);',
|
|
' this.setYear(this.getYear() + 13);',
|
|
' $mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 14);',
|
|
' this.SetCentury(this.GetCentury() + 15);',
|
|
' };',
|
|
'});',
|
|
'this.A = null;',
|
|
'this.B = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'ExtA.setYear(ExtA.getYear() + 1);',
|
|
'$mod.TExtB.setYear($mod.TExtB.getYear() + 2);',
|
|
'ExtA.setYear(ExtA.getYear() + 3);',
|
|
'$mod.B.setYear($mod.B.getYear() + 4);',
|
|
'$mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 5);',
|
|
'$mod.B.$class.SetCentury($mod.B.$class.GetCentury() + 6);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_ClassOf;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' procedure ProcA; virtual;');
|
|
Add(' procedure ProcB; virtual;');
|
|
Add(' end;');
|
|
Add(' TExtAClass = class of TExtA;');
|
|
Add(' TExtB = class external name ''ExtB'' (TExtA)');
|
|
Add(' end;');
|
|
Add(' TExtBClass = class of TExtB;');
|
|
Add(' TExtC = class (TExtB)');
|
|
Add(' procedure ProcA; override;');
|
|
Add(' end;');
|
|
Add(' TExtCClass = class of TExtC;');
|
|
Add('procedure TExtC.ProcA; begin end;');
|
|
Add('var');
|
|
Add(' A: texta; ClA: TExtAClass;');
|
|
Add(' B: textb; ClB: TExtBClass;');
|
|
Add(' C: textc; ClC: TExtCClass;');
|
|
Add('begin');
|
|
Add(' ClA:=texta;');
|
|
Add(' ClA:=textb;');
|
|
Add(' ClA:=textc;');
|
|
Add(' ClB:=textb;');
|
|
Add(' ClB:=textc;');
|
|
Add(' ClC:=textc;');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_ClassOf',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.ProcA = function () {',
|
|
' };',
|
|
'});',
|
|
'this.A = null;',
|
|
'this.ClA = null;',
|
|
'this.B = null;',
|
|
'this.ClB = null;',
|
|
'this.C = null;',
|
|
'this.ClC = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.ClA = ExtA;',
|
|
'$mod.ClA = ExtB;',
|
|
'$mod.ClA = $mod.TExtC;',
|
|
'$mod.ClB = ExtB;',
|
|
'$mod.ClB = $mod.TExtC;',
|
|
'$mod.ClC = $mod.TExtC;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_ClassOtherUnit;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit2.pas',
|
|
LinesToStr([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TExtA = class external name ''ExtA''',
|
|
' class var Id: longint;',
|
|
' end;',
|
|
'']),
|
|
'');
|
|
|
|
StartUnit(true);
|
|
Add('interface');
|
|
Add('uses unit2;');
|
|
Add('implementation');
|
|
Add('begin');
|
|
Add(' unit2.texta.id:=unit2.texta.id+1;');
|
|
ConvertUnit;
|
|
CheckSource('TestExternalClass_ClassOtherUnit',
|
|
LinesToStr([
|
|
'']),
|
|
LinesToStr([
|
|
'ExtA.Id = ExtA.Id + 1;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_Is;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' end;');
|
|
Add(' TExtAClass = class of TExtA;');
|
|
Add(' TExtB = class external name ''ExtB'' (TExtA)');
|
|
Add(' end;');
|
|
Add(' TExtBClass = class of TExtB;');
|
|
Add(' TExtC = class (TExtB)');
|
|
Add(' end;');
|
|
Add(' TExtCClass = class of TExtC;');
|
|
Add('var');
|
|
Add(' A: texta; ClA: TExtAClass;');
|
|
Add(' B: textb; ClB: TExtBClass;');
|
|
Add(' C: textc; ClC: TExtCClass;');
|
|
Add('begin');
|
|
Add(' if a is textb then ;');
|
|
Add(' if a is textc then ;');
|
|
Add(' if b is textc then ;');
|
|
Add(' if cla is textb then ;');
|
|
Add(' if cla is textc then ;');
|
|
Add(' if clb is textc then ;');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_Is',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.A = null;',
|
|
'this.ClA = null;',
|
|
'this.B = null;',
|
|
'this.ClB = null;',
|
|
'this.C = null;',
|
|
'this.ClC = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'if (rtl.isExt($mod.A, ExtB)) ;',
|
|
'if ($mod.TExtC.isPrototypeOf($mod.A)) ;',
|
|
'if ($mod.TExtC.isPrototypeOf($mod.B)) ;',
|
|
'if (rtl.isExt($mod.ClA, ExtB)) ;',
|
|
'if (rtl.is($mod.ClA, $mod.TExtC)) ;',
|
|
'if (rtl.is($mod.ClB, $mod.TExtC)) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_As;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' end;');
|
|
Add(' TExtB = class external name ''ExtB'' (TExtA)');
|
|
Add(' end;');
|
|
Add(' TExtC = class (TExtB)');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' A: texta;');
|
|
Add(' B: textb;');
|
|
Add(' C: textc;');
|
|
Add('begin');
|
|
Add(' b:=a as textb;');
|
|
Add(' c:=a as textc;');
|
|
Add(' c:=b as textc;');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_Is',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.A = null;',
|
|
'this.B = null;',
|
|
'this.C = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.B = rtl.asExt($mod.A, ExtB);',
|
|
'$mod.C = rtl.as($mod.A, $mod.TExtC);',
|
|
'$mod.C = rtl.as($mod.B, $mod.TExtC);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_DestructorFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' destructor Free;');
|
|
Add(' end;');
|
|
SetExpectedPasResolverError('Pascal element not supported: destructor',
|
|
nPasElementNotSupported);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_New;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' constructor New;');
|
|
Add(' constructor New(i: longint; j: longint = 2);');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' A: texta;');
|
|
Add('begin');
|
|
Add(' a:=texta.new;');
|
|
Add(' a:=texta.new();');
|
|
Add(' a:=texta.new(1);');
|
|
Add(' with texta do begin');
|
|
Add(' a:=new;');
|
|
Add(' a:=new();');
|
|
Add(' a:=new(2);');
|
|
Add(' end;');
|
|
Add(' a:=test1.texta.new;');
|
|
Add(' a:=test1.texta.new();');
|
|
Add(' a:=test1.texta.new(3);');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_New',
|
|
LinesToStr([ // statements
|
|
'this.A = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.A = new ExtA();',
|
|
'$mod.A = new ExtA();',
|
|
'$mod.A = new ExtA(1,2);',
|
|
'$mod.A = new ExtA();',
|
|
'$mod.A = new ExtA();',
|
|
'$mod.A = new ExtA(2,2);',
|
|
'$mod.A = new ExtA();',
|
|
'$mod.A = new ExtA();',
|
|
'$mod.A = new ExtA(3,2);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_ClassOf_New;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtAClass = class of TExtA;');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' constructor New;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' A: texta;');
|
|
Add(' C: textaclass;');
|
|
Add('begin');
|
|
Add(' a:=c.new;');
|
|
Add(' a:=c.new();');
|
|
Add(' with C do begin');
|
|
Add(' a:=new;');
|
|
Add(' a:=new();');
|
|
Add(' end;');
|
|
Add(' a:=test1.c.new;');
|
|
Add(' a:=test1.c.new();');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_ClassOf_New',
|
|
LinesToStr([ // statements
|
|
'this.A = null;',
|
|
'this.C = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.A = new $mod.C();',
|
|
'$mod.A = new $mod.C();',
|
|
'var $with1 = $mod.C;',
|
|
'$mod.A = new $with1();',
|
|
'$mod.A = new $with1();',
|
|
'$mod.A = new $mod.C();',
|
|
'$mod.A = new $mod.C();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_FuncClassOf_New;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TExtAClass = class of TExtA;',
|
|
' TExtA = class external name ''ExtA''',
|
|
' constructor New;',
|
|
' end;',
|
|
'function GetCreator: TExtAClass;',
|
|
'begin',
|
|
' Result:=TExtA;',
|
|
'end;',
|
|
'var',
|
|
' A: texta;',
|
|
'begin',
|
|
' a:=getcreator.new;',
|
|
' a:=getcreator().new;',
|
|
' a:=getcreator().new();',
|
|
' a:=getcreator.new();',
|
|
' with getcreator do begin',
|
|
' a:=new;',
|
|
' a:=new();',
|
|
' end;']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_FuncClassOf_New',
|
|
LinesToStr([ // statements
|
|
'this.GetCreator = function () {',
|
|
' var Result = null;',
|
|
' Result = ExtA;',
|
|
' return Result;',
|
|
'};',
|
|
'this.A = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.A = new ($mod.GetCreator())();',
|
|
'$mod.A = new ($mod.GetCreator())();',
|
|
'$mod.A = new ($mod.GetCreator())();',
|
|
'$mod.A = new ($mod.GetCreator())();',
|
|
'var $with1 = $mod.GetCreator();',
|
|
'$mod.A = new $with1();',
|
|
'$mod.A = new $with1();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_New_PasClassFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TExtA = class external name ''ExtA''',
|
|
' constructor New;',
|
|
' end;',
|
|
' TBird = class(TExtA)',
|
|
' end;',
|
|
'begin',
|
|
' TBird.new;',
|
|
'']);
|
|
SetExpectedPasResolverError(sJSNewNotSupported,nJSNewNotSupported);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_New_PasClassBracketsFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TExtA = class external name ''ExtA''',
|
|
' constructor New;',
|
|
' end;',
|
|
' TBird = class(TExtA)',
|
|
' end;',
|
|
'begin',
|
|
' TBird.new();',
|
|
'']);
|
|
SetExpectedPasResolverError(sJSNewNotSupported,nJSNewNotSupported);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_LocalConstSameName;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' constructor New;');
|
|
Add(' end;');
|
|
Add('function DoIt: longint;');
|
|
Add('const ExtA: longint = 3;');
|
|
Add('begin');
|
|
Add(' Result:=ExtA;');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' A: texta;');
|
|
Add('begin');
|
|
Add(' a:=texta.new;');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_LocalConstSameName',
|
|
LinesToStr([ // statements
|
|
'var ExtA$1 = 3;',
|
|
'this.DoIt = function () {',
|
|
' var Result = 0;',
|
|
' Result = ExtA$1;',
|
|
' return Result;',
|
|
'};',
|
|
'this.A = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.A = new ExtA();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_ReintroduceOverload;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' procedure DoIt;');
|
|
Add(' end;');
|
|
Add(' TMyA = class(TExtA)');
|
|
Add(' procedure DoIt;');
|
|
Add(' end;');
|
|
Add('procedure TMyA.DoIt; begin end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_ReintroduceOverload',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TMyA", ExtA, "", function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt$1 = function () {',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_Inherited;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' procedure DoIt(i: longint = 1); virtual;');
|
|
Add(' procedure DoSome(j: longint = 2);');
|
|
Add(' end;');
|
|
Add(' TExtB = class external name ''ExtB''(TExtA)');
|
|
Add(' end;');
|
|
Add(' TMyC = class(TExtB)');
|
|
Add(' procedure DoIt(i: longint = 1); override;');
|
|
Add(' procedure DoSome(j: longint = 2); reintroduce;');
|
|
Add(' end;');
|
|
Add('procedure TMyC.DoIt(i: longint);');
|
|
Add('begin');
|
|
Add(' inherited;');
|
|
Add(' inherited DoIt;');
|
|
Add(' inherited DoIt();');
|
|
Add(' inherited DoIt(3);');
|
|
Add(' inherited DoSome;');
|
|
Add(' inherited DoSome();');
|
|
Add(' inherited DoSome(4);');
|
|
Add('end;');
|
|
Add('procedure TMyC.DoSome(j: longint);');
|
|
Add('begin');
|
|
Add(' inherited;');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_ReintroduceOverload',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TMyC", ExtB, "", function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (i) {',
|
|
' ExtB.DoIt.apply(this, arguments);',
|
|
' ExtB.DoIt.call(this, 1);',
|
|
' ExtB.DoIt.call(this, 1);',
|
|
' ExtB.DoIt.call(this, 3);',
|
|
' ExtB.DoSome.call(this, 2);',
|
|
' ExtB.DoSome.call(this, 2);',
|
|
' ExtB.DoSome.call(this, 4);',
|
|
' };',
|
|
' this.DoSome$1 = function (j) {',
|
|
' ExtB.DoSome.apply(this, arguments);',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_PascalAncestorFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' end;');
|
|
Add(' TExtA = class external name ''ExtA''(TObject)');
|
|
Add(' end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError('Ancestor "TObject" is not external',nAncestorIsNotExternal);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_NewInstance;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' end;');
|
|
Add(' TMyB = class(TExtA)');
|
|
Add(' protected');
|
|
Add(' class function NewInstance(fnname: string; const paramarray): TMyB; virtual;');
|
|
Add(' end;');
|
|
Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
|
|
Add('begin end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_NewInstance',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TMyB", ExtA, "NewInstance", function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.NewInstance = function (fnname, paramarray) {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_NewInstance_NonVirtualFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' end;');
|
|
Add(' TMyB = class(TExtA)');
|
|
Add(' protected');
|
|
Add(' class function NewInstance(fnname: string; const paramarray): TMyB;');
|
|
Add(' end;');
|
|
Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
|
|
Add('begin end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError(sNewInstanceFunctionMustBeVirtual,nNewInstanceFunctionMustBeVirtual);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_NewInstance_FirstParamNotString_Fail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' end;');
|
|
Add(' TMyB = class(TExtA)');
|
|
Add(' protected');
|
|
Add(' class function NewInstance(fnname: longint; const paramarray): TMyB; virtual;');
|
|
Add(' end;');
|
|
Add('class function TMyB.NewInstance(fnname: longint; const paramarray): TMyB;');
|
|
Add('begin end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Longint", expected "String"',
|
|
nIncompatibleTypeArgNo);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_NewInstance_SecondParamTyped_Fail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TExtA = class external name ''ExtA''');
|
|
Add(' end;');
|
|
Add(' TMyB = class(TExtA)');
|
|
Add(' protected');
|
|
Add(' class function NewInstance(fnname: string; const paramarray: string): TMyB; virtual;');
|
|
Add(' end;');
|
|
Add('class function TMyB.NewInstance(fnname: string; const paramarray: string): TMyB;');
|
|
Add('begin end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError('Incompatible type arg no. 2: Got "type", expected "untyped"',
|
|
nIncompatibleTypeArgNo);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_PascalProperty;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TJSElement = class;');
|
|
Add(' TJSNotifyEvent = procedure(Sender: TJSElement) of object;');
|
|
Add(' TJSElement = class external name ''ExtA''');
|
|
Add(' end;');
|
|
Add(' TControl = class(TJSElement)');
|
|
Add(' private');
|
|
Add(' FOnClick: TJSNotifyEvent;');
|
|
Add(' property OnClick: TJSNotifyEvent read FOnClick write FOnClick;');
|
|
Add(' procedure Click(Sender: TJSElement);');
|
|
Add(' end;');
|
|
Add('procedure TControl.Click(Sender: TJSElement);');
|
|
Add('begin');
|
|
Add(' OnClick(Self);');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' Ctrl: TControl;');
|
|
Add('begin');
|
|
Add(' Ctrl.OnClick:=@Ctrl.Click;');
|
|
Add(' Ctrl.OnClick(Ctrl);');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_PascalProperty',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TControl", ExtA, "", function () {',
|
|
' this.$init = function () {',
|
|
' this.FOnClick = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FOnClick = undefined;',
|
|
' };',
|
|
' this.Click = function (Sender) {',
|
|
' this.FOnClick(this);',
|
|
' };',
|
|
'});',
|
|
'this.Ctrl = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Ctrl.FOnClick = rtl.createCallback($mod.Ctrl, "Click");',
|
|
'$mod.Ctrl.FOnClick($mod.Ctrl);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_TypeCastToRootClass;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' IUnknown = interface end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TChild = class',
|
|
' end;',
|
|
' TExtRootA = class external name ''ExtRootA''',
|
|
' end;',
|
|
' TExtChildA = class external name ''ExtChildA''(TExtRootA)',
|
|
' end;',
|
|
' TExtRootB = class external name ''ExtRootB''',
|
|
' end;',
|
|
' TExtChildB = class external name ''ExtChildB''(TExtRootB)',
|
|
' end;',
|
|
'var',
|
|
' Obj: TObject;',
|
|
' Child: TChild;',
|
|
' RootA: TExtRootA;',
|
|
' ChildA: TExtChildA;',
|
|
' RootB: TExtRootB;',
|
|
' ChildB: TExtChildB;',
|
|
' i: IUnknown;',
|
|
'begin',
|
|
' obj:=tobject(roota);',
|
|
' obj:=tobject(childa);',
|
|
' child:=tchild(tobject(roota));',
|
|
' roota:=textroota(obj);',
|
|
' roota:=textroota(child);',
|
|
' roota:=textroota(rootb);',
|
|
' roota:=textroota(childb);',
|
|
' childa:=textchilda(textroota(obj));',
|
|
' roota:=TExtRootA(i)',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_TypeCastToRootClass',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.Child = null;',
|
|
'this.RootA = null;',
|
|
'this.ChildA = null;',
|
|
'this.RootB = null;',
|
|
'this.ChildB = null;',
|
|
'this.i = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Obj = $mod.RootA;',
|
|
'$mod.Obj = $mod.ChildA;',
|
|
'$mod.Child = $mod.RootA;',
|
|
'$mod.RootA = $mod.Obj;',
|
|
'$mod.RootA = $mod.Child;',
|
|
'$mod.RootA = $mod.RootB;',
|
|
'$mod.RootA = $mod.ChildB;',
|
|
'$mod.ChildA = $mod.Obj;',
|
|
'$mod.RootA = $mod.i;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_TypeCastToJSObject;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' IUnknown = interface end;',
|
|
' IBird = interface(IUnknown) end;',
|
|
' TClass = class of TObject;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TChild = class',
|
|
' end;',
|
|
' TJSObject = class external name ''Object''',
|
|
' end;',
|
|
' TRec = record end;',
|
|
'var',
|
|
' Obj: TObject;',
|
|
' Child: TChild;',
|
|
' i: IUnknown;',
|
|
' Bird: IBird;',
|
|
' j: TJSObject;',
|
|
' r: TRec;',
|
|
' c: TClass;',
|
|
'begin',
|
|
' j:=tjsobject(IUnknown);',
|
|
' j:=tjsobject(IBird);',
|
|
' j:=tjsobject(TObject);',
|
|
' j:=tjsobject(TChild);',
|
|
' j:=tjsobject(TRec);',
|
|
' j:=tjsobject(Obj);',
|
|
' j:=tjsobject(Child);',
|
|
' j:=tjsobject(i);',
|
|
' j:=tjsobject(Bird);',
|
|
' j:=tjsobject(r);',
|
|
' j:=tjsobject(c);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_TypeCastToJSObject',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
|
|
'rtl.createInterface($mod, "IBird", "{4B0D080B-C0F6-396E-AE88-000B87785074}", [], $mod.IUnknown);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
|
|
'});',
|
|
'this.TRec = function (s) {',
|
|
' this.$equal = function (b) {',
|
|
' return true;',
|
|
' };',
|
|
'};',
|
|
'this.Obj = null;',
|
|
'this.Child = null;',
|
|
'this.i = null;',
|
|
'this.Bird = null;',
|
|
'this.j = null;',
|
|
'this.r = new $mod.TRec();',
|
|
'this.c = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.j = $mod.IUnknown;',
|
|
'$mod.j = $mod.IBird;',
|
|
'$mod.j = $mod.TObject;',
|
|
'$mod.j = $mod.TChild;',
|
|
'$mod.j = $mod.TRec;',
|
|
'$mod.j = $mod.Obj;',
|
|
'$mod.j = $mod.Child;',
|
|
'$mod.j = $mod.i;',
|
|
'$mod.j = $mod.Bird;',
|
|
'$mod.j = $mod.r;',
|
|
'$mod.j = $mod.c;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_TypeCastStringToExternalString;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TJSString = class external name ''String''');
|
|
Add(' class function fromCharCode() : string; varargs;');
|
|
Add(' function anchor(const aName : string) : string;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' s: string;');
|
|
Add('begin');
|
|
Add(' s:=TJSString.fromCharCode(65,66);');
|
|
Add(' s:=TJSString(s).anchor(s);');
|
|
Add(' s:=TJSString(''foo'').anchor(s);');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_TypeCastStringToExternalString',
|
|
LinesToStr([ // statements
|
|
'this.s = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.s = String.fromCharCode(65, 66);',
|
|
'$mod.s = $mod.s.anchor($mod.s);',
|
|
'$mod.s = "foo".anchor($mod.s);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_TypeCastToJSFunction;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TJSObject = class external name ''Object'' end;',
|
|
' TJSFunction = class external name ''Function''',
|
|
' function bind(thisArg: TJSObject): TJSFunction; varargs;',
|
|
' function call(thisArg: TJSObject): JSValue; varargs;',
|
|
' end;',
|
|
' TObject = class',
|
|
' procedure DoIt(i: longint);',
|
|
' end;',
|
|
' TFuncInt = function(o: TObject): longint;',
|
|
'function GetIt(o: TObject): longint;',
|
|
' procedure Sub; begin end;',
|
|
'var',
|
|
' f: TJSFunction;',
|
|
' fi: TFuncInt;',
|
|
'begin',
|
|
' fi:=TFuncInt(f);',
|
|
' f:=TJSFunction(fi);',
|
|
' f:=TJSFunction(@GetIt);',
|
|
' f:=TJSFunction(@GetIt).bind(nil,3);',
|
|
' f:=TJSFunction(@Sub);',
|
|
' f:=TJSFunction(@o.doit);',
|
|
' f:=TJSFunction(fi).bind(nil,4)',
|
|
'end;',
|
|
'procedure TObject.DoIt(i: longint);',
|
|
' procedure Sub; begin end;',
|
|
'var f: TJSFunction;',
|
|
'begin',
|
|
' f:=TJSFunction(@DoIt);',
|
|
' f:=TJSFunction(@DoIt).bind(nil,13);',
|
|
' f:=TJSFunction(@Sub);',
|
|
' f:=TJSFunction(@GetIt);',
|
|
'end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_TypeCastToJSFunction',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (i) {',
|
|
' var Self = this;',
|
|
' function Sub() {',
|
|
' };',
|
|
' var f = null;',
|
|
' f = rtl.createCallback(Self, "DoIt");',
|
|
' f = rtl.createCallback(Self, "DoIt").bind(null, 13);',
|
|
' f = Sub;',
|
|
' f = $mod.GetIt;',
|
|
' };',
|
|
'});',
|
|
'this.GetIt = function (o) {',
|
|
' var Result = 0;',
|
|
' function Sub() {',
|
|
' };',
|
|
' var f = null;',
|
|
' var fi = null;',
|
|
' fi = f;',
|
|
' f = fi;',
|
|
' f = $mod.GetIt;',
|
|
' f = $mod.GetIt.bind(null, 3);',
|
|
' f = Sub;',
|
|
' f = rtl.createCallback(o, "DoIt");',
|
|
' f = fi.bind(null, 4);',
|
|
' return Result;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_CallClassFunctionOfInstanceFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TJSString = class external name ''String''');
|
|
Add(' class function fromCharCode() : string; varargs;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' s: string;');
|
|
Add(' sObj: TJSString;');
|
|
Add('begin');
|
|
Add(' s:=sObj.fromCharCode(65,66);');
|
|
SetExpectedPasResolverError('External class instance cannot access static class function fromCharCode',
|
|
nExternalClassInstanceCannotAccessStaticX);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_BracketAccessor;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TJSArray = class external name ''Array2''',
|
|
' function GetItems(Index: longint): jsvalue; external name ''[]'';',
|
|
' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';',
|
|
' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;',
|
|
' end;',
|
|
'procedure DoIt(vI: JSValue; const vJ: jsvalue; var vK: jsvalue; out vL: jsvalue);',
|
|
'begin end;',
|
|
'var',
|
|
' Arr: tjsarray;',
|
|
' s: string;',
|
|
' i: longint;',
|
|
' v: jsvalue;',
|
|
'begin',
|
|
' v:=arr[0];',
|
|
' v:=arr.items[1];',
|
|
' arr[2]:=s;',
|
|
' arr.items[3]:=s;',
|
|
' arr[4]:=i;',
|
|
' arr[5]:=arr[6];',
|
|
' arr.items[7]:=arr.items[8];',
|
|
' with arr do items[9]:=items[10];',
|
|
' doit(arr[7],arr[8],arr[9],arr[10]);',
|
|
' with arr do begin',
|
|
' v:=GetItems(14);',
|
|
' setitems(15,16);',
|
|
' end;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_BracketAccessor',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (vI, vJ, vK, vL) {',
|
|
'};',
|
|
'this.Arr = null;',
|
|
'this.s = "";',
|
|
'this.i = 0;',
|
|
'this.v = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.v = $mod.Arr[0];',
|
|
'$mod.v = $mod.Arr[1];',
|
|
'$mod.Arr[2] = $mod.s;',
|
|
'$mod.Arr[3] = $mod.s;',
|
|
'$mod.Arr[4] = $mod.i;',
|
|
'$mod.Arr[5] = $mod.Arr[6];',
|
|
'$mod.Arr[7] = $mod.Arr[8];',
|
|
'var $with1 = $mod.Arr;',
|
|
'$with1[9] = $with1[10];',
|
|
'$mod.DoIt($mod.Arr[7], $mod.Arr[8], {',
|
|
' a: 9,',
|
|
' p: $mod.Arr,',
|
|
' get: function () {',
|
|
' return this.p[this.a];',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p[this.a] = v;',
|
|
' }',
|
|
'}, {',
|
|
' a: 10,',
|
|
' p: $mod.Arr,',
|
|
' get: function () {',
|
|
' return this.p[this.a];',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p[this.a] = v;',
|
|
' }',
|
|
'});',
|
|
'var $with2 = $mod.Arr;',
|
|
'$mod.v = $with2[14];',
|
|
'$with2[15] = 16;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_BracketAccessor_Call;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TJSArray = class external name ''Array2''',
|
|
' function GetItems(Index: longint): jsvalue; external name ''[]'';',
|
|
' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';',
|
|
' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;',
|
|
' end;',
|
|
' TMyArr = class(TJSArray)',
|
|
' procedure DoIt;',
|
|
' end;',
|
|
'procedure tmyarr.DoIt;',
|
|
'begin',
|
|
' Items[1]:=Items[2];',
|
|
' SetItems(3,getItems(4));',
|
|
'end;',
|
|
'var',
|
|
' Arr: tmyarr;',
|
|
' s: string;',
|
|
' i: longint;',
|
|
' v: jsvalue;',
|
|
'begin',
|
|
' v:=arr[0];',
|
|
' v:=arr.items[1];',
|
|
' arr[2]:=s;',
|
|
' arr.items[3]:=s;',
|
|
' arr[4]:=i;',
|
|
' arr[5]:=arr[6];',
|
|
' arr.items[7]:=arr.items[8];',
|
|
' with arr do items[9]:=items[10];',
|
|
' with arr do begin',
|
|
' v:=GetItems(14);',
|
|
' setitems(15,16);',
|
|
' end;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_BracketAccessor_Call',
|
|
LinesToStr([ // statements
|
|
'rtl.createClassExt($mod, "TMyArr", Array2, "", function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' this[1] = this[2];',
|
|
' this[3] = this[4];',
|
|
' };',
|
|
'});',
|
|
'this.Arr = null;',
|
|
'this.s = "";',
|
|
'this.i = 0;',
|
|
'this.v = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.v = $mod.Arr[0];',
|
|
'$mod.v = $mod.Arr[1];',
|
|
'$mod.Arr[2] = $mod.s;',
|
|
'$mod.Arr[3] = $mod.s;',
|
|
'$mod.Arr[4] = $mod.i;',
|
|
'$mod.Arr[5] = $mod.Arr[6];',
|
|
'$mod.Arr[7] = $mod.Arr[8];',
|
|
'var $with1 = $mod.Arr;',
|
|
'$with1[9] = $with1[10];',
|
|
'var $with2 = $mod.Arr;',
|
|
'$mod.v = $with2[14];',
|
|
'$with2[15] = 16;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_BracketAccessor_2ParamsFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TJSArray = class external name ''Array2''');
|
|
Add(' function GetItems(Index1, Index2: longint): jsvalue; external name ''[]'';');
|
|
Add(' procedure SetItems(Index1, Index2: longint; Value: jsvalue); external name ''[]'';');
|
|
Add(' property Items[Index1, Index2: longint]: jsvalue read GetItems write SetItems; default;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError(sBracketAccessorOfExternalClassMustHaveOneParameter,
|
|
nBracketAccessorOfExternalClassMustHaveOneParameter);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_BracketAccessor_ReadOnly;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TJSArray = class external name ''Array2''');
|
|
Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
|
|
Add(' property Items[Index: longint]: jsvalue read GetItems; default;');
|
|
Add(' end;');
|
|
Add('procedure DoIt(vI: JSValue; const vJ: jsvalue);');
|
|
Add('begin end;');
|
|
Add('var');
|
|
Add(' Arr: tjsarray;');
|
|
Add(' v: jsvalue;');
|
|
Add('begin');
|
|
Add(' v:=arr[0];');
|
|
Add(' v:=arr.items[1];');
|
|
Add(' with arr do v:=items[2];');
|
|
Add(' doit(arr[3],arr[4]);');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_BracketAccessor_ReadOnly',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (vI, vJ) {',
|
|
'};',
|
|
'this.Arr = null;',
|
|
'this.v = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.v = $mod.Arr[0];',
|
|
'$mod.v = $mod.Arr[1];',
|
|
'var $with1 = $mod.Arr;',
|
|
'$mod.v = $with1[2];',
|
|
'$mod.DoIt($mod.Arr[3], $mod.Arr[4]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_BracketAccessor_WriteOnly;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TJSArray = class external name ''Array2''');
|
|
Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
|
|
Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' Arr: tjsarray;');
|
|
Add(' s: string;');
|
|
Add(' i: longint;');
|
|
Add(' v: jsvalue;');
|
|
Add('begin');
|
|
Add(' arr[2]:=s;');
|
|
Add(' arr.items[3]:=s;');
|
|
Add(' arr[4]:=i;');
|
|
Add(' with arr do items[5]:=i;');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_BracketAccessor_WriteOnly',
|
|
LinesToStr([ // statements
|
|
'this.Arr = null;',
|
|
'this.s = "";',
|
|
'this.i = 0;',
|
|
'this.v = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Arr[2] = $mod.s;',
|
|
'$mod.Arr[3] = $mod.s;',
|
|
'$mod.Arr[4] = $mod.i;',
|
|
'var $with1 = $mod.Arr;',
|
|
'$with1[5] = $mod.i;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_BracketAccessor_MultiType;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TJSArray = class external name ''Array2''');
|
|
Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
|
|
Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
|
|
Add(' procedure SetNumbers(Index: longint; Value: longint); external name ''[]'';');
|
|
Add(' property Numbers[Index: longint]: longint write SetNumbers;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' Arr: tjsarray;');
|
|
Add(' s: string;');
|
|
Add(' i: longint;');
|
|
Add(' v: jsvalue;');
|
|
Add('begin');
|
|
Add(' arr[2]:=s;');
|
|
Add(' arr.items[3]:=s;');
|
|
Add(' arr.numbers[4]:=i;');
|
|
Add(' with arr do items[5]:=i;');
|
|
Add(' with arr do numbers[6]:=i;');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_BracketAccessor_MultiType',
|
|
LinesToStr([ // statements
|
|
'this.Arr = null;',
|
|
'this.s = "";',
|
|
'this.i = 0;',
|
|
'this.v = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Arr[2] = $mod.s;',
|
|
'$mod.Arr[3] = $mod.s;',
|
|
'$mod.Arr[4] = $mod.i;',
|
|
'var $with1 = $mod.Arr;',
|
|
'$with1[5] = $mod.i;',
|
|
'var $with2 = $mod.Arr;',
|
|
'$with2[6] = $mod.i;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_BracketAccessor_Index;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TJSArray = class external name ''Array2''');
|
|
Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
|
|
Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
|
|
Add(' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;');
|
|
Add(' end;');
|
|
Add('var');
|
|
Add(' Arr: tjsarray;');
|
|
Add(' i: longint;');
|
|
Add(' IntArr: array of longint;');
|
|
Add(' v: jsvalue;');
|
|
Add('begin');
|
|
Add(' v:=arr.items[i];');
|
|
Add(' arr[longint(v)]:=arr.items[intarr[0]];');
|
|
Add(' arr.items[intarr[1]]:=arr[IntArr[2]];');
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_BracketAccessor_Index',
|
|
LinesToStr([ // statements
|
|
'this.Arr = null;',
|
|
'this.i = 0;',
|
|
'this.IntArr = [];',
|
|
'this.v = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.v = $mod.Arr[$mod.i];',
|
|
'$mod.Arr[Math.floor($mod.v)] = $mod.Arr[$mod.IntArr[0]];',
|
|
'$mod.Arr[$mod.IntArr[1]] = $mod.Arr[$mod.IntArr[2]];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_ForInJSObject;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TJSObject = class external name ''Object''',
|
|
' end;',
|
|
'var',
|
|
' o: TJSObject;',
|
|
' key: string;',
|
|
'begin',
|
|
' for key in o do',
|
|
' if key=''abc'' then ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_ForInJSObject',
|
|
LinesToStr([ // statements
|
|
'this.o = null;',
|
|
'this.key = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'for ($mod.key in $mod.o) if ($mod.key === "abc") ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_ForInJSArray;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TJSInt8Array = class external name ''Int8Array''',
|
|
' private',
|
|
' flength: NativeInt external name ''length'';',
|
|
' function getValue(Index: NativeInt): shortint; external name ''[]'';',
|
|
' public',
|
|
' property values[Index: NativeInt]: Shortint Read getValue; default;',
|
|
' property Length: NativeInt read flength;',
|
|
' end;',
|
|
'var',
|
|
' a: TJSInt8Array;',
|
|
' value: shortint;',
|
|
'begin',
|
|
' for value in a do',
|
|
' if value=3 then ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestExternalClass_ForInJSArray',
|
|
LinesToStr([ // statements
|
|
'this.a = null;',
|
|
'this.value = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'for (var $in1 = $mod.a, $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) {',
|
|
' $mod.value = $in1[$l2];',
|
|
' if ($mod.value === 3) ;',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestExternalClass_IncompatibleArgDuplicateIdentifier;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit2.pas',
|
|
LinesToStr([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TJSBufferSource = class external name ''BufferSource''',
|
|
' end;',
|
|
'procedure DoIt(s: TJSBufferSource); external name ''DoIt'';',
|
|
'']),
|
|
'');
|
|
AddModuleWithIntfImplSrc('unit3.pas',
|
|
LinesToStr([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TJSBufferSource = class external name ''BufferSource''',
|
|
' end;',
|
|
'']),
|
|
'');
|
|
|
|
StartUnit(true);
|
|
Add([
|
|
'interface',
|
|
'uses unit2, unit3;',
|
|
'procedure DoSome(s: TJSBufferSource);',
|
|
'implementation',
|
|
'procedure DoSome(s: TJSBufferSource);',
|
|
'begin',
|
|
' DoIt(s);',
|
|
'end;',
|
|
'']);
|
|
SetExpectedPasResolverError('Incompatible type arg no. 1: Got "unit3.TJSBufferSource", expected "unit2.TJSBufferSource"',
|
|
nIncompatibleTypeArgNo);
|
|
ConvertUnit;
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_Corba;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface;',
|
|
' IUnknown = interface',
|
|
' [''{00000000-0000-0000-C000-000000000046}'']',
|
|
' end;',
|
|
' IInterface = IUnknown;',
|
|
' IBird = interface(IInterface)',
|
|
' function GetSize: longint;',
|
|
' procedure SetSize(i: longint);',
|
|
' property Size: longint read GetSize write SetSize;',
|
|
' procedure DoIt(i: longint);',
|
|
' end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = class(TObject,IBird)',
|
|
' function GetSize: longint; virtual; abstract;',
|
|
' procedure SetSize(i: longint); virtual; abstract;',
|
|
' procedure DoIt(i: longint); virtual; abstract;',
|
|
' end;',
|
|
'var',
|
|
' BirdIntf: IBird;',
|
|
'begin',
|
|
' BirdIntf.Size:=BirdIntf.Size;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_Corba',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{00000000-0000-0000-C000-000000000046}", [], null);',
|
|
'rtl.createInterface($mod, "IBird", "{5BD1A53B-69BB-37EE-AF32-BEFB86D85B03}", ["GetSize", "SetSize", "DoIt"], $mod.IUnknown);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' rtl.addIntf(this, $mod.IBird);',
|
|
'});',
|
|
'this.BirdIntf = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
' $mod.BirdIntf.SetSize($mod.BirdIntf.GetSize());',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_ProcExternalFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' procedure DoIt; external name ''foo'';',
|
|
' end;',
|
|
'begin']);
|
|
SetExpectedParserError(
|
|
'Fields are not allowed in Interfaces at token "Identifier external" in file test1.pp at line 6 column 21',
|
|
nParserNoFieldsAllowed);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_Overloads;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' integer = longint;',
|
|
' IUnknown = interface',
|
|
' procedure DoIt(i: integer);',
|
|
' procedure DoIt(s: string);',
|
|
' end;',
|
|
' IBird = interface(IUnknown)',
|
|
' procedure DoIt(b: boolean); overload;',
|
|
' end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = class(TObject,IBird)',
|
|
' procedure DoIt(o: TObject);',
|
|
' procedure DoIt(s: string);',
|
|
' procedure DoIt(i: integer);',
|
|
' procedure DoIt(b: boolean);',
|
|
' end;',
|
|
'procedure TBird.DoIt(o: TObject); begin end;',
|
|
'procedure TBird.DoIt(s: string); begin end;',
|
|
'procedure TBird.DoIt(i: integer); begin end;',
|
|
'procedure TBird.DoIt(b: boolean); begin end;',
|
|
'var',
|
|
' BirdIntf: IBird;',
|
|
'begin',
|
|
' BirdIntf.DoIt(3);',
|
|
' BirdIntf.DoIt(''abc'');',
|
|
' BirdIntf.DoIt(true);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_Overloads',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-BDC4-8A2AE2C59400}", ["DoIt", "DoIt$1"], null);',
|
|
'rtl.createInterface($mod, "IBird", "{8285DD5E-EA3E-396E-AE88-000B86AABF05}", ["DoIt$2"], $mod.IUnknown);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' this.DoIt = function (o) {',
|
|
' };',
|
|
' this.DoIt$1 = function (s) {',
|
|
' };',
|
|
' this.DoIt$2 = function (i) {',
|
|
' };',
|
|
' this.DoIt$3 = function (b) {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IBird, {',
|
|
' DoIt$2: "DoIt$3",',
|
|
' DoIt: "DoIt$2"',
|
|
' });',
|
|
'});',
|
|
'this.BirdIntf = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.BirdIntf.DoIt(3);',
|
|
'$mod.BirdIntf.DoIt$1("abc");',
|
|
'$mod.BirdIntf.DoIt$2(true);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_DuplicateGUIInIntfListFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IBird = interface',
|
|
' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
|
|
' end;',
|
|
' IDog = interface',
|
|
' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
|
|
' end;',
|
|
' TObject = class(IBird,IDog)',
|
|
' end;',
|
|
'begin']);
|
|
SetExpectedPasResolverError('Duplicate GUID {4B3BA825-E0EC-4799-A19C-55F714A07959} in IDog and IBird',
|
|
nDuplicateGUIDXInYZ);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_DuplicateGUIInAncestorFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IAnimal = interface',
|
|
' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
|
|
' end;',
|
|
' IBird = interface(IAnimal)',
|
|
' end;',
|
|
' IHawk = interface(IBird)',
|
|
' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
|
|
' end;',
|
|
'begin']);
|
|
SetExpectedPasResolverError('Duplicate GUID {4B3BA825-E0EC-4799-A19C-55F714A07959} in IHawk and IAnimal',
|
|
nDuplicateGUIDXInYZ);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_AncestorImpl;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' integer = longint;',
|
|
' IUnknown = interface',
|
|
' procedure DoIt(i: integer);',
|
|
' end;',
|
|
' IBird = interface',
|
|
' procedure Fly(i: integer);',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' procedure DoIt(i: integer);',
|
|
' end;',
|
|
' TBird = class(IBird)',
|
|
' procedure Fly(i: integer);',
|
|
' end;',
|
|
'procedure TObject.DoIt(i: integer); begin end;',
|
|
'procedure TBird.Fly(i: integer); begin end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_AncestorIntf',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-BDC4-8A2800000000}", ["DoIt"], null);',
|
|
'rtl.createInterface($mod, "IBird", "{B92D5841-6264-3AE3-BF20-000000000000}", ["Fly"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (i) {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' this.Fly = function (i) {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IBird);',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_ImplReintroduce;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' integer = longint;',
|
|
' IBird = interface',
|
|
' procedure DoIt(i: integer);',
|
|
' end;',
|
|
' TObject = class',
|
|
' procedure DoIt(i: integer);',
|
|
' end;',
|
|
' TBird = class(IBird)',
|
|
' procedure DoIt(i: integer); virtual; reintroduce;',
|
|
' end;',
|
|
'procedure TObject.DoIt(i: integer); begin end;',
|
|
'procedure TBird.DoIt(i: integer); begin end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_ImplReintroduce',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IBird", "{B92D5841-6264-3AE2-8594-000000000000}", ["DoIt"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (i) {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' this.DoIt$1 = function (i) {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IBird, {',
|
|
' DoIt: "DoIt$1"',
|
|
' });',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_MethodResolution;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' procedure Walk(i: longint);',
|
|
' end;',
|
|
' IBird = interface(IUnknown)',
|
|
' procedure Walk(b: boolean); overload;',
|
|
' procedure Fly(s: string);',
|
|
' end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = class(TObject,IBird)',
|
|
' procedure IBird.Fly = Move;',
|
|
' procedure IBird.Walk = Hop;',
|
|
' procedure Hop(i: longint);',
|
|
' procedure Move(s: string);',
|
|
' procedure Hop(b: boolean);',
|
|
' end;',
|
|
'procedure TBird.Move(s: string); begin end;',
|
|
'procedure TBird.Hop(i: longint); begin end;',
|
|
'procedure TBird.Hop(b: boolean); begin end;',
|
|
'var',
|
|
' BirdIntf: IBird;',
|
|
'begin',
|
|
' BirdIntf.Walk(3);',
|
|
' BirdIntf.Walk(true);',
|
|
' BirdIntf.Fly(''abc'');',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_MethodResolution',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-BDD7-23D600000000}", ["Walk"], null);',
|
|
'rtl.createInterface($mod, "IBird", "{CF8A4986-80F6-396E-AE88-000B86AAE208}", ["Walk$1", "Fly"], $mod.IUnknown);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' this.Hop = function (i) {',
|
|
' };',
|
|
' this.Move = function (s) {',
|
|
' };',
|
|
' this.Hop$1 = function (b) {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IBird, {',
|
|
' Walk$1: "Hop$1",',
|
|
' Fly: "Move",',
|
|
' Walk: "Hop"',
|
|
' });',
|
|
'});',
|
|
'this.BirdIntf = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.BirdIntf.Walk(3);',
|
|
'$mod.BirdIntf.Walk$1(true);',
|
|
'$mod.BirdIntf.Fly("abc");',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_AncestorMoreInterfaces;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' procedure Walk;',
|
|
' end;',
|
|
' IBird = interface end;',
|
|
' IDog = interface end;',
|
|
' TObject = class(IBird,IDog)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' procedure Walk; virtual; abstract;',
|
|
' end;',
|
|
' TBird = class(IUnknown)',
|
|
' end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_AncestorLess',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{8F2D5841-758A-322B-BDDF-21CD521DD723}", ["_AddRef", "Walk"], null);',
|
|
'rtl.createInterface($mod, "IBird", "{CCE11D4C-6504-3AEE-AE88-000B86AAE675}", [], $mod.IUnknown);',
|
|
'rtl.createInterface($mod, "IDog", "{CCE11D4C-6504-3AEE-AE88-000B8E5FC675}", [], $mod.IUnknown);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IBird);',
|
|
' rtl.addIntf(this, $mod.IDog);',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
' rtl.addIntf(this, $mod.IBird);',
|
|
' rtl.addIntf(this, $mod.IDog);',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_MethodOverride;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' [''{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}'']',
|
|
' procedure Go;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' procedure Go; virtual; abstract;',
|
|
' end;',
|
|
' TBird = class',
|
|
' procedure Go; override;',
|
|
' end;',
|
|
' TCat = class(TObject)',
|
|
' procedure Go; override;',
|
|
' end;',
|
|
' TDog = class(TObject, IUnknown)',
|
|
' procedure Go; override;',
|
|
' end;',
|
|
'procedure TBird.Go; begin end;',
|
|
'procedure TCat.Go; begin end;',
|
|
'procedure TDog.Go; begin end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_MethodOverride',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}", ["Go"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' this.Go = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'rtl.createClass($mod, "TCat", $mod.TObject, function () {',
|
|
' this.Go = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'rtl.createClass($mod, "TDog", $mod.TObject, function () {',
|
|
' this.Go = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_Corba_Delegation;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' end;',
|
|
' IBird = interface(IUnknown)',
|
|
' procedure Fly(s: string);',
|
|
' end;',
|
|
' IEagle = interface(IBird)',
|
|
' end;',
|
|
' IDove = interface(IBird)',
|
|
' end;',
|
|
' ISwallow = interface(IBird)',
|
|
' end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
|
|
' procedure Fly(s: string); virtual; abstract;',
|
|
' end;',
|
|
' TBat = class(IBird,IEagle,IDove,ISwallow)',
|
|
' FBirdIntf: IBird;',
|
|
' property BirdIntf: IBird read FBirdIntf implements IBird;',
|
|
' function GetEagleIntf: IEagle; virtual; abstract;',
|
|
' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
|
|
' FDoveObj: TBird;',
|
|
' property DoveObj: TBird read FDoveObj implements IDove;',
|
|
' function GetSwallowObj: TBird; virtual; abstract;',
|
|
' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
|
|
' end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_Delegation',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
|
|
'rtl.createInterface($mod, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], $mod.IUnknown);',
|
|
'rtl.createInterface($mod, "IEagle", "{489289DE-FDE2-34A6-8288-39119022B1B4}", [], $mod.IBird);',
|
|
'rtl.createInterface($mod, "IDove", "{489289DE-FDE2-34A6-8288-39118EF16074}", [], $mod.IBird);',
|
|
'rtl.createInterface($mod, "ISwallow", "{B89289DE-FDE2-34A6-8288-3911CBDCB359}", [], $mod.IBird);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' rtl.addIntf(this, $mod.IBird);',
|
|
' rtl.addIntf(this, $mod.IEagle);',
|
|
' rtl.addIntf(this, $mod.IDove);',
|
|
' rtl.addIntf(this, $mod.ISwallow);',
|
|
'});',
|
|
'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.FBirdIntf = null;',
|
|
' this.FDoveObj = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FBirdIntf = undefined;',
|
|
' this.FDoveObj = undefined;',
|
|
' $mod.TObject.$final.call(this);',
|
|
' };',
|
|
' this.$intfmaps = {',
|
|
' "{478D080B-C0F6-396E-AE88-000B87785B07}": function () {',
|
|
' return this.FBirdIntf;',
|
|
' },',
|
|
' "{489289DE-FDE2-34A6-8288-39119022B1B4}": function () {',
|
|
' return this.GetEagleIntf();',
|
|
' },',
|
|
' "{489289DE-FDE2-34A6-8288-39118EF16074}": function () {',
|
|
' return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
|
|
' },',
|
|
' "{B89289DE-FDE2-34A6-8288-3911CBDCB359}": function () {',
|
|
' return rtl.getIntfT(this.GetSwallowObj(), $mod.ISwallow);',
|
|
' }',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_Corba_DelegationStatic;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' end;',
|
|
' IBird = interface(IUnknown)',
|
|
' procedure Fly(s: string);',
|
|
' end;',
|
|
' IEagle = interface(IBird)',
|
|
' end;',
|
|
' IDove = interface(IBird)',
|
|
' end;',
|
|
' ISwallow = interface(IBird)',
|
|
' end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
|
|
' procedure Fly(s: string); virtual; abstract;',
|
|
' end;',
|
|
' TBat = class(IBird,IEagle,IDove,ISwallow)',
|
|
' private',
|
|
' class var FBirdIntf: IBird;',
|
|
' class var FDoveObj: TBird;',
|
|
' class function GetEagleIntf: IEagle; virtual; abstract;',
|
|
' class function GetSwallowObj: TBird; virtual; abstract;',
|
|
' protected',
|
|
' class property BirdIntf: IBird read FBirdIntf implements IBird;',
|
|
' class property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
|
|
' class property DoveObj: TBird read FDoveObj implements IDove;',
|
|
' class property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
|
|
' end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_DelegationStatic',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
|
|
'rtl.createInterface($mod, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], $mod.IUnknown);',
|
|
'rtl.createInterface($mod, "IEagle", "{489289DE-FDE2-34A6-8288-39119022B1B4}", [], $mod.IBird);',
|
|
'rtl.createInterface($mod, "IDove", "{489289DE-FDE2-34A6-8288-39118EF16074}", [], $mod.IBird);',
|
|
'rtl.createInterface($mod, "ISwallow", "{B89289DE-FDE2-34A6-8288-3911CBDCB359}", [], $mod.IBird);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' rtl.addIntf(this, $mod.IBird);',
|
|
' rtl.addIntf(this, $mod.IEagle);',
|
|
' rtl.addIntf(this, $mod.IDove);',
|
|
' rtl.addIntf(this, $mod.ISwallow);',
|
|
'});',
|
|
'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
|
|
' this.FBirdIntf = null;',
|
|
' this.FDoveObj = null;',
|
|
' this.$intfmaps = {',
|
|
' "{478D080B-C0F6-396E-AE88-000B87785B07}": function () {',
|
|
' return this.FBirdIntf;',
|
|
' },',
|
|
' "{489289DE-FDE2-34A6-8288-39119022B1B4}": function () {',
|
|
' return this.$class.GetEagleIntf();',
|
|
' },',
|
|
' "{489289DE-FDE2-34A6-8288-39118EF16074}": function () {',
|
|
' return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
|
|
' },',
|
|
' "{B89289DE-FDE2-34A6-8288-3911CBDCB359}": function () {',
|
|
' return rtl.getIntfT(this.$class.GetSwallowObj(), $mod.ISwallow);',
|
|
' }',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_Corba_Operators;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' end;',
|
|
' IBird = interface(IUnknown)',
|
|
' function GetItems(Index: longint): longint;',
|
|
' procedure SetItems(Index: longint; Value: longint);',
|
|
' property Items[Index: longint]: longint read GetItems write SetItems; default;',
|
|
' end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = class(TObject,IBird)',
|
|
' function GetItems(Index: longint): longint; virtual; abstract;',
|
|
' procedure SetItems(Index: longint; Value: longint); virtual; abstract;',
|
|
' end;',
|
|
'var',
|
|
' IntfVar: IBird = nil;',
|
|
' IntfVar2: IBird;',
|
|
' ObjVar: TBird;',
|
|
' v: JSValue;',
|
|
'begin',
|
|
' IntfVar:=nil;',
|
|
' IntfVar[3]:=IntfVar[4];',
|
|
' if Assigned(IntfVar) then ;',
|
|
' IntfVar:=IntfVar2;',
|
|
' IntfVar:=ObjVar;',
|
|
' if IntfVar=IntfVar2 then ;',
|
|
' if IntfVar<>IntfVar2 then ;',
|
|
' if IntfVar is IBird then ;',
|
|
' if IntfVar is TBird then ;',
|
|
' if ObjVar is IBird then ;',
|
|
' IntfVar:=IntfVar2 as IBird;',
|
|
' ObjVar:=IntfVar2 as TBird;',
|
|
' IntfVar:=ObjVar as IBird;',
|
|
' IntfVar:=IBird(IntfVar2);',
|
|
' ObjVar:=TBird(IntfVar);',
|
|
' IntfVar:=IBird(ObjVar);',
|
|
' v:=IntfVar;',
|
|
' IntfVar:=IBird(v);',
|
|
' if v is IBird then ;',
|
|
' v:=JSValue(IntfVar);',
|
|
' v:=IBird;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_Corba_Operators',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
|
|
'rtl.createInterface($mod, "IBird", "{D53FED90-DE59-3202-B1AE-000B87785B08}", ["GetItems", "SetItems"], $mod.IUnknown);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' rtl.addIntf(this, $mod.IBird);',
|
|
'});',
|
|
'this.IntfVar = null;',
|
|
'this.IntfVar2 = null;',
|
|
'this.ObjVar = null;',
|
|
'this.v = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.IntfVar = null;',
|
|
'$mod.IntfVar.SetItems(3, $mod.IntfVar.GetItems(4));',
|
|
'if ($mod.IntfVar != null) ;',
|
|
'$mod.IntfVar = $mod.IntfVar2;',
|
|
'$mod.IntfVar = rtl.getIntfT($mod.ObjVar,$mod.IBird);',
|
|
'if ($mod.IntfVar === $mod.IntfVar2) ;',
|
|
'if ($mod.IntfVar !== $mod.IntfVar2) ;',
|
|
'if ($mod.IBird.isPrototypeOf($mod.IntfVar)) ;',
|
|
'if (rtl.intfIsClass($mod.IntfVar, $mod.TBird)) ;',
|
|
'if (rtl.getIntfT($mod.ObjVar, $mod.IBird) !== null) ;',
|
|
'$mod.IntfVar = rtl.as($mod.IntfVar2, $mod.IBird);',
|
|
'$mod.ObjVar = rtl.intfAsClass($mod.IntfVar2, $mod.TBird);',
|
|
'$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
|
|
'$mod.IntfVar = $mod.IntfVar2;',
|
|
'$mod.ObjVar = rtl.intfToClass($mod.IntfVar, $mod.TBird);',
|
|
'$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
|
|
'$mod.v = $mod.IntfVar;',
|
|
'$mod.IntfVar = rtl.getObject($mod.v);',
|
|
'if (rtl.isExt($mod.v, $mod.IBird, 1)) ;',
|
|
'$mod.v = rtl.getObject($mod.IntfVar);',
|
|
'$mod.v = $mod.IBird;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_Corba_Args;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' end;',
|
|
' IBird = interface(IUnknown)',
|
|
' end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = class(TObject,IBird)',
|
|
' end;',
|
|
'procedure DoIt(var u; i: IBird; const j: IBird);',
|
|
'begin',
|
|
' DoIt(i,i,i);',
|
|
'end;',
|
|
'procedure Change(var i: IBird; out j: IBird);',
|
|
'begin',
|
|
' DoIt(i,i,i);',
|
|
' Change(i,i);',
|
|
'end;',
|
|
'var',
|
|
' i: IBird;',
|
|
' o: TBird;',
|
|
'begin',
|
|
' DoIt(i,i,i);',
|
|
' Change(i,i);',
|
|
' DoIt(o,o,o);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_Corba_Args',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
|
|
'rtl.createInterface($mod, "IBird", "{4B0D080B-C0F6-396E-AE88-000B87785074}", [], $mod.IUnknown);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' rtl.addIntf(this, $mod.IBird);',
|
|
'});',
|
|
'this.DoIt = function (u, i, j) {',
|
|
' $mod.DoIt({',
|
|
' get: function () {',
|
|
' return i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' i = v;',
|
|
' }',
|
|
' }, i, i);',
|
|
'};',
|
|
'this.Change = function (i, j) {',
|
|
' $mod.DoIt(i, i.get(), i.get());',
|
|
' $mod.Change(i, i);',
|
|
'};',
|
|
'this.i = null;',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt({',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'}, $mod.i, $mod.i);',
|
|
'$mod.Change({',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'}, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});',
|
|
'$mod.DoIt({',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.o;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.o = v;',
|
|
' }',
|
|
'}, rtl.getIntfT($mod.o, $mod.IBird), rtl.getIntfT($mod.o, $mod.IBird));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_Corba_ForIn;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface end;',
|
|
' TObject = class',
|
|
' Id: longint;',
|
|
' end;',
|
|
' IEnumerator = interface(IUnknown)',
|
|
' function GetCurrent: TObject;',
|
|
' function MoveNext: Boolean;',
|
|
' property Current: TObject read GetCurrent;',
|
|
' end;',
|
|
' IEnumerable = interface(IUnknown)',
|
|
' function GetEnumerator: IEnumerator;',
|
|
' end;',
|
|
'var',
|
|
' o: TObject;',
|
|
' i: IEnumerable;',
|
|
'begin',
|
|
' for o in i do o.Id:=3;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_Corba_ForIn',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.Id = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createInterface($mod, "IEnumerator", "{95D7745D-ED61-3F13-BBE4-07708161999E}", ["GetCurrent", "MoveNext"], $mod.IUnknown);',
|
|
'rtl.createInterface($mod, "IEnumerable", "{8CC9D45D-ED7D-3B73-96B6-290B931BB19E}", ["GetEnumerator"], $mod.IUnknown);',
|
|
'this.o = null;',
|
|
'this.i = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'var $in1 = $mod.i.GetEnumerator();',
|
|
'while ($in1.MoveNext()) {',
|
|
' $mod.o = $in1.GetCurrent();',
|
|
' $mod.o.Id = 3;',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_AssignVar;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' end;',
|
|
'var',
|
|
' i: IUnknown;',
|
|
'procedure DoGlobal(o: TObject);',
|
|
'begin',
|
|
' i:=nil;',
|
|
' i:=o;',
|
|
' i:=i;',
|
|
'end;',
|
|
'procedure DoLocal(o: TObject);',
|
|
'const k: IUnknown = nil;',
|
|
'var j: IUnknown;',
|
|
'begin',
|
|
' k:=o;',
|
|
' k:=i;',
|
|
' j:=o;',
|
|
' j:=i;',
|
|
'end;',
|
|
'var o: TObject;',
|
|
'begin',
|
|
' i:=nil;',
|
|
' i:=o;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_AssignVar',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'this.i = null;',
|
|
'this.DoGlobal = function (o) {',
|
|
' rtl.setIntfP($mod, "i", null);',
|
|
' rtl.setIntfP($mod, "i", rtl.queryIntfT(o, $mod.IUnknown), true);',
|
|
' rtl.setIntfP($mod, "i", $mod.i);',
|
|
'};',
|
|
'var k = null;',
|
|
'this.DoLocal = function (o) {',
|
|
' var j = null;',
|
|
' try{',
|
|
' k = rtl.setIntfL(k, rtl.queryIntfT(o, $mod.IUnknown), true);',
|
|
' k = rtl.setIntfL(k, $mod.i);',
|
|
' j = rtl.setIntfL(j, rtl.queryIntfT(o, $mod.IUnknown), true);',
|
|
' j = rtl.setIntfL(j, $mod.i);',
|
|
' }finally{',
|
|
' rtl._Release(j);',
|
|
' };',
|
|
'};',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'rtl.setIntfP($mod, "i", null);',
|
|
'rtl.setIntfP($mod, "i", rtl.queryIntfT($mod.o, $mod.IUnknown), true);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_AssignArg;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' end;',
|
|
'procedure DoDefault(i, j: IUnknown);',
|
|
'begin',
|
|
' i:=nil;',
|
|
' i:=j;',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_AssignArg',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'this.DoDefault = function (i, j) {',
|
|
' rtl._AddRef(i);',
|
|
' try {',
|
|
' i = rtl.setIntfL(i, null);',
|
|
' i = rtl.setIntfL(i, j);',
|
|
' } finally {',
|
|
' rtl._Release(i);',
|
|
' };',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_FunctionResult;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' end;',
|
|
'function DoDefault(i: IUnknown): IUnknown;',
|
|
'begin',
|
|
' Result:=i;',
|
|
' if Result<>nil then exit;',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_FunctionResult',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'this.DoDefault = function (i) {',
|
|
' var Result = null;',
|
|
' var $ok = false;',
|
|
' try {',
|
|
' Result = rtl.setIntfL(Result, i);',
|
|
' if(Result !== null){',
|
|
' $ok = true;',
|
|
' return Result;',
|
|
' };',
|
|
' $ok = true;',
|
|
' } finally {',
|
|
' if(!$ok) rtl._Release(Result);',
|
|
' };',
|
|
' return Result;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_InheritedFuncResult;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' function GetIntf: IUnknown; virtual;',
|
|
' end;',
|
|
' TMouse = class',
|
|
' function GetIntf: IUnknown; override;',
|
|
' end;',
|
|
'function TObject.GetIntf: IUnknown; begin end;',
|
|
'function TMouse.GetIntf: IUnknown;',
|
|
'var i: IUnknown;',
|
|
'begin',
|
|
' inherited;',
|
|
' inherited GetIntf;',
|
|
' inherited GetIntf();',
|
|
' Result:=inherited GetIntf;',
|
|
' Result:=inherited GetIntf();',
|
|
' i:=inherited GetIntf;',
|
|
' i:=inherited GetIntf();',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_InheritedFuncResult',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.GetIntf = function () {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'rtl.createClass($mod, "TMouse", $mod.TObject, function () {',
|
|
' this.GetIntf = function () {',
|
|
' var Result = null;',
|
|
' var i = null;',
|
|
' var $ir = rtl.createIntfRefs();',
|
|
' var $ok = false;',
|
|
' try {',
|
|
' $ir.ref(1, $mod.TObject.GetIntf.apply(this, arguments));',
|
|
' $ir.ref(2, $mod.TObject.GetIntf.call(this));',
|
|
' $ir.ref(3, $mod.TObject.GetIntf.call(this));',
|
|
' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
|
|
' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
|
|
' i = rtl.setIntfL(i, $mod.TObject.GetIntf.call(this), true);',
|
|
' i = rtl.setIntfL(i, $mod.TObject.GetIntf.call(this), true);',
|
|
' $ok = true;',
|
|
' } finally {',
|
|
' $ir.free();',
|
|
' rtl._Release(i);',
|
|
' if (!$ok) rtl._Release(Result);',
|
|
' };',
|
|
' return Result;',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_IsAsTypeCasts;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' end;',
|
|
'procedure DoDefault(i, j: IUnknown; o: TObject);',
|
|
'begin',
|
|
' if i is IUnknown then ;',
|
|
' if o is IUnknown then ;',
|
|
' if i is TObject then ;',
|
|
' i:=j as IUnknown;',
|
|
' i:=o as IUnknown;',
|
|
' o:=j as TObject;',
|
|
' i:=IUnknown(j);',
|
|
' i:=IUnknown(o);',
|
|
' o:=TObject(i);',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_IsAsTypeCasts',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'this.DoDefault = function (i, j, o) {',
|
|
' rtl._AddRef(i);',
|
|
' try {',
|
|
' if ($mod.IUnknown.isPrototypeOf(i)) ;',
|
|
' if (rtl.queryIntfIsT(o, $mod.IUnknown)) ;',
|
|
' if (rtl.intfIsClass(i, $mod.TObject)) ;',
|
|
' i = rtl.setIntfL(i, rtl.as(j, $mod.IUnknown));',
|
|
' i = rtl.setIntfL(i, rtl.queryIntfT(o, $mod.IUnknown), true);',
|
|
' o = rtl.intfAsClass(j, $mod.TObject);',
|
|
' i = rtl.setIntfL(i, j);',
|
|
' i = rtl.setIntfL(i, rtl.queryIntfT(o, $mod.IUnknown), true);',
|
|
' o = rtl.intfToClass(i, $mod.TObject);',
|
|
' } finally {',
|
|
' rtl._Release(i);',
|
|
' };',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_PassAsArg;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' end;',
|
|
'procedure DoIt(v: IUnknown; const j: IUnknown; var k: IUnknown; out l: IUnknown);',
|
|
'var o: TObject;',
|
|
'begin',
|
|
' DoIt(v,v,v,v);',
|
|
' DoIt(o,o,k,k);',
|
|
'end;',
|
|
'procedure DoSome;',
|
|
'var v: IUnknown;',
|
|
'begin',
|
|
' DoIt(v,v,v,v);',
|
|
'end;',
|
|
'var i: IUnknown;',
|
|
'begin',
|
|
' DoIt(i,i,i,i);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_PassAsArg',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'this.DoIt = function (v, j, k, l) {',
|
|
' var o = null;',
|
|
' var $ir = rtl.createIntfRefs();',
|
|
' rtl._AddRef(v);',
|
|
' try {',
|
|
' $mod.DoIt(v, v, {',
|
|
' get: function () {',
|
|
' return v;',
|
|
' },',
|
|
' set: function (w) {',
|
|
' v = rtl.setIntfL(v, w);',
|
|
' }',
|
|
' }, {',
|
|
' get: function () {',
|
|
' return v;',
|
|
' },',
|
|
' set: function (w) {',
|
|
' v = rtl.setIntfL(v, w);',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt($ir.ref(1, rtl.queryIntfT(o, $mod.IUnknown)), $ir.ref(2, rtl.queryIntfT(o, $mod.IUnknown)), k, k);',
|
|
' } finally {',
|
|
' $ir.free();',
|
|
' rtl._Release(v);',
|
|
' };',
|
|
'};',
|
|
'this.DoSome = function () {',
|
|
' var v = null;',
|
|
' try {',
|
|
' $mod.DoIt(v, v, {',
|
|
' get: function () {',
|
|
' return v;',
|
|
' },',
|
|
' set: function (w) {',
|
|
' v = rtl.setIntfL(v, w);',
|
|
' }',
|
|
' }, {',
|
|
' get: function () {',
|
|
' return v;',
|
|
' },',
|
|
' set: function (w) {',
|
|
' v = rtl.setIntfL(v, w);',
|
|
' }',
|
|
' });',
|
|
' } finally {',
|
|
' rtl._Release(v);',
|
|
' };',
|
|
'};',
|
|
'this.i = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt($mod.i, $mod.i, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' rtl.setIntfP(this.p, "i", v);',
|
|
' }',
|
|
'}, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' rtl.setIntfP(this.p, "i", v);',
|
|
' }',
|
|
'});',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_PassToUntypedParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' end;',
|
|
'procedure DoIt(out i);',
|
|
'begin end;',
|
|
'procedure DoSome;',
|
|
'var v: IUnknown;',
|
|
'begin',
|
|
' DoIt(v);',
|
|
'end;',
|
|
'function GetIt: IUnknown;',
|
|
'begin',
|
|
' DoIt(Result);',
|
|
'end;',
|
|
'var i: IUnknown;',
|
|
'begin',
|
|
' DoIt(i);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_PassToUntypedParam',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'this.DoIt = function (i) {',
|
|
'};',
|
|
'this.DoSome = function () {',
|
|
' var v = null;',
|
|
' try {',
|
|
' $mod.DoIt({',
|
|
' get: function () {',
|
|
' return v;',
|
|
' },',
|
|
' set: function (w) {',
|
|
' v = w;',
|
|
' }',
|
|
' });',
|
|
' } finally {',
|
|
' rtl._Release(v);',
|
|
' };',
|
|
'};',
|
|
'this.GetIt = function () {',
|
|
' var Result = null;',
|
|
' var $ok = false;',
|
|
' try {',
|
|
' $mod.DoIt({',
|
|
' get: function () {',
|
|
' return Result;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' Result = v;',
|
|
' }',
|
|
' });',
|
|
' $ok = true;',
|
|
' } finally {',
|
|
' if (!$ok) rtl._Release(Result);',
|
|
' };',
|
|
' return Result;',
|
|
'};',
|
|
'this.i = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'try {',
|
|
' $mod.DoIt({',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
' });',
|
|
'} finally {',
|
|
' rtl._Release($mod.i);',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_FunctionInExpr;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' end;',
|
|
'function GetIt: IUnknown;',
|
|
'begin',
|
|
'end;',
|
|
'procedure DoSome;',
|
|
'var v: IUnknown;',
|
|
' i: longint;',
|
|
'begin',
|
|
' v:=GetIt;',
|
|
' v:=GetIt();',
|
|
' GetIt()._AddRef;',
|
|
' i:=GetIt()._AddRef;',
|
|
'end;',
|
|
'var v: IUnknown;',
|
|
' i: longint;',
|
|
'begin',
|
|
' v:=GetIt;',
|
|
' v:=GetIt();',
|
|
' GetIt()._AddRef;',
|
|
' i:=GetIt()._AddRef;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_FunctionInExpr',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'this.GetIt = function () {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
'};',
|
|
'this.DoSome = function () {',
|
|
' var v = null;',
|
|
' var i = 0;',
|
|
' var $ir = rtl.createIntfRefs();',
|
|
' try {',
|
|
' v = rtl.setIntfL(v, $mod.GetIt(), true);',
|
|
' v = rtl.setIntfL(v, $mod.GetIt(), true);',
|
|
' $ir.ref(1, $mod.GetIt())._AddRef();',
|
|
' i = $ir.ref(2, $mod.GetIt())._AddRef();',
|
|
' } finally {',
|
|
' $ir.free();',
|
|
' rtl._Release(v);',
|
|
' };',
|
|
'};',
|
|
'this.v = null;',
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'var $ir = rtl.createIntfRefs();',
|
|
'try {',
|
|
' rtl.setIntfP($mod, "v", $mod.GetIt(), true);',
|
|
' rtl.setIntfP($mod, "v", $mod.GetIt(), true);',
|
|
' $ir.ref(1, $mod.GetIt())._AddRef();',
|
|
' $mod.i = $ir.ref(2, $mod.GetIt())._AddRef();',
|
|
'} finally {',
|
|
' $ir.free();',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_Property;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' FAnt: IUnknown;',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' function GetBird: IUnknown; virtual; abstract;',
|
|
' procedure SetBird(Value: IUnknown); virtual; abstract;',
|
|
' function GetItems(Index: longint): IUnknown; virtual; abstract;',
|
|
' procedure SetItems(Index: longint; Value: IUnknown); virtual; abstract;',
|
|
' property Ant: IUnknown read FAnt write FAnt;',
|
|
' property Bird: IUnknown read GetBird write SetBird;',
|
|
' property Items[Index: longint]: IUnknown read GetItems write SetItems; default;',
|
|
' end;',
|
|
'procedure DoIt;',
|
|
'var',
|
|
' o: TObject;',
|
|
' v: IUnknown;',
|
|
'begin',
|
|
' v:=o.Ant;',
|
|
' o.Ant:=v;',
|
|
' o.Ant:=o.Ant;',
|
|
' v:=o.Bird;',
|
|
' o.Bird:=v;',
|
|
' o.Bird:=o.Bird;',
|
|
' v:=o.Items[1];',
|
|
' o.Items[2]:=v;',
|
|
' o.Items[3]:=o.Items[4];',
|
|
' v:=o[5];',
|
|
' o[6]:=v;',
|
|
' o[7]:=o[8];',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_Property',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FAnt = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FAnt = undefined;',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'this.DoIt = function () {',
|
|
' var o = null;',
|
|
' var v = null;',
|
|
' var $ir = rtl.createIntfRefs();',
|
|
' try {',
|
|
' v = rtl.setIntfL(v, o.FAnt);',
|
|
' rtl.setIntfP(o, "FAnt", v);',
|
|
' rtl.setIntfP(o, "FAnt", o.FAnt);',
|
|
' v = rtl.setIntfL(v, o.GetBird(), true);',
|
|
' o.SetBird(v);',
|
|
' o.SetBird($ir.ref(1, o.GetBird()));',
|
|
' v = rtl.setIntfL(v, o.GetItems(1), true);',
|
|
' o.SetItems(2, v);',
|
|
' o.SetItems(3, $ir.ref(2, o.GetItems(4)));',
|
|
' v = rtl.setIntfL(v, o.GetItems(5), true);',
|
|
' o.SetItems(6, v);',
|
|
' o.SetItems(7, $ir.ref(3, o.GetItems(8)));',
|
|
' } finally {',
|
|
' $ir.free();',
|
|
' rtl._Release(v);',
|
|
' };',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_IntfProperty;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' function GetBird: IUnknown;',
|
|
' procedure SetBird(Value: IUnknown);',
|
|
' function GetItems(Index: longint): IUnknown;',
|
|
' procedure SetItems(Index: longint; Value: IUnknown);',
|
|
' property Bird: IUnknown read GetBird write SetBird;',
|
|
' property Items[Index: longint]: IUnknown read GetItems write SetItems; default;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' function GetBird: IUnknown; virtual; abstract;',
|
|
' procedure SetBird(Value: IUnknown); virtual; abstract;',
|
|
' function GetItems(Index: longint): IUnknown; virtual; abstract;',
|
|
' procedure SetItems(Index: longint; Value: IUnknown); virtual; abstract;',
|
|
' end;',
|
|
'procedure DoIt;',
|
|
'var',
|
|
' o: TObject;',
|
|
' v: IUnknown;',
|
|
'begin',
|
|
' v:=v.Items[1];',
|
|
' v.Items[2]:=v;',
|
|
' v.Items[3]:=v.Items[4];',
|
|
' v:=v[5];',
|
|
' v[6]:=v;',
|
|
' v[7]:=v[8];',
|
|
' v[9].Bird.Bird:=v;',
|
|
' v:=v.Bird[10].Bird',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_IntfProperty',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{385F5482-571B-338C-8130-4E97F330543B}", [',
|
|
' "_AddRef",',
|
|
' "_Release",',
|
|
' "GetBird",',
|
|
' "SetBird",',
|
|
' "GetItems",',
|
|
' "SetItems"',
|
|
'], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'this.DoIt = function () {',
|
|
' var o = null;',
|
|
' var v = null;',
|
|
' var $ir = rtl.createIntfRefs();',
|
|
' try {',
|
|
' v = rtl.setIntfL(v, v.GetItems(1), true);',
|
|
' v.SetItems(2, v);',
|
|
' v.SetItems(3, $ir.ref(1, v.GetItems(4)));',
|
|
' v = rtl.setIntfL(v, v.GetItems(5), true);',
|
|
' v.SetItems(6, v);',
|
|
' v.SetItems(7, $ir.ref(2, v.GetItems(8)));',
|
|
' $ir.ref(4, $ir.ref(3, v.GetItems(9)).GetBird()).SetBird(v);',
|
|
' v = rtl.setIntfL(v, $ir.ref(6, v.$ir.ref(5, GetBird()).GetItems(10)).GetBird(), true);',
|
|
' } finally {',
|
|
' $ir.free();',
|
|
' rtl._Release(v);',
|
|
' };',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_Delegation;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' IBird = interface(IUnknown)',
|
|
' procedure Fly(s: string);',
|
|
' end;',
|
|
' IEagle = interface(IBird) end;',
|
|
' IDove = interface(IBird) end;',
|
|
' ISwallow = interface(IBird) end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' procedure Fly(s: string); virtual; abstract;',
|
|
' end;',
|
|
' TBat = class(IBird,IEagle,IDove,ISwallow)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' FBirdIntf: IBird;',
|
|
' property BirdIntf: IBird read FBirdIntf implements IBird;',
|
|
' function GetEagleIntf: IEagle; virtual; abstract;',
|
|
' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
|
|
' FDoveObj: TBird;',
|
|
' property DoveObj: TBird read FDoveObj implements IDove;',
|
|
' function GetSwallowObj: TBird; virtual; abstract;',
|
|
' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
|
|
' end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_Delegation',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
|
|
'rtl.createInterface($mod, "IBird", "{CC440C7F-7623-3DEE-AE88-000B86AAF108}", ["Fly"], $mod.IUnknown);',
|
|
'rtl.createInterface($mod, "IEagle", "{4B6A41C9-B020-3D7C-B688-96D19022B1B4}", [], $mod.IBird);',
|
|
'rtl.createInterface($mod, "IDove", "{4B6A41C9-B020-3D7C-B688-96D18EF16074}", [], $mod.IBird);',
|
|
'rtl.createInterface($mod, "ISwallow", "{BB6A41C9-B020-3D7C-B688-96D1CBDCB359}", [], $mod.IBird);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' rtl.addIntf(this, $mod.IBird);',
|
|
' rtl.addIntf(this, $mod.IEagle);',
|
|
' rtl.addIntf(this, $mod.IDove);',
|
|
' rtl.addIntf(this, $mod.ISwallow);',
|
|
'});',
|
|
'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.FBirdIntf = null;',
|
|
' this.FDoveObj = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FBirdIntf = undefined;',
|
|
' this.FDoveObj = undefined;',
|
|
' $mod.TObject.$final.call(this);',
|
|
' };',
|
|
' this.$intfmaps = {',
|
|
' "{CC440C7F-7623-3DEE-AE88-000B86AAF108}": function () {',
|
|
' return rtl._AddRef(this.FBirdIntf);',
|
|
' },',
|
|
' "{4B6A41C9-B020-3D7C-B688-96D19022B1B4}": function () {',
|
|
' return this.GetEagleIntf();',
|
|
' },',
|
|
' "{4B6A41C9-B020-3D7C-B688-96D18EF16074}": function () {',
|
|
' return rtl.queryIntfT(this.FDoveObj, $mod.IDove);',
|
|
' },',
|
|
' "{BB6A41C9-B020-3D7C-B688-96D1CBDCB359}": function () {',
|
|
' return rtl.queryIntfT(this.GetSwallowObj(), $mod.ISwallow);',
|
|
' }',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_With;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' function GetAnt: IUnknown;',
|
|
' property Ant: IUnknown read GetAnt;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint; virtual; abstract;',
|
|
' function _Release: longint; virtual; abstract;',
|
|
' function GetAnt: IUnknown; virtual; abstract;',
|
|
' property Ant: IUnknown read GetAnt;',
|
|
' end;',
|
|
'procedure DoIt;',
|
|
'var',
|
|
' i: IUnknown;',
|
|
'begin',
|
|
' with i do ',
|
|
' GetAnt;',
|
|
' with i.Ant, Ant do ',
|
|
' GetAnt;',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_With',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{D7ADB00D-C6B6-39FB-BDDF-21CD521DDFA9}", ["_AddRef", "_Release", "GetAnt"], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' rtl.addIntf(this, $mod.IUnknown);',
|
|
'});',
|
|
'this.DoIt = function () {',
|
|
' var i = null;',
|
|
' var $ir = rtl.createIntfRefs();',
|
|
' try {',
|
|
' $ir.ref(1, i.GetAnt());',
|
|
' var $with1 = $ir.ref(2, i.GetAnt());',
|
|
' var $with2 = $ir.ref(3, $with1.GetAnt());',
|
|
' $ir.ref(4, $with2.GetAnt());',
|
|
' } finally {',
|
|
' $ir.free();',
|
|
' };',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_ForIn;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface end;',
|
|
' TObject = class',
|
|
' Id: longint;',
|
|
' end;',
|
|
' IEnumerator = interface(IUnknown)',
|
|
' function GetCurrent: TObject;',
|
|
' function MoveNext: Boolean;',
|
|
' property Current: TObject read GetCurrent;',
|
|
' end;',
|
|
' IEnumerable = interface(IUnknown)',
|
|
' function GetEnumerator: IEnumerator;',
|
|
' end;',
|
|
'var',
|
|
' o: TObject;',
|
|
' i: IEnumerable;',
|
|
'begin',
|
|
' for o in i do o.Id:=3;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_COM_ForIn',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.Id = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createInterface($mod, "IEnumerator", "{95D7745D-ED61-3F13-BBE4-07708161999E}", ["GetCurrent", "MoveNext"], $mod.IUnknown);',
|
|
'rtl.createInterface($mod, "IEnumerable", "{8CC9D45D-ED7D-3B73-96B6-290B931BB19E}", ["GetEnumerator"], $mod.IUnknown);',
|
|
'this.o = null;',
|
|
'this.i = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'var $in1 = $mod.i.GetEnumerator();',
|
|
'try {',
|
|
' while ($in1.MoveNext()) {',
|
|
' $mod.o = $in1.GetCurrent();',
|
|
' $mod.o.Id = 3;',
|
|
' }',
|
|
'} finally {',
|
|
' rtl._Release($in1)',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_ArrayOfIntfFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TArrOfIntf = array of IUnknown;',
|
|
'begin',
|
|
'']);
|
|
SetExpectedPasResolverError('Not supported: array of COM-interface',nNotSupportedX);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_RecordIntfFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' function _Release: longint;',
|
|
' end;',
|
|
' TRec = record',
|
|
' i: IUnknown;',
|
|
' end;',
|
|
'begin',
|
|
'']);
|
|
SetExpectedPasResolverError('Not supported: COM-interface as record member',nNotSupportedX);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_COM_UnitInitialization;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'interface',
|
|
'implementation',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' function _AddRef: longint;',
|
|
' end;',
|
|
' TObject = class(IUnknown)',
|
|
' function _AddRef: longint;',
|
|
' end;',
|
|
'function TObject._AddRef: longint; begin end;',
|
|
'var i: IUnknown;',
|
|
' o: TObject;',
|
|
'initialization',
|
|
' i:=nil;',
|
|
' i:=i;',
|
|
' i:=o;',
|
|
' if (o as IUnknown)=nil then ;',
|
|
'']);
|
|
ConvertUnit;
|
|
CheckSource('TestClassInterface_COM_UnitInitialization',
|
|
LinesToStr([ // statements
|
|
'var $impl = $mod.$impl;',
|
|
'']),
|
|
LinesToStr([ // this.$init
|
|
'var $ir = rtl.createIntfRefs();',
|
|
'try {',
|
|
' rtl.setIntfP($impl, "i", null);',
|
|
' rtl.setIntfP($impl, "i", $impl.i);',
|
|
' rtl.setIntfP($impl, "i", rtl.queryIntfT($impl.o, $impl.IUnknown), true);',
|
|
' if ($ir.ref(1, rtl.queryIntfT($impl.o, $impl.IUnknown)) === null) ;',
|
|
'} finally {',
|
|
' $ir.free();',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // implementation
|
|
'rtl.createInterface($impl, "IUnknown", "{B92D5841-758A-322B-BDDF-21CD52180000}", ["_AddRef"], null);',
|
|
'rtl.createClass($impl, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this._AddRef = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
' rtl.addIntf(this, $impl.IUnknown);',
|
|
'});',
|
|
'$impl.i = null;',
|
|
'$impl.o = null;',
|
|
''])
|
|
);
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_GUID;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' [''{f31db68f-3010-D355-4EBA-CDD4EF4A737C}'']',
|
|
' end;',
|
|
' TObject = class end;',
|
|
' TGUID = record D1, D2, D3, D4: word; end;',
|
|
' TAliasGUID = TGUID;',
|
|
' TGUIDString = type string;',
|
|
' TAliasGUIDString = TGUIDString;',
|
|
'procedure DoConstGUIDIt(const g: TAliasGUID); overload;',
|
|
'begin end;',
|
|
'procedure DoDefGUID(g: TAliasGUID); overload;',
|
|
'begin end;',
|
|
'procedure DoStr(const s: TAliasGUIDString); overload;',
|
|
'begin end;',
|
|
'var',
|
|
' i: IUnknown;',
|
|
' g: TAliasGUID = ''{d91c9af4-3C93-420F-A303-BF5BA82BFD23}'';',
|
|
' s: TAliasGUIDString;',
|
|
'begin',
|
|
' DoConstGUIDIt(IUnknown);',
|
|
' DoDefGUID(IUnknown);',
|
|
' DoStr(IUnknown);',
|
|
' DoConstGUIDIt(i);',
|
|
' DoDefGUID(i);',
|
|
' DoStr(i);',
|
|
' DoConstGUIDIt(''{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}'');',
|
|
' DoDefGUID(''{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}'');',
|
|
' DoStr(g);',
|
|
' g:=i;',
|
|
' g:=IUnknown;',
|
|
' g:=''{D91C9AF4-3C93-420F-A303-bf5ba82bfd23}'';',
|
|
' s:=i;',
|
|
' s:=IUnknown;',
|
|
' s:=g;',
|
|
' if g=i then ;',
|
|
' if i=g then ;',
|
|
' if g=IUnknown then ;',
|
|
' if IUnknown=g then ;',
|
|
' if s=i then ;',
|
|
' if i=s then ;',
|
|
' if s=IUnknown then ;',
|
|
' if IUnknown=s then ;',
|
|
' if s=g then ;',
|
|
' if g=s then ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_GUID',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.TGUID = function (s) {',
|
|
' if (s) {',
|
|
' this.D1 = s.D1;',
|
|
' this.D2 = s.D2;',
|
|
' this.D3 = s.D3;',
|
|
' this.D4 = s.D4;',
|
|
' } else {',
|
|
' this.D1 = 0;',
|
|
' this.D2 = 0;',
|
|
' this.D3 = 0;',
|
|
' this.D4 = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.D1 === b.D1) && ((this.D2 === b.D2) && ((this.D3 === b.D3) && (this.D4 === b.D4)));',
|
|
' };',
|
|
'};',
|
|
'this.DoConstGUIDIt = function (g) {',
|
|
'};',
|
|
'this.DoDefGUID = function (g) {',
|
|
'};',
|
|
'this.DoStr = function (s) {',
|
|
'};',
|
|
'this.i = null;',
|
|
'this.g = new $mod.TGUID({',
|
|
' D1: 0xD91C9AF4,',
|
|
' D2: 0x3C93,',
|
|
' D3: 0x420F,',
|
|
' D4: [',
|
|
' 0xA3,',
|
|
' 0x03,',
|
|
' 0xBF,',
|
|
' 0x5B,',
|
|
' 0xA8,',
|
|
' 0x2B,',
|
|
' 0xFD,',
|
|
' 0x23',
|
|
' ]',
|
|
'});',
|
|
'this.s = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoConstGUIDIt(rtl.getIntfGUIDR($mod.IUnknown));',
|
|
'$mod.DoDefGUID(new $mod.TGUID(rtl.getIntfGUIDR($mod.IUnknown)));',
|
|
'$mod.DoStr($mod.IUnknown.$guid);',
|
|
'$mod.DoConstGUIDIt(rtl.getIntfGUIDR($mod.i));',
|
|
'$mod.DoDefGUID(new $mod.TGUID(rtl.getIntfGUIDR($mod.i)));',
|
|
'$mod.DoStr($mod.i.$guid);',
|
|
'$mod.DoConstGUIDIt(rtl.strToGUIDR("{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}"));',
|
|
'$mod.DoDefGUID(rtl.strToGUIDR("{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}"));',
|
|
'$mod.DoStr(rtl.guidrToStr($mod.g));',
|
|
'$mod.g = new $mod.TGUID(rtl.getIntfGUIDR($mod.i));',
|
|
'$mod.g = new $mod.TGUID(rtl.getIntfGUIDR($mod.IUnknown));',
|
|
'$mod.g = new $mod.TGUID({',
|
|
' D1: 0xD91C9AF4,',
|
|
' D2: 0x3C93,',
|
|
' D3: 0x420F,',
|
|
' D4: [',
|
|
' 0xA3,',
|
|
' 0x03,',
|
|
' 0xBF,',
|
|
' 0x5B,',
|
|
' 0xA8,',
|
|
' 0x2B,',
|
|
' 0xFD,',
|
|
' 0x23',
|
|
' ]',
|
|
'});',
|
|
'$mod.s = $mod.i.$guid;',
|
|
'$mod.s = $mod.IUnknown.$guid;',
|
|
'$mod.s = rtl.guidrToStr($mod.g);',
|
|
'if ($mod.g.$equal(rtl.getIntfGUIDR($mod.i))) ;',
|
|
'if ($mod.g.$equal(rtl.getIntfGUIDR($mod.i))) ;',
|
|
'if ($mod.g.$equal(rtl.getIntfGUIDR($mod.IUnknown))) ;',
|
|
'if ($mod.g.$equal(rtl.getIntfGUIDR($mod.IUnknown))) ;',
|
|
'if ($mod.s === $mod.i.$guid) ;',
|
|
'if ($mod.i.$guid === $mod.s) ;',
|
|
'if ($mod.s === $mod.IUnknown.$guid) ;',
|
|
'if ($mod.IUnknown.$guid === $mod.s) ;',
|
|
'if ($mod.g.$equal(rtl.createTGUID($mod.s))) ;',
|
|
'if ($mod.g.$equal(rtl.createTGUID($mod.s))) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestClassInterface_GUIDProperty;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' [''{f31db68f-3010-D355-4EBA-CDD4EF4A737C}'']',
|
|
' end;',
|
|
' TGUID = record D1, D2, D3, D4: word; end;',
|
|
' TAliasGUID = TGUID;',
|
|
' TGUIDString = type string;',
|
|
' TAliasGUIDString = TGUIDString;',
|
|
' TObject = class',
|
|
' function GetG: TAliasGUID; virtual; abstract;',
|
|
' procedure SetG(const Value: TAliasGUID); virtual; abstract;',
|
|
' function GetS: TAliasGUIDString; virtual; abstract;',
|
|
' procedure SetS(const Value: TAliasGUIDString); virtual; abstract;',
|
|
' property g: TAliasGUID read GetG write SetG;',
|
|
' property s: TAliasGUIDString read GetS write SetS;',
|
|
' end;',
|
|
'var o: TObject;',
|
|
'begin',
|
|
' o.g:=IUnknown;',
|
|
' o.g:=''{D91C9AF4-3C93-420F-A303-bf5ba82bfd23}'';',
|
|
' o.s:=IUnknown;',
|
|
' o.s:=o.g;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestClassInterface_GUIDProperty',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface($mod, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
|
|
'this.TGUID = function (s) {',
|
|
' if (s) {',
|
|
' this.D1 = s.D1;',
|
|
' this.D2 = s.D2;',
|
|
' this.D3 = s.D3;',
|
|
' this.D4 = s.D4;',
|
|
' } else {',
|
|
' this.D1 = 0;',
|
|
' this.D2 = 0;',
|
|
' this.D3 = 0;',
|
|
' this.D4 = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.D1 === b.D1) && ((this.D2 === b.D2) && ((this.D3 === b.D3) && (this.D4 === b.D4)));',
|
|
' };',
|
|
'};',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.o.SetG(new $mod.TGUID(rtl.getIntfGUIDR($mod.IUnknown)));',
|
|
'$mod.o.SetG(new $mod.TGUID({',
|
|
' D1: 0xD91C9AF4,',
|
|
' D2: 0x3C93,',
|
|
' D3: 0x420F,',
|
|
' D4: [',
|
|
' 0xA3,',
|
|
' 0x03,',
|
|
' 0xBF,',
|
|
' 0x5B,',
|
|
' 0xA8,',
|
|
' 0x2B,',
|
|
' 0xFD,',
|
|
' 0x23',
|
|
' ]',
|
|
'}));',
|
|
'$mod.o.SetS($mod.IUnknown.$guid);',
|
|
'$mod.o.SetS(rtl.guidrToStr($mod.o.GetG()));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TProcInt = procedure(vI: longint = 1);',
|
|
'procedure DoIt(vJ: longint);',
|
|
'begin end;',
|
|
'var',
|
|
' b: boolean;',
|
|
' vP, vQ: tprocint;',
|
|
'begin',
|
|
' vp:=nil;',
|
|
' vp:=vp;',
|
|
' vp:=@doit;',
|
|
' vp;',
|
|
' vp();',
|
|
' vp(2);',
|
|
' b:=vp=nil;',
|
|
' b:=nil=vp;',
|
|
' b:=vp=vq;',
|
|
' b:=vp=@doit;',
|
|
' b:=@doit=vp;',
|
|
' b:=vp<>nil;',
|
|
' b:=nil<>vp;',
|
|
' b:=vp<>vq;',
|
|
' b:=vp<>@doit;',
|
|
' b:=@doit<>vp;',
|
|
' b:=Assigned(vp);',
|
|
' if Assigned(vp) then ;']);
|
|
ConvertProgram;
|
|
CheckSource('TestProcType',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function(vJ) {',
|
|
'};',
|
|
'this.b = false;',
|
|
'this.vP = null;',
|
|
'this.vQ = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.vP = null;',
|
|
'$mod.vP = $mod.vP;',
|
|
'$mod.vP = $mod.DoIt;',
|
|
'$mod.vP(1);',
|
|
'$mod.vP(1);',
|
|
'$mod.vP(2);',
|
|
'$mod.b = $mod.vP === null;',
|
|
'$mod.b = null === $mod.vP;',
|
|
'$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
|
|
'$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
|
|
'$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
|
|
'$mod.b = $mod.vP !== null;',
|
|
'$mod.b = null !== $mod.vP;',
|
|
'$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
|
|
'$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
|
|
'$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
|
|
'$mod.b = $mod.vP != null;',
|
|
'if ($mod.vP != null) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_Arg;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TProcInt = procedure(vI: longint = 1);',
|
|
'procedure DoIt(vJ: longint); begin end;',
|
|
'procedure DoSome(vP, vQ: TProcInt);',
|
|
'var',
|
|
' b: boolean;',
|
|
'begin',
|
|
' vp:=nil;',
|
|
' vp:=vp;',
|
|
' vp:=@doit;',
|
|
' vp;',
|
|
' vp();',
|
|
' vp(2);',
|
|
' b:=vp=nil;',
|
|
' b:=nil=vp;',
|
|
' b:=vp=vq;',
|
|
' b:=vp=@doit;',
|
|
' b:=@doit=vp;',
|
|
' b:=vp<>nil;',
|
|
' b:=nil<>vp;',
|
|
' b:=vp<>vq;',
|
|
' b:=vp<>@doit;',
|
|
' b:=@doit<>vp;',
|
|
' b:=Assigned(vp);',
|
|
' if Assigned(vp) then ;',
|
|
'end;',
|
|
'begin',
|
|
' DoSome(@DoIt,nil);']);
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_Arg',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function(vJ) {',
|
|
'};',
|
|
'this.DoSome = function(vP, vQ) {',
|
|
' var b = false;',
|
|
' vP = null;',
|
|
' vP = vP;',
|
|
' vP = $mod.DoIt;',
|
|
' vP(1);',
|
|
' vP(1);',
|
|
' vP(2);',
|
|
' b = vP === null;',
|
|
' b = null === vP;',
|
|
' b = rtl.eqCallback(vP,vQ);',
|
|
' b = rtl.eqCallback(vP, $mod.DoIt);',
|
|
' b = rtl.eqCallback($mod.DoIt, vP);',
|
|
' b = vP !== null;',
|
|
' b = null !== vP;',
|
|
' b = !rtl.eqCallback(vP, vQ);',
|
|
' b = !rtl.eqCallback(vP, $mod.DoIt);',
|
|
' b = !rtl.eqCallback($mod.DoIt, vP);',
|
|
' b = vP != null;',
|
|
' if (vP != null) ;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoSome($mod.DoIt,null);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_FunctionFPC;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TFuncInt = function(vA: longint = 1): longint;');
|
|
Add('function DoIt(vI: longint): longint;');
|
|
Add('begin end;');
|
|
Add('var');
|
|
Add(' b: boolean;');
|
|
Add(' vP, vQ: tfuncint;');
|
|
Add('begin');
|
|
Add(' vp:=nil;');
|
|
Add(' vp:=vp;');
|
|
Add(' vp:=@doit;'); // ok in fpc and delphi
|
|
//Add(' vp:=doit;'); // illegal in fpc, ok in delphi
|
|
Add(' vp;'); // ok in fpc and delphi
|
|
Add(' vp();');
|
|
Add(' vp(2);');
|
|
Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
|
|
Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
|
|
//Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
|
|
Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
|
|
Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
|
|
Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
|
|
//Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
|
|
Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
|
|
Add(' b:=Assigned(vp);');
|
|
//Add(' doit(vp);'); // illegal in fpc, ok in delphi
|
|
Add(' doit(vp());'); // ok in fpc and delphi
|
|
Add(' doit(vp(2));'); // ok in fpc and delphi
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_FunctionFPC',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function(vI) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
'};',
|
|
'this.b = false;',
|
|
'this.vP = null;',
|
|
'this.vQ = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.vP = null;',
|
|
'$mod.vP = $mod.vP;',
|
|
'$mod.vP = $mod.DoIt;',
|
|
'$mod.vP(1);',
|
|
'$mod.vP(1);',
|
|
'$mod.vP(2);',
|
|
'$mod.b = $mod.vP === null;',
|
|
'$mod.b = null === $mod.vP;',
|
|
'$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
|
|
'$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
|
|
'$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
|
|
'$mod.b = 4 === $mod.vP(1);',
|
|
'$mod.b = $mod.vP !== null;',
|
|
'$mod.b = null !== $mod.vP;',
|
|
'$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
|
|
'$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
|
|
'$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
|
|
'$mod.b = 6 !== $mod.vP(1);',
|
|
'$mod.b = $mod.vP != null;',
|
|
'$mod.DoIt($mod.vP(1));',
|
|
'$mod.DoIt($mod.vP(2));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_FunctionDelphi;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$mode Delphi}');
|
|
Add('type');
|
|
Add(' TFuncInt = function(vA: longint = 1): longint;');
|
|
Add('function DoIt(vI: longint): longint;');
|
|
Add('begin end;');
|
|
Add('var');
|
|
Add(' b: boolean;');
|
|
Add(' vP, vQ: tfuncint;');
|
|
Add('begin');
|
|
Add(' vp:=nil;');
|
|
Add(' vp:=vp;');
|
|
Add(' vp:=@doit;'); // ok in fpc and delphi
|
|
Add(' vp:=doit;'); // illegal in fpc, ok in delphi
|
|
Add(' vp;'); // ok in fpc and delphi
|
|
Add(' vp();');
|
|
Add(' vp(2);');
|
|
//Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
|
|
//Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
|
|
//Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
|
|
//Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
|
|
Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
|
|
//Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
|
|
//Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
|
|
//Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
|
|
//Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
|
|
Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
|
|
Add(' b:=Assigned(vp);');
|
|
Add(' doit(vp);'); // illegal in fpc, ok in delphi
|
|
Add(' doit(vp());'); // ok in fpc and delphi
|
|
Add(' doit(vp(2));'); // ok in fpc and delphi *)
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_FunctionDelphi',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function(vI) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
'};',
|
|
'this.b = false;',
|
|
'this.vP = null;',
|
|
'this.vQ = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.vP = null;',
|
|
'$mod.vP = $mod.vP;',
|
|
'$mod.vP = $mod.DoIt;',
|
|
'$mod.vP = $mod.DoIt;',
|
|
'$mod.vP(1);',
|
|
'$mod.vP(1);',
|
|
'$mod.vP(2);',
|
|
'$mod.b = $mod.vP(1) === $mod.vQ(1);',
|
|
'$mod.b = $mod.vP(1) === 3;',
|
|
'$mod.b = 4 === $mod.vP(1);',
|
|
'$mod.b = $mod.vP(1) !== $mod.vQ(1);',
|
|
'$mod.b = $mod.vP(1) !== 5;',
|
|
'$mod.b = 6 !== $mod.vP(1);',
|
|
'$mod.b = $mod.vP != null;',
|
|
'$mod.DoIt($mod.vP(1));',
|
|
'$mod.DoIt($mod.vP(1));',
|
|
'$mod.DoIt($mod.vP(2));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_ProcedureDelphi;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$mode Delphi}');
|
|
Add('type');
|
|
Add(' TProc = procedure;');
|
|
Add('procedure DoIt;');
|
|
Add('begin end;');
|
|
Add('var');
|
|
Add(' b: boolean;');
|
|
Add(' vP, vQ: tproc;');
|
|
Add('begin');
|
|
Add(' vp:=nil;');
|
|
Add(' vp:=vp;');
|
|
Add(' vp:=vq;');
|
|
Add(' vp:=@doit;'); // ok in fpc and delphi, Note that in Delphi type of @F is Pointer, while in FPC it is the proc type
|
|
Add(' vp:=doit;'); // illegal in fpc, ok in delphi
|
|
//Add(' vp:=@doit;'); // illegal in fpc, ok in delphi (because Delphi treats @F as Pointer), not supported by resolver
|
|
Add(' vp;'); // ok in fpc and delphi
|
|
Add(' vp();');
|
|
|
|
// equal
|
|
//Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=@@vp=nil;'); // ok in fpc delphi mode, ok in delphi
|
|
//Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=nil=@@vp;'); // ok in fpc delphi mode, ok in delphi
|
|
Add(' b:=@@vp=@@vq;'); // ok in fpc delphi mode, ok in Delphi
|
|
//Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
|
|
//Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=@@vp=@doit;'); // ok in fpc delphi mode, ok in delphi
|
|
//Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=@doit=@@vp;'); // ok in fpc delphi mode, ok in delphi
|
|
|
|
// unequal
|
|
//Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=@@vp<>nil;'); // ok in fpc mode delphi, ok in delphi
|
|
//Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=nil<>@@vp;'); // ok in fpc mode delphi, ok in delphi
|
|
//Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
|
|
Add(' b:=@@vp<>@@vq;'); // ok in fpc mode delphi, ok in delphi
|
|
//Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=@@vp<>@doit;'); // ok in fpc mode delphi, illegal in delphi
|
|
//Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=@doit<>@@vp;'); // ok in fpc mode delphi, illegal in delphi
|
|
|
|
Add(' b:=Assigned(vp);');
|
|
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_ProcedureDelphi',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function() {',
|
|
'};',
|
|
'this.b = false;',
|
|
'this.vP = null;',
|
|
'this.vQ = null;'
|
|
]),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.vP = null;',
|
|
'$mod.vP = $mod.vP;',
|
|
'$mod.vP = $mod.vQ;',
|
|
'$mod.vP = $mod.DoIt;',
|
|
'$mod.vP = $mod.DoIt;',
|
|
'$mod.vP();',
|
|
'$mod.vP();',
|
|
'$mod.b = $mod.vP === null;',
|
|
'$mod.b = null === $mod.vP;',
|
|
'$mod.b = rtl.eqCallback($mod.vP, $mod.vQ);',
|
|
'$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
|
|
'$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
|
|
'$mod.b = $mod.vP !== null;',
|
|
'$mod.b = null !== $mod.vP;',
|
|
'$mod.b = !rtl.eqCallback($mod.vP, $mod.vQ);',
|
|
'$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
|
|
'$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
|
|
'$mod.b = $mod.vP != null;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_AsParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TFuncInt = function(vA: longint = 1): longint;');
|
|
Add('procedure DoIt(vG: tfuncint; const vH: tfuncint; var vI: tfuncint);');
|
|
Add('var vJ: tfuncint;');
|
|
Add('begin');
|
|
Add(' vg:=vg;');
|
|
Add(' vj:=vh;');
|
|
Add(' vi:=vi;');
|
|
Add(' doit(vg,vg,vg);');
|
|
Add(' doit(vh,vh,vj);');
|
|
Add(' doit(vi,vi,vi);');
|
|
Add(' doit(vj,vj,vj);');
|
|
Add('end;');
|
|
Add('var i: tfuncint;');
|
|
Add('begin');
|
|
Add(' doit(i,i,i);');
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_AsParam',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (vG,vH,vI) {',
|
|
' var vJ = null;',
|
|
' vG = vG;',
|
|
' vJ = vH;',
|
|
' vI.set(vI.get());',
|
|
' $mod.DoIt(vG, vG, {',
|
|
' get: function () {',
|
|
' return vG;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vG = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(vH, vH, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
' $mod.DoIt(vI.get(), vI.get(), vI);',
|
|
' $mod.DoIt(vJ, vJ, {',
|
|
' get: function () {',
|
|
' return vJ;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' vJ = v;',
|
|
' }',
|
|
' });',
|
|
'};',
|
|
'this.i = null;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.DoIt($mod.i,$mod.i,{',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});'
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_MethodFPC;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TFuncInt = function(vA: longint = 1): longint of object;');
|
|
Add(' TObject = class');
|
|
Add(' function DoIt(vA: longint = 1): longint;');
|
|
Add(' end;');
|
|
Add('function TObject.DoIt(vA: longint = 1): longint;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' Obj: TObject;');
|
|
Add(' vP: tfuncint;');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add(' vp:=@obj.doit;'); // ok in fpc and delphi
|
|
//Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
|
|
Add(' vp;'); // ok in fpc and delphi
|
|
Add(' vp();');
|
|
Add(' vp(2);');
|
|
Add(' b:=vp=@obj.doit;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=@obj.doit=vp;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
|
|
Add(' b:=@obj.doit<>vp;'); // ok in fpc, illegal in delphi
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_MethodFPC',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (vA) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.vP = null;',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
|
|
'$mod.vP(1);',
|
|
'$mod.vP(1);',
|
|
'$mod.vP(2);',
|
|
'$mod.b = rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.b = rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
|
|
'$mod.b = !rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.b = !rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_MethodDelphi;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$mode delphi}');
|
|
Add('type');
|
|
Add(' TFuncInt = function(vA: longint = 1): longint of object;');
|
|
Add(' TObject = class');
|
|
Add(' function DoIt(vA: longint = 1): longint;');
|
|
Add(' end;');
|
|
Add('function TObject.DoIt(vA: longint = 1): longint;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' Obj: TObject;');
|
|
Add(' vP: tfuncint;');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add(' vp:=@obj.doit;'); // ok in fpc and delphi
|
|
Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
|
|
Add(' vp;'); // ok in fpc and delphi
|
|
Add(' vp();');
|
|
Add(' vp(2);');
|
|
//Add(' b:=vp=@obj.doit;'); // ok in fpc, illegal in delphi
|
|
//Add(' b:=@obj.doit=vp;'); // ok in fpc, illegal in delphi
|
|
//Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
|
|
//Add(' b:=@obj.doit<>vp;'); // ok in fpc, illegal in delphi
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_MethodDelphi',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (vA) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.vP = null;',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
|
|
'$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
|
|
'$mod.vP(1);',
|
|
'$mod.vP(1);',
|
|
'$mod.vP(2);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_PropertyFPC;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TFuncInt = function(vA: longint = 1): longint of object;');
|
|
Add(' TObject = class');
|
|
Add(' FOnFoo: TFuncInt;');
|
|
Add(' function DoIt(vA: longint = 1): longint;');
|
|
Add(' function GetFoo: TFuncInt;');
|
|
Add(' procedure SetFoo(const Value: TFuncInt);');
|
|
Add(' function GetEvents(Index: longint): TFuncInt;');
|
|
Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
|
|
Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
|
|
Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
|
|
Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
|
|
Add(' end;');
|
|
Add('function tobject.doit(va: longint = 1): longint; begin end;');
|
|
Add('function tobject.getfoo: tfuncint; begin end;');
|
|
Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
|
|
Add('function tobject.getevents(index: longint): tfuncint; begin end;');
|
|
Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
|
|
Add('var');
|
|
Add(' Obj: TObject;');
|
|
Add(' vP: tfuncint;');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add(' obj.onfoo:=nil;');
|
|
Add(' obj.onbar:=nil;');
|
|
Add(' obj.events[1]:=nil;');
|
|
Add(' obj.onfoo:=obj.onfoo;');
|
|
Add(' obj.onbar:=obj.onbar;');
|
|
Add(' obj.events[2]:=obj.events[3];');
|
|
Add(' obj.onfoo:=@obj.doit;');
|
|
Add(' obj.onbar:=@obj.doit;');
|
|
Add(' obj.events[4]:=@obj.doit;');
|
|
//Add(' obj.onfoo:=obj.doit;'); // delphi
|
|
//Add(' obj.onbar:=obj.doit;'); // delphi
|
|
//Add(' obj.events[4]:=obj.doit;'); // delphi
|
|
Add(' obj.onfoo;');
|
|
Add(' obj.onbar;');
|
|
//Add(' obj.events[5];'); ToDo in pasresolver
|
|
Add(' obj.onfoo();');
|
|
Add(' obj.onbar();');
|
|
Add(' obj.events[6]();');
|
|
Add(' b:=obj.onfoo=nil;');
|
|
Add(' b:=obj.onbar=nil;');
|
|
Add(' b:=obj.events[7]=nil;');
|
|
Add(' b:=obj.onfoo<>nil;');
|
|
Add(' b:=obj.onbar<>nil;');
|
|
Add(' b:=obj.events[8]<>nil;');
|
|
Add(' b:=obj.onfoo=vp;');
|
|
Add(' b:=obj.onbar=vp;');
|
|
Add(' b:=obj.events[9]=vp;');
|
|
Add(' b:=obj.onfoo=obj.onfoo;');
|
|
Add(' b:=obj.onbar=obj.onfoo;');
|
|
Add(' b:=obj.events[10]=obj.onfoo;');
|
|
Add(' b:=obj.onfoo<>obj.onfoo;');
|
|
Add(' b:=obj.onbar<>obj.onfoo;');
|
|
Add(' b:=obj.events[11]<>obj.onfoo;');
|
|
Add(' b:=obj.onfoo=@obj.doit;');
|
|
Add(' b:=obj.onbar=@obj.doit;');
|
|
Add(' b:=obj.events[12]=@obj.doit;');
|
|
Add(' b:=obj.onfoo<>@obj.doit;');
|
|
Add(' b:=obj.onbar<>@obj.doit;');
|
|
Add(' b:=obj.events[12]<>@obj.doit;');
|
|
Add(' b:=Assigned(obj.onfoo);');
|
|
Add(' b:=Assigned(obj.onbar);');
|
|
Add(' b:=Assigned(obj.events[13]);');
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_PropertyFPC',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FOnFoo = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FOnFoo = undefined;',
|
|
' };',
|
|
' this.DoIt = function (vA) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
'this.GetFoo = function () {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
'};',
|
|
'this.SetFoo = function (Value) {',
|
|
'};',
|
|
'this.GetEvents = function (Index) {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
'};',
|
|
'this.SetEvents = function (Index, Value) {',
|
|
'};',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.vP = null;',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.Obj.FOnFoo = null;',
|
|
'$mod.Obj.SetFoo(null);',
|
|
'$mod.Obj.SetEvents(1, null);',
|
|
'$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
|
|
'$mod.Obj.SetFoo($mod.Obj.GetFoo());',
|
|
'$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
|
|
'$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
|
|
'$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.Obj.FOnFoo(1);',
|
|
'$mod.Obj.GetFoo();',
|
|
'$mod.Obj.FOnFoo(1);',
|
|
'$mod.Obj.GetFoo()(1);',
|
|
'$mod.Obj.GetEvents(6)(1);',
|
|
'$mod.b = $mod.Obj.FOnFoo === null;',
|
|
'$mod.b = $mod.Obj.GetFoo() === null;',
|
|
'$mod.b = $mod.Obj.GetEvents(7) === null;',
|
|
'$mod.b = $mod.Obj.FOnFoo !== null;',
|
|
'$mod.b = $mod.Obj.GetFoo() !== null;',
|
|
'$mod.b = $mod.Obj.GetEvents(8) !== null;',
|
|
'$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.vP);',
|
|
'$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.vP);',
|
|
'$mod.b = rtl.eqCallback($mod.Obj.GetEvents(9), $mod.vP);',
|
|
'$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
|
|
'$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
|
|
'$mod.b = rtl.eqCallback($mod.Obj.GetEvents(10), $mod.Obj.FOnFoo);',
|
|
'$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
|
|
'$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
|
|
'$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(11), $mod.Obj.FOnFoo);',
|
|
'$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.b = rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.b = $mod.Obj.FOnFoo != null;',
|
|
'$mod.b = $mod.Obj.GetFoo() != null;',
|
|
'$mod.b = $mod.Obj.GetEvents(13) != null;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_PropertyDelphi;
|
|
begin
|
|
StartProgram(false);
|
|
Add('{$mode delphi}');
|
|
Add('type');
|
|
Add(' TFuncInt = function(vA: longint = 1): longint of object;');
|
|
Add(' TObject = class');
|
|
Add(' FOnFoo: TFuncInt;');
|
|
Add(' function DoIt(vA: longint = 1): longint;');
|
|
Add(' function GetFoo: TFuncInt;');
|
|
Add(' procedure SetFoo(const Value: TFuncInt);');
|
|
Add(' function GetEvents(Index: longint): TFuncInt;');
|
|
Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
|
|
Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
|
|
Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
|
|
Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
|
|
Add(' end;');
|
|
Add('function tobject.doit(va: longint = 1): longint; begin end;');
|
|
Add('function tobject.getfoo: tfuncint; begin end;');
|
|
Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
|
|
Add('function tobject.getevents(index: longint): tfuncint; begin end;');
|
|
Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
|
|
Add('var');
|
|
Add(' Obj: TObject;');
|
|
Add(' vP: tfuncint;');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add(' obj.onfoo:=nil;');
|
|
Add(' obj.onbar:=nil;');
|
|
Add(' obj.events[1]:=nil;');
|
|
Add(' obj.onfoo:=obj.onfoo;');
|
|
Add(' obj.onbar:=obj.onbar;');
|
|
Add(' obj.events[2]:=obj.events[3];');
|
|
Add(' obj.onfoo:=@obj.doit;');
|
|
Add(' obj.onbar:=@obj.doit;');
|
|
Add(' obj.events[4]:=@obj.doit;');
|
|
Add(' obj.onfoo:=obj.doit;'); // delphi
|
|
Add(' obj.onbar:=obj.doit;'); // delphi
|
|
Add(' obj.events[4]:=obj.doit;'); // delphi
|
|
Add(' obj.onfoo;');
|
|
Add(' obj.onbar;');
|
|
//Add(' obj.events[5];'); ToDo in pasresolver
|
|
Add(' obj.onfoo();');
|
|
Add(' obj.onbar();');
|
|
Add(' obj.events[6]();');
|
|
//Add(' b:=obj.onfoo=nil;'); // fpc
|
|
//Add(' b:=obj.onbar=nil;'); // fpc
|
|
//Add(' b:=obj.events[7]=nil;'); // fpc
|
|
//Add(' b:=obj.onfoo<>nil;'); // fpc
|
|
//Add(' b:=obj.onbar<>nil;'); // fpc
|
|
//Add(' b:=obj.events[8]<>nil;'); // fpc
|
|
Add(' b:=obj.onfoo=vp;');
|
|
Add(' b:=obj.onbar=vp;');
|
|
//Add(' b:=obj.events[9]=vp;'); ToDo in pasresolver
|
|
Add(' b:=obj.onfoo=obj.onfoo;');
|
|
Add(' b:=obj.onbar=obj.onfoo;');
|
|
//Add(' b:=obj.events[10]=obj.onfoo;'); // ToDo in pasresolver
|
|
Add(' b:=obj.onfoo<>obj.onfoo;');
|
|
Add(' b:=obj.onbar<>obj.onfoo;');
|
|
//Add(' b:=obj.events[11]<>obj.onfoo;'); // ToDo in pasresolver
|
|
//Add(' b:=obj.onfoo=@obj.doit;'); // fpc
|
|
//Add(' b:=obj.onbar=@obj.doit;'); // fpc
|
|
//Add(' b:=obj.events[12]=@obj.doit;'); // fpc
|
|
//Add(' b:=obj.onfoo<>@obj.doit;'); // fpc
|
|
//Add(' b:=obj.onbar<>@obj.doit;'); // fpc
|
|
//Add(' b:=obj.events[12]<>@obj.doit;'); // fpc
|
|
Add(' b:=Assigned(obj.onfoo);');
|
|
Add(' b:=Assigned(obj.onbar);');
|
|
Add(' b:=Assigned(obj.events[13]);');
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_PropertyDelphi',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FOnFoo = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FOnFoo = undefined;',
|
|
' };',
|
|
' this.DoIt = function (vA) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
'this.GetFoo = function () {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
'};',
|
|
'this.SetFoo = function (Value) {',
|
|
'};',
|
|
'this.GetEvents = function (Index) {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
'};',
|
|
'this.SetEvents = function (Index, Value) {',
|
|
'};',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.vP = null;',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([
|
|
'$mod.Obj.FOnFoo = null;',
|
|
'$mod.Obj.SetFoo(null);',
|
|
'$mod.Obj.SetEvents(1, null);',
|
|
'$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
|
|
'$mod.Obj.SetFoo($mod.Obj.GetFoo());',
|
|
'$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
|
|
'$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
|
|
'$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
|
|
'$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
|
|
'$mod.Obj.FOnFoo(1);',
|
|
'$mod.Obj.GetFoo();',
|
|
'$mod.Obj.FOnFoo(1);',
|
|
'$mod.Obj.GetFoo()(1);',
|
|
'$mod.Obj.GetEvents(6)(1);',
|
|
'$mod.b = $mod.Obj.FOnFoo(1) === $mod.vP(1);',
|
|
'$mod.b = $mod.Obj.GetFoo() === $mod.vP(1);',
|
|
'$mod.b = $mod.Obj.FOnFoo(1) === $mod.Obj.FOnFoo(1);',
|
|
'$mod.b = $mod.Obj.GetFoo() === $mod.Obj.FOnFoo(1);',
|
|
'$mod.b = $mod.Obj.FOnFoo(1) !== $mod.Obj.FOnFoo(1);',
|
|
'$mod.b = $mod.Obj.GetFoo() !== $mod.Obj.FOnFoo(1);',
|
|
'$mod.b = $mod.Obj.FOnFoo != null;',
|
|
'$mod.b = $mod.Obj.GetFoo() != null;',
|
|
'$mod.b = $mod.Obj.GetEvents(13) != null;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_WithClassInstDoPropertyFPC;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TFuncInt = function(vA: longint = 1): longint of object;');
|
|
Add(' TObject = class');
|
|
Add(' FOnFoo: TFuncInt;');
|
|
Add(' function DoIt(vA: longint = 1): longint;');
|
|
Add(' function GetFoo: TFuncInt;');
|
|
Add(' procedure SetFoo(const Value: TFuncInt);');
|
|
Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
|
|
Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
|
|
Add(' end;');
|
|
Add('function tobject.doit(va: longint = 1): longint; begin end;');
|
|
Add('function tobject.getfoo: tfuncint; begin end;');
|
|
Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
|
|
Add('var');
|
|
Add(' Obj: TObject;');
|
|
Add(' vP: tfuncint;');
|
|
Add(' b: boolean;');
|
|
Add('begin');
|
|
Add('with obj do begin');
|
|
Add(' fonfoo:=nil;');
|
|
Add(' onfoo:=nil;');
|
|
Add(' onbar:=nil;');
|
|
Add(' fonfoo:=fonfoo;');
|
|
Add(' onfoo:=onfoo;');
|
|
Add(' onbar:=onbar;');
|
|
Add(' fonfoo:=@doit;');
|
|
Add(' onfoo:=@doit;');
|
|
Add(' onbar:=@doit;');
|
|
//Add(' fonfoo:=doit;'); // delphi
|
|
//Add(' onfoo:=doit;'); // delphi
|
|
//Add(' onbar:=doit;'); // delphi
|
|
Add(' fonfoo;');
|
|
Add(' onfoo;');
|
|
Add(' onbar;');
|
|
Add(' fonfoo();');
|
|
Add(' onfoo();');
|
|
Add(' onbar();');
|
|
Add(' b:=fonfoo=nil;');
|
|
Add(' b:=onfoo=nil;');
|
|
Add(' b:=onbar=nil;');
|
|
Add(' b:=fonfoo<>nil;');
|
|
Add(' b:=onfoo<>nil;');
|
|
Add(' b:=onbar<>nil;');
|
|
Add(' b:=fonfoo=vp;');
|
|
Add(' b:=onfoo=vp;');
|
|
Add(' b:=onbar=vp;');
|
|
Add(' b:=fonfoo=fonfoo;');
|
|
Add(' b:=onfoo=onfoo;');
|
|
Add(' b:=onbar=onfoo;');
|
|
Add(' b:=fonfoo<>fonfoo;');
|
|
Add(' b:=onfoo<>onfoo;');
|
|
Add(' b:=onbar<>onfoo;');
|
|
Add(' b:=fonfoo=@doit;');
|
|
Add(' b:=onfoo=@doit;');
|
|
Add(' b:=onbar=@doit;');
|
|
Add(' b:=fonfoo<>@doit;');
|
|
Add(' b:=onfoo<>@doit;');
|
|
Add(' b:=onbar<>@doit;');
|
|
Add(' b:=Assigned(fonfoo);');
|
|
Add(' b:=Assigned(onfoo);');
|
|
Add(' b:=Assigned(onbar);');
|
|
Add('end;');
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_WithClassInstDoPropertyFPC',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FOnFoo = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FOnFoo = undefined;',
|
|
' };',
|
|
' this.DoIt = function (vA) {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
' };',
|
|
' this.GetFoo = function () {',
|
|
' var Result = null;',
|
|
' return Result;',
|
|
' };',
|
|
' this.SetFoo = function (Value) {',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.vP = null;',
|
|
'this.b = false;'
|
|
]),
|
|
LinesToStr([
|
|
'var $with1 = $mod.Obj;',
|
|
'$with1.FOnFoo = null;',
|
|
'$with1.FOnFoo = null;',
|
|
'$with1.SetFoo(null);',
|
|
'$with1.FOnFoo = $with1.FOnFoo;',
|
|
'$with1.FOnFoo = $with1.FOnFoo;',
|
|
'$with1.SetFoo($with1.GetFoo());',
|
|
'$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
|
|
'$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
|
|
'$with1.SetFoo(rtl.createCallback($with1, "DoIt"));',
|
|
'$with1.FOnFoo(1);',
|
|
'$with1.FOnFoo(1);',
|
|
'$with1.GetFoo();',
|
|
'$with1.FOnFoo(1);',
|
|
'$with1.FOnFoo(1);',
|
|
'$with1.GetFoo()(1);',
|
|
'$mod.b = $with1.FOnFoo === null;',
|
|
'$mod.b = $with1.FOnFoo === null;',
|
|
'$mod.b = $with1.GetFoo() === null;',
|
|
'$mod.b = $with1.FOnFoo !== null;',
|
|
'$mod.b = $with1.FOnFoo !== null;',
|
|
'$mod.b = $with1.GetFoo() !== null;',
|
|
'$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
|
|
'$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
|
|
'$mod.b = rtl.eqCallback($with1.GetFoo(), $mod.vP);',
|
|
'$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
|
|
'$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
|
|
'$mod.b = rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
|
|
'$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
|
|
'$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
|
|
'$mod.b = !rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
|
|
'$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
|
|
'$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
|
|
'$mod.b = rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
|
|
'$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
|
|
'$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
|
|
'$mod.b = !rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
|
|
'$mod.b = $with1.FOnFoo != null;',
|
|
'$mod.b = $with1.FOnFoo != null;',
|
|
'$mod.b = $with1.GetFoo() != null;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_Nested;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TProcInt = procedure(vI: longint = 1);',
|
|
'procedure DoIt(vJ: longint);',
|
|
'var aProc: TProcInt;',
|
|
' b: boolean;',
|
|
' procedure Sub(vK: longint);',
|
|
' var aSub: TProcInt;',
|
|
' procedure SubSub(vK: longint);',
|
|
' var aSubSub: TProcInt;',
|
|
' begin;',
|
|
' aProc:=@DoIt;',
|
|
' aSub:=@DoIt;',
|
|
' aSubSub:=@DoIt;',
|
|
' aProc:=@Sub;',
|
|
' aSub:=@Sub;',
|
|
' aSubSub:=@Sub;',
|
|
' aProc:=@SubSub;',
|
|
' aSub:=@SubSub;',
|
|
' aSubSub:=@SubSub;',
|
|
' end;',
|
|
' begin;',
|
|
' end;',
|
|
'begin;',
|
|
' aProc:=@Sub;',
|
|
' b:=aProc=@Sub;',
|
|
' b:=@Sub=aProc;',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_Nested',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (vJ) {',
|
|
' var aProc = null;',
|
|
' var b = false;',
|
|
' function Sub(vK) {',
|
|
' var aSub = null;',
|
|
' function SubSub(vK) {',
|
|
' var aSubSub = null;',
|
|
' aProc = $mod.DoIt;',
|
|
' aSub = $mod.DoIt;',
|
|
' aSubSub = $mod.DoIt;',
|
|
' aProc = Sub;',
|
|
' aSub = Sub;',
|
|
' aSubSub = Sub;',
|
|
' aProc = SubSub;',
|
|
' aSub = SubSub;',
|
|
' aSubSub = SubSub;',
|
|
' };',
|
|
' };',
|
|
' aProc = Sub;',
|
|
' b = rtl.eqCallback(aProc, Sub);',
|
|
' b = rtl.eqCallback(Sub, aProc);',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_NestedOfObject;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TProcInt = procedure(vI: longint = 1) of object;',
|
|
' TObject = class',
|
|
' procedure DoIt(vJ: longint);',
|
|
' end;',
|
|
'procedure TObject.DoIt(vJ: longint);',
|
|
'var aProc: TProcInt;',
|
|
' b: boolean;',
|
|
' procedure Sub(vK: longint);',
|
|
' var aSub: TProcInt;',
|
|
' procedure SubSub(vK: longint);',
|
|
' var aSubSub: TProcInt;',
|
|
' begin;',
|
|
' aProc:=@DoIt;',
|
|
' aSub:=@DoIt;',
|
|
' aSubSub:=@DoIt;',
|
|
' aProc:=@Sub;',
|
|
' aSub:=@Sub;',
|
|
' aSubSub:=@Sub;',
|
|
' aProc:=@SubSub;',
|
|
' aSub:=@SubSub;',
|
|
' aSubSub:=@SubSub;',
|
|
' end;',
|
|
' begin;',
|
|
' end;',
|
|
'begin;',
|
|
' aProc:=@Sub;',
|
|
' b:=aProc=@Sub;',
|
|
' b:=@Sub=aProc;',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_Nested',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function (vJ) {',
|
|
' var Self = this;',
|
|
' var aProc = null;',
|
|
' var b = false;',
|
|
' function Sub(vK) {',
|
|
' var aSub = null;',
|
|
' function SubSub(vK) {',
|
|
' var aSubSub = null;',
|
|
' aProc = rtl.createCallback(Self, "DoIt");',
|
|
' aSub = rtl.createCallback(Self, "DoIt");',
|
|
' aSubSub = rtl.createCallback(Self, "DoIt");',
|
|
' aProc = Sub;',
|
|
' aSub = Sub;',
|
|
' aSubSub = Sub;',
|
|
' aProc = SubSub;',
|
|
' aSub = SubSub;',
|
|
' aSubSub = SubSub;',
|
|
' };',
|
|
' };',
|
|
' aProc = Sub;',
|
|
' b = rtl.eqCallback(aProc, Sub);',
|
|
' b = rtl.eqCallback(Sub, aProc);',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_ReferenceToProc;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TProcRef = reference to procedure(i: longint = 0);',
|
|
' TFuncRef = reference to function(i: longint = 0): longint;',
|
|
'var',
|
|
' p: TProcRef;',
|
|
' f: TFuncRef;',
|
|
'procedure DoIt(i: longint);',
|
|
'begin',
|
|
'end;',
|
|
'function GetIt(i: longint): longint;',
|
|
'begin',
|
|
' p:=@DoIt;',
|
|
' f:=@GetIt;',
|
|
' f;',
|
|
' f();',
|
|
' f(1);',
|
|
'end;',
|
|
'begin',
|
|
' p:=@DoIt;',
|
|
' f:=@GetIt;',
|
|
' f;',
|
|
' f();',
|
|
' f(1);',
|
|
' p:=TProcRef(f);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_ReferenceToProc',
|
|
LinesToStr([ // statements
|
|
'this.p = null;',
|
|
'this.f = null;',
|
|
'this.DoIt = function (i) {',
|
|
'};',
|
|
'this.GetIt = function (i) {',
|
|
' var Result = 0;',
|
|
' $mod.p = $mod.DoIt;',
|
|
' $mod.f = $mod.GetIt;',
|
|
' $mod.f(0);',
|
|
' $mod.f(0);',
|
|
' $mod.f(1);',
|
|
' return Result;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.DoIt;',
|
|
'$mod.f = $mod.GetIt;',
|
|
'$mod.f(0);',
|
|
'$mod.f(0);',
|
|
'$mod.f(1);',
|
|
'$mod.p = $mod.f;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_ReferenceToMethod;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TFuncRef = reference to function(i: longint = 5): longint;',
|
|
' TObject = class',
|
|
' function Grow(s: longint): longint;',
|
|
' end;',
|
|
'var',
|
|
' f: tfuncref;',
|
|
'function tobject.grow(s: longint): longint;',
|
|
' function GrowSub(i: longint): longint;',
|
|
' begin',
|
|
' f:=@grow;',
|
|
' f:=@growsub;',
|
|
' end;',
|
|
'begin',
|
|
' f:=@grow;',
|
|
' f:=@growsub;',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_ReferenceToMethod',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.Grow = function (s) {',
|
|
' var Self = this;',
|
|
' var Result = 0;',
|
|
' function GrowSub(i) {',
|
|
' var Result = 0;',
|
|
' $mod.f = rtl.createCallback(Self, "Grow");',
|
|
' $mod.f = GrowSub;',
|
|
' return Result;',
|
|
' };',
|
|
' $mod.f = rtl.createCallback(Self, "Grow");',
|
|
' $mod.f = GrowSub;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.f = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_Typecast;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TNotifyEvent = procedure(Sender: Pointer) of object;',
|
|
' TEvent = procedure of object;',
|
|
' TGetter = function:longint of object;',
|
|
' TProcA = procedure(i: longint);',
|
|
' TFuncB = function(i, j: longint): longint;',
|
|
'procedure DoIt(); varargs; begin end;',
|
|
'var',
|
|
' Notify: tnotifyevent;',
|
|
' Event: tevent;',
|
|
' Getter: tgetter;',
|
|
' ProcA: tproca;',
|
|
' FuncB: tfuncb;',
|
|
' p: pointer;',
|
|
'begin',
|
|
' notify:=tnotifyevent(event);',
|
|
' event:=tevent(event);',
|
|
' event:=tevent(notify);',
|
|
' event:=tevent(getter);',
|
|
' event:=tevent(proca);',
|
|
' proca:=tproca(funcb);',
|
|
' funcb:=tfuncb(funcb);',
|
|
' funcb:=tfuncb(proca);',
|
|
' funcb:=tfuncb(getter);',
|
|
' proca:=tproca(p);',
|
|
' funcb:=tfuncb(p);',
|
|
' getter:=tgetter(p);',
|
|
' p:=pointer(notify);',
|
|
' p:=notify;',
|
|
' p:=pointer(proca);',
|
|
' p:=proca;',
|
|
' p:=pointer(funcb);',
|
|
' p:=funcb;',
|
|
' doit(Pointer(notify),pointer(event),pointer(proca));',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_Typecast',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function () {',
|
|
'};',
|
|
'this.Notify = null;',
|
|
'this.Event = null;',
|
|
'this.Getter = null;',
|
|
'this.ProcA = null;',
|
|
'this.FuncB = null;',
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Notify = $mod.Event;',
|
|
'$mod.Event = $mod.Event;',
|
|
'$mod.Event = $mod.Notify;',
|
|
'$mod.Event = $mod.Getter;',
|
|
'$mod.Event = $mod.ProcA;',
|
|
'$mod.ProcA = $mod.FuncB;',
|
|
'$mod.FuncB = $mod.FuncB;',
|
|
'$mod.FuncB = $mod.ProcA;',
|
|
'$mod.FuncB = $mod.Getter;',
|
|
'$mod.ProcA = $mod.p;',
|
|
'$mod.FuncB = $mod.p;',
|
|
'$mod.Getter = $mod.p;',
|
|
'$mod.p = $mod.Notify;',
|
|
'$mod.p = $mod.Notify;',
|
|
'$mod.p = $mod.ProcA;',
|
|
'$mod.p = $mod.ProcA;',
|
|
'$mod.p = $mod.FuncB;',
|
|
'$mod.p = $mod.FuncB;',
|
|
'$mod.DoIt($mod.Notify, $mod.Event, $mod.ProcA);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_PassProcToUntyped;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEvent = procedure of object;',
|
|
' TFunc = function: longint;',
|
|
'procedure DoIt(); varargs; begin end;',
|
|
'procedure DoSome(const a; var b; p: pointer); begin end;',
|
|
'var',
|
|
' Event: tevent;',
|
|
' Func: TFunc;',
|
|
'begin',
|
|
' doit(event,func);',
|
|
' dosome(event,event,event);',
|
|
' dosome(func,func,func);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_PassProcToUntyped',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function () {',
|
|
'};',
|
|
'this.DoSome = function (a, b, p) {',
|
|
'};',
|
|
'this.Event = null;',
|
|
'this.Func = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt($mod.Event, $mod.Func);',
|
|
'$mod.DoSome($mod.Event, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.Event;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.Event = v;',
|
|
' }',
|
|
'}, $mod.Event);',
|
|
'$mod.DoSome($mod.Func, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.Func;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.Func = v;',
|
|
' }',
|
|
'}, $mod.Func);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestProcType_PassProcToArray;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TFunc = function: longint;',
|
|
' TArrFunc = array of TFunc;',
|
|
'procedure DoIt(Arr: TArrFunc); begin end;',
|
|
'function GetIt: longint; begin end;',
|
|
'var',
|
|
' Func: tfunc;',
|
|
'begin',
|
|
' doit([]);',
|
|
' doit([@GetIt]);',
|
|
' doit([Func]);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestProcType_PassProcToArray',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (Arr) {',
|
|
'};',
|
|
'this.GetIt = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
'};',
|
|
'this.Func = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt([]);',
|
|
'$mod.DoIt([$mod.GetIt]);',
|
|
'$mod.DoIt([$mod.Func]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer;
|
|
begin
|
|
StartProgram(false);
|
|
Add(['type',
|
|
' TObject = class end;',
|
|
' TClass = class of TObject;',
|
|
' TArrInt = array of longint;',
|
|
'const',
|
|
' n = nil;',
|
|
'var',
|
|
' v: jsvalue;',
|
|
' Obj: tobject;',
|
|
' C: tclass;',
|
|
' a: tarrint;',
|
|
' p: Pointer = nil;',
|
|
' s: string;',
|
|
'begin',
|
|
' p:=p;',
|
|
' p:=nil;',
|
|
' if p=nil then;',
|
|
' if nil=p then;',
|
|
' if Assigned(p) then;',
|
|
' p:=Pointer(v);',
|
|
' p:=obj;',
|
|
' p:=c;',
|
|
' p:=a;',
|
|
' p:=tobject;',
|
|
' obj:=TObject(p);',
|
|
' c:=TClass(p);',
|
|
' a:=TArrInt(p);',
|
|
' p:=n;',
|
|
' p:=Pointer(a);',
|
|
' p:=pointer(s);',
|
|
' s:=string(p);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestPointer',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.n = null;',
|
|
'this.v = undefined;',
|
|
'this.Obj = null;',
|
|
'this.C = null;',
|
|
'this.a = [];',
|
|
'this.p = null;',
|
|
'this.s = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.p;',
|
|
'$mod.p = null;',
|
|
'if ($mod.p === null) ;',
|
|
'if (null === $mod.p) ;',
|
|
'if ($mod.p != null) ;',
|
|
'$mod.p = $mod.v;',
|
|
'$mod.p = $mod.Obj;',
|
|
'$mod.p = $mod.C;',
|
|
'$mod.p = $mod.a;',
|
|
'$mod.p = $mod.TObject;',
|
|
'$mod.Obj = $mod.p;',
|
|
'$mod.C = $mod.p;',
|
|
'$mod.a = $mod.p;',
|
|
'$mod.p = null;',
|
|
'$mod.p = $mod.a;',
|
|
'$mod.p = $mod.s;',
|
|
'$mod.s = $mod.p;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_Proc;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' procedure DoIt; virtual; abstract;');
|
|
Add(' end;');
|
|
Add('procedure DoSome; begin end;');
|
|
Add('var');
|
|
Add(' o: TObject;');
|
|
Add(' p: Pointer;');
|
|
Add('begin');
|
|
Add(' p:=@DoSome;');
|
|
Add(' p:=@o.DoIt;');
|
|
ConvertProgram;
|
|
CheckSource('TestPointer_Proc',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.DoSome = function () {',
|
|
'};',
|
|
'this.o = null;',
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.DoSome;',
|
|
'$mod.p = rtl.createCallback($mod.o, "DoIt");',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_AssignRecordFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TRec = record end;');
|
|
Add('var');
|
|
Add(' p: Pointer;');
|
|
Add(' r: TRec;');
|
|
Add('begin');
|
|
Add(' p:=r;');
|
|
SetExpectedPasResolverError('Incompatible types: got "TRec" expected "Pointer"',
|
|
nIncompatibleTypesGotExpected);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_AssignStaticArrayFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TArr = array[boolean] of longint;');
|
|
Add('var');
|
|
Add(' p: Pointer;');
|
|
Add(' a: TArr;');
|
|
Add('begin');
|
|
Add(' p:=a;');
|
|
SetExpectedPasResolverError('Incompatible types: got "TArr" expected "Pointer"',
|
|
nIncompatibleTypesGotExpected);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_TypeCastJSValueToPointer;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure DoIt(args: array of jsvalue); begin end;',
|
|
'procedure DoAll; varargs; begin end;',
|
|
'var',
|
|
' v: jsvalue;',
|
|
'begin',
|
|
' DoIt([pointer(v)]);',
|
|
' DoAll(pointer(v));',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestPointer_TypeCastJSValueToPointer',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (args) {',
|
|
'};',
|
|
'this.DoAll = function () {',
|
|
'};',
|
|
'this.v = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt([$mod.v]);',
|
|
'$mod.DoAll($mod.v);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_NonRecordFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' p = ^longint;',
|
|
'begin',
|
|
'']);
|
|
SetExpectedPasResolverError('Not supported: pointer of Longint',nNotSupportedX);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_AnonymousArgTypeFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure DoIt(p: ^longint); begin end;',
|
|
'begin',
|
|
'']);
|
|
SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_AnonymousVarTypeFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var p: ^longint;',
|
|
'begin',
|
|
'']);
|
|
SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_AnonymousResultTypeFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'function DoIt: ^longint; begin end;',
|
|
'begin',
|
|
'']);
|
|
SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_AddrOperatorFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var i: longint;',
|
|
'begin',
|
|
' if @i=nil then ;',
|
|
'']);
|
|
SetExpectedConverterError('illegal qualifier "@" in front of "i:Longint"',nIllegalQualifierInFrontOf);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_ArrayParamsFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' p: Pointer;',
|
|
'begin',
|
|
' p:=p[1];',
|
|
'']);
|
|
SetExpectedPasResolverError('illegal qualifier "[" after "Pointer"',nIllegalQualifierAfter);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_PointerAddFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' p: Pointer;',
|
|
'begin',
|
|
' p:=p+1;',
|
|
'']);
|
|
SetExpectedPasResolverError('Operator is not overloaded: "Pointer" + "Longint"',nOperatorIsNotOverloadedAOpB);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_IncPointerFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' p: Pointer;',
|
|
'begin',
|
|
' inc(p,1);',
|
|
'']);
|
|
SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Pointer", expected "integer"',
|
|
nIncompatibleTypeArgNo);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_Record;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TRec = record x: longint; end;',
|
|
' PRec = ^TRec;',
|
|
'var',
|
|
' r: TRec;',
|
|
' p: PRec;',
|
|
' q: ^TRec;',
|
|
' Ptr: pointer;',
|
|
'begin',
|
|
' new(p);',
|
|
' p:=@r;',
|
|
' r:=p^;',
|
|
' r.x:=p^.x;',
|
|
' p^.x:=r.x;',
|
|
' if p^.x=3 then ;',
|
|
' if 4=p^.x then ;',
|
|
' dispose(p);',
|
|
' new(q);',
|
|
' dispose(q);',
|
|
' Ptr:=p;',
|
|
' p:=PRec(ptr);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestPointer_Record',
|
|
LinesToStr([ // statements
|
|
'this.TRec = function (s) {',
|
|
' if (s) {',
|
|
' this.x = s.x;',
|
|
' } else {',
|
|
' this.x = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.x === b.x;',
|
|
' };',
|
|
'};',
|
|
'this.r = new $mod.TRec();',
|
|
'this.p = null;',
|
|
'this.q = null;',
|
|
'this.Ptr = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = new $mod.TRec();',
|
|
'$mod.p = $mod.r;',
|
|
'$mod.r = new $mod.TRec($mod.p);',
|
|
'$mod.r.x = $mod.p.x;',
|
|
'$mod.p.x = $mod.r.x;',
|
|
'if ($mod.p.x === 3) ;',
|
|
'if (4 === $mod.p.x) ;',
|
|
'$mod.p = null;',
|
|
'$mod.q = new $mod.TRec();',
|
|
'$mod.q = null;',
|
|
'$mod.Ptr = $mod.p;',
|
|
'$mod.p = $mod.Ptr;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestPointer_RecordArg;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch autoderef}',
|
|
'type',
|
|
' TRec = record x: longint; end;',
|
|
' PRec = ^TRec;',
|
|
'function DoIt(const a: PRec; var b: PRec; out c: PRec): TRec;',
|
|
'begin',
|
|
' a.x:=a.x;',
|
|
' a^.x:=a^.x;',
|
|
' with a^ do',
|
|
' x:=x;',
|
|
'end;',
|
|
'function GetIt(p: PRec): PRec;',
|
|
'begin',
|
|
' p.x:=p.x;',
|
|
' p^.x:=p^.x;',
|
|
' with p^ do',
|
|
' x:=x;',
|
|
'end;',
|
|
'var',
|
|
' r: TRec;',
|
|
' p: PRec;',
|
|
'begin',
|
|
' p:=GetIt(p);',
|
|
' p^:=GetIt(@r)^;',
|
|
' DoIt(p,p,p);',
|
|
' DoIt(@r,p,p);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestPointer_Record',
|
|
LinesToStr([ // statements
|
|
'this.TRec = function (s) {',
|
|
' if (s) {',
|
|
' this.x = s.x;',
|
|
' } else {',
|
|
' this.x = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.x === b.x;',
|
|
' };',
|
|
'};',
|
|
'this.DoIt = function (a, b, c) {',
|
|
' var Result = new $mod.TRec();',
|
|
' a.x = a.x;',
|
|
' a.x = a.x;',
|
|
' a.x = a.x;',
|
|
' return Result;',
|
|
'};',
|
|
'this.GetIt = function (p) {',
|
|
' var Result = null;',
|
|
' p.x = p.x;',
|
|
' p.x = p.x;',
|
|
' p.x = p.x;',
|
|
' return Result;',
|
|
'};',
|
|
'this.r = new $mod.TRec();',
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.GetIt($mod.p);',
|
|
'$mod.p = new $mod.TRec($mod.GetIt($mod.r));',
|
|
'$mod.DoIt($mod.p, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.p;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.p = v;',
|
|
' }',
|
|
'}, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.p;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.p = v;',
|
|
' }',
|
|
'});',
|
|
'$mod.DoIt($mod.r, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.p;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.p = v;',
|
|
' }',
|
|
'}, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.p;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.p = v;',
|
|
' }',
|
|
'});',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_AssignToJSValue;
|
|
begin
|
|
StartProgram(false);
|
|
Add('var');
|
|
Add(' v: jsvalue;');
|
|
Add(' i: longint;');
|
|
Add(' s: string;');
|
|
Add(' b: boolean;');
|
|
Add(' d: double;');
|
|
Add(' p: pointer;');
|
|
Add('begin');
|
|
Add(' v:=v;');
|
|
Add(' v:=1;');
|
|
Add(' v:=i;');
|
|
Add(' v:='''';');
|
|
Add(' v:=''c'';');
|
|
Add(' v:=''foo'';');
|
|
Add(' v:=s;');
|
|
Add(' v:=false;');
|
|
Add(' v:=true;');
|
|
Add(' v:=b;');
|
|
Add(' v:=0.1;');
|
|
Add(' v:=d;');
|
|
Add(' v:=nil;');
|
|
Add(' v:=p;');
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_AssignToJSValue',
|
|
LinesToStr([ // statements
|
|
'this.v = undefined;',
|
|
'this.i = 0;',
|
|
'this.s = "";',
|
|
'this.b = false;',
|
|
'this.d = 0.0;',
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.v = $mod.v;',
|
|
'$mod.v = 1;',
|
|
'$mod.v = $mod.i;',
|
|
'$mod.v = "";',
|
|
'$mod.v = "c";',
|
|
'$mod.v = "foo";',
|
|
'$mod.v = $mod.s;',
|
|
'$mod.v = false;',
|
|
'$mod.v = true;',
|
|
'$mod.v = $mod.b;',
|
|
'$mod.v = 0.1;',
|
|
'$mod.v = $mod.d;',
|
|
'$mod.v = null;',
|
|
'$mod.v = $mod.p;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_TypeCastToBaseType;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TYesNo = boolean;');
|
|
Add(' TFloat = double;');
|
|
Add(' TCaption = string;');
|
|
Add(' TChar = char;');
|
|
Add('var');
|
|
Add(' v: jsvalue;');
|
|
Add(' i: integer;');
|
|
Add(' s: TCaption;');
|
|
Add(' b: TYesNo;');
|
|
Add(' d: TFloat;');
|
|
Add(' c: char;');
|
|
Add('begin');
|
|
Add(' i:=longint(v);');
|
|
Add(' i:=integer(v);');
|
|
Add(' s:=string(v);');
|
|
Add(' s:=TCaption(v);');
|
|
Add(' b:=boolean(v);');
|
|
Add(' b:=TYesNo(v);');
|
|
Add(' d:=double(v);');
|
|
Add(' d:=TFloat(v);');
|
|
Add(' c:=char(v);');
|
|
Add(' c:=TChar(v);');
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_TypeCastToBaseType',
|
|
LinesToStr([ // statements
|
|
'this.v = undefined;',
|
|
'this.i = 0;',
|
|
'this.s = "";',
|
|
'this.b = false;',
|
|
'this.d = 0.0;',
|
|
'this.c = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.i = Math.floor($mod.v);',
|
|
'$mod.i = Math.floor($mod.v);',
|
|
'$mod.s = "" + $mod.v;',
|
|
'$mod.s = "" + $mod.v;',
|
|
'$mod.b = !($mod.v == false);',
|
|
'$mod.b = !($mod.v == false);',
|
|
'$mod.d = rtl.getNumber($mod.v);',
|
|
'$mod.d = rtl.getNumber($mod.v);',
|
|
'$mod.c = rtl.getChar($mod.v);',
|
|
'$mod.c = rtl.getChar($mod.v);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_Equal;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TYesNo = boolean;');
|
|
Add(' TFloat = double;');
|
|
Add(' TCaption = string;');
|
|
Add(' TChar = char;');
|
|
Add(' TMulti = JSValue;');
|
|
Add('var');
|
|
Add(' v: jsvalue;');
|
|
Add(' i: integer;');
|
|
Add(' s: TCaption;');
|
|
Add(' b: TYesNo;');
|
|
Add(' d: TFloat;');
|
|
Add(' c: char;');
|
|
Add(' m: TMulti;');
|
|
Add('begin');
|
|
Add(' b:=v=v;');
|
|
Add(' b:=v<>v;');
|
|
Add(' b:=v=1;');
|
|
Add(' b:=v<>1;');
|
|
Add(' b:=2=v;');
|
|
Add(' b:=2<>v;');
|
|
Add(' b:=v=i;');
|
|
Add(' b:=i=v;');
|
|
Add(' b:=v=nil;');
|
|
Add(' b:=nil=v;');
|
|
Add(' b:=v=false;');
|
|
Add(' b:=true=v;');
|
|
Add(' b:=v=b;');
|
|
Add(' b:=b=v;');
|
|
Add(' b:=v=s;');
|
|
Add(' b:=s=v;');
|
|
Add(' b:=v=''foo'';');
|
|
Add(' b:=''''=v;');
|
|
Add(' b:=v=d;');
|
|
Add(' b:=d=v;');
|
|
Add(' b:=v=3.4;');
|
|
Add(' b:=5.6=v;');
|
|
Add(' b:=v=c;');
|
|
Add(' b:=c=v;');
|
|
Add(' b:=m=m;');
|
|
Add(' b:=v=m;');
|
|
Add(' b:=m=v;');
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_Equal',
|
|
LinesToStr([ // statements
|
|
'this.v = undefined;',
|
|
'this.i = 0;',
|
|
'this.s = "";',
|
|
'this.b = false;',
|
|
'this.d = 0.0;',
|
|
'this.c = "";',
|
|
'this.m = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.b = $mod.v == $mod.v;',
|
|
'$mod.b = $mod.v != $mod.v;',
|
|
'$mod.b = $mod.v == 1;',
|
|
'$mod.b = $mod.v != 1;',
|
|
'$mod.b = 2 == $mod.v;',
|
|
'$mod.b = 2 != $mod.v;',
|
|
'$mod.b = $mod.v == $mod.i;',
|
|
'$mod.b = $mod.i == $mod.v;',
|
|
'$mod.b = $mod.v == null;',
|
|
'$mod.b = null == $mod.v;',
|
|
'$mod.b = $mod.v == false;',
|
|
'$mod.b = true == $mod.v;',
|
|
'$mod.b = $mod.v == $mod.b;',
|
|
'$mod.b = $mod.b == $mod.v;',
|
|
'$mod.b = $mod.v == $mod.s;',
|
|
'$mod.b = $mod.s == $mod.v;',
|
|
'$mod.b = $mod.v == "foo";',
|
|
'$mod.b = "" == $mod.v;',
|
|
'$mod.b = $mod.v == $mod.d;',
|
|
'$mod.b = $mod.d == $mod.v;',
|
|
'$mod.b = $mod.v == 3.4;',
|
|
'$mod.b = 5.6 == $mod.v;',
|
|
'$mod.b = $mod.v == $mod.c;',
|
|
'$mod.b = $mod.c == $mod.v;',
|
|
'$mod.b = $mod.m == $mod.m;',
|
|
'$mod.b = $mod.v == $mod.m;',
|
|
'$mod.b = $mod.m == $mod.v;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_If;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' v: jsvalue;',
|
|
'begin',
|
|
' if v then ;',
|
|
' while v do ;',
|
|
' repeat until v;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_If',
|
|
LinesToStr([ // statements
|
|
'this.v = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'if ($mod.v) ;',
|
|
'while($mod.v){',
|
|
'};',
|
|
'do{',
|
|
'} while(!$mod.v);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_Not;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' v: jsvalue;',
|
|
' b: boolean;',
|
|
'begin',
|
|
' b:=not v;',
|
|
' if not v then ;',
|
|
' while not v do ;',
|
|
' repeat until not v;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_If',
|
|
LinesToStr([ // statements
|
|
'this.v = undefined;',
|
|
'this.b = false;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.b=!$mod.v;',
|
|
'if (!$mod.v) ;',
|
|
'while(!$mod.v){',
|
|
'};',
|
|
'do{',
|
|
'} while($mod.v);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_Enum;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TColor = (red, blue);');
|
|
Add(' TRedBlue = TColor;');
|
|
Add('var');
|
|
Add(' v: jsvalue;');
|
|
Add(' e: TColor;');
|
|
Add('begin');
|
|
Add(' v:=e;');
|
|
Add(' v:=TColor(e);');
|
|
Add(' v:=TRedBlue(e);');
|
|
Add(' e:=TColor(v);');
|
|
Add(' e:=TRedBlue(v);');
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_Enum',
|
|
LinesToStr([ // statements
|
|
'this.TColor = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "blue",',
|
|
' blue: 1',
|
|
'};',
|
|
'this.v = undefined;',
|
|
'this.e = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.v = $mod.e;',
|
|
'$mod.v = $mod.e;',
|
|
'$mod.v = $mod.e;',
|
|
'$mod.e = $mod.v;',
|
|
'$mod.e = $mod.v;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_ClassInstance;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBirdObject = TObject;',
|
|
'var',
|
|
' v: jsvalue;',
|
|
' o: TObject;',
|
|
'begin',
|
|
' v:=o;',
|
|
' v:=TObject(o);',
|
|
' v:=TBirdObject(o);',
|
|
' o:=TObject(v);',
|
|
' o:=TBirdObject(v);',
|
|
' if v is TObject then ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_ClassInstance',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.v = undefined;',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.v = $mod.o;',
|
|
'$mod.v = $mod.o;',
|
|
'$mod.v = $mod.o;',
|
|
'$mod.o = rtl.getObject($mod.v);',
|
|
'$mod.o = rtl.getObject($mod.v);',
|
|
'if (rtl.isExt($mod.v, $mod.TObject, 1)) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_ClassOf;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TClass = class of TObject;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBirds = class of TBird;',
|
|
' TBird = class(TObject) end;',
|
|
'var',
|
|
' v: jsvalue;',
|
|
' c: TClass;',
|
|
'begin',
|
|
' v:=c;',
|
|
' v:=TObject;',
|
|
' v:=TClass(c);',
|
|
' v:=TBirds(c);',
|
|
' c:=TClass(v);',
|
|
' c:=TBirds(v);',
|
|
' if v is TClass then ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_ClassOf',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
'});',
|
|
'this.v = undefined;',
|
|
'this.c = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.v = $mod.c;',
|
|
'$mod.v = $mod.TObject;',
|
|
'$mod.v = $mod.c;',
|
|
'$mod.v = $mod.c;',
|
|
'$mod.c = rtl.getObject($mod.v);',
|
|
'$mod.c = rtl.getObject($mod.v);',
|
|
'if (rtl.isExt($mod.v, $mod.TObject, 2)) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_ArrayOfJSValue;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' integer = longint;',
|
|
' TArray = array of JSValue;',
|
|
' TArrgh = tarray;',
|
|
' TArrInt = array of integer;',
|
|
'var',
|
|
' v: jsvalue;',
|
|
' TheArray: tarray = (1,''2'');',
|
|
' Arr: tarrgh;',
|
|
' i: integer;',
|
|
' ArrInt: tarrint;',
|
|
'begin',
|
|
' arr:=thearray;',
|
|
' thearray:=arr;',
|
|
' setlength(arr,2);',
|
|
' setlength(thearray,3);',
|
|
' arr[4]:=v;',
|
|
' arr[5]:=length(thearray);',
|
|
' arr[6]:=nil;',
|
|
' arr[7]:=thearray[8];',
|
|
' arr[low(arr)]:=high(thearray);',
|
|
' arr:=arrint;',
|
|
' arrInt:=tarrint(arr);',
|
|
' if TheArray = nil then ;',
|
|
' if nil = TheArray then ;',
|
|
' if TheArray <> nil then ;',
|
|
' if nil <> TheArray then ;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_ArrayOfJSValue',
|
|
LinesToStr([ // statements
|
|
'this.v = undefined;',
|
|
'this.TheArray = [1, "2"];',
|
|
'this.Arr = [];',
|
|
'this.i = 0;',
|
|
'this.ArrInt = [];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.Arr = $mod.TheArray;',
|
|
'$mod.TheArray = $mod.Arr;',
|
|
'$mod.Arr = rtl.arraySetLength($mod.Arr,undefined,2);',
|
|
'$mod.TheArray = rtl.arraySetLength($mod.TheArray,undefined,3);',
|
|
'$mod.Arr[4] = $mod.v;',
|
|
'$mod.Arr[5] = rtl.length($mod.TheArray);',
|
|
'$mod.Arr[6] = null;',
|
|
'$mod.Arr[7] = $mod.TheArray[8];',
|
|
'$mod.Arr[0] = rtl.length($mod.TheArray) - 1;',
|
|
'$mod.Arr = $mod.ArrInt;',
|
|
'$mod.ArrInt = $mod.Arr;',
|
|
'if (rtl.length($mod.TheArray) === 0) ;',
|
|
'if (rtl.length($mod.TheArray) === 0) ;',
|
|
'if (rtl.length($mod.TheArray) > 0) ;',
|
|
'if (rtl.length($mod.TheArray) > 0) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_ArrayLit;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TFlag = (big,small);',
|
|
' TArray = array of JSValue;',
|
|
' TObject = class end;',
|
|
' TClass = class of TObject;',
|
|
'var',
|
|
' v: jsvalue;',
|
|
' a: TArray;',
|
|
' o: TObject;',
|
|
'begin',
|
|
' a:=[];',
|
|
' a:=[1];',
|
|
' a:=[1,2];',
|
|
' a:=[big];',
|
|
' a:=[1,big];',
|
|
' a:=[o,nil];',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_ArrayLit',
|
|
LinesToStr([ // statements
|
|
'this.TFlag = {',
|
|
' "0": "big",',
|
|
' big: 0,',
|
|
' "1": "small",',
|
|
' small: 1',
|
|
'};',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.v = undefined;',
|
|
'this.a = [];',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.a = [];',
|
|
'$mod.a = [1];',
|
|
'$mod.a = [1, 2];',
|
|
'$mod.a = [$mod.TFlag.big];',
|
|
'$mod.a = [1, $mod.TFlag.big];',
|
|
'$mod.a = [$mod.o, null];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_Params;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TYesNo = boolean;');
|
|
Add(' TFloat = double;');
|
|
Add(' TCaption = string;');
|
|
Add(' TChar = char;');
|
|
Add('function DoIt(a: jsvalue; const b: jsvalue; var c: jsvalue; out d: jsvalue): jsvalue;');
|
|
Add('var');
|
|
Add(' l: jsvalue;');
|
|
Add('begin');
|
|
Add(' a:=a;');
|
|
Add(' l:=b;');
|
|
Add(' c:=c;');
|
|
Add(' d:=d;');
|
|
Add(' Result:=l;');
|
|
Add('end;');
|
|
Add('function DoSome(a: jsvalue; const b: jsvalue): jsvalue; begin end;');
|
|
Add('var');
|
|
Add(' v: jsvalue;');
|
|
Add(' i: integer;');
|
|
Add(' b: TYesNo;');
|
|
Add(' d: TFloat;');
|
|
Add(' s: TCaption;');
|
|
Add(' c: TChar;');
|
|
Add('begin');
|
|
Add(' v:=doit(v,v,v,v);');
|
|
Add(' i:=integer(dosome(i,i));');
|
|
Add(' b:=TYesNo(dosome(b,b));');
|
|
Add(' d:=TFloat(dosome(d,d));');
|
|
Add(' s:=TCaption(dosome(s,s));');
|
|
Add(' c:=TChar(dosome(c,c));');
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_Params',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (a, b, c, d) {',
|
|
' var Result = undefined;',
|
|
' var l = undefined;',
|
|
' a = a;',
|
|
' l = b;',
|
|
' c.set(c.get());',
|
|
' d.set(d.get());',
|
|
' Result = l;',
|
|
' return Result;',
|
|
'};',
|
|
'this.DoSome = function (a, b) {',
|
|
' var Result = undefined;',
|
|
' return Result;',
|
|
'};',
|
|
'this.v = undefined;',
|
|
'this.i = 0;',
|
|
'this.b = false;',
|
|
'this.d = 0.0;',
|
|
'this.s = "";',
|
|
'this.c = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.v = $mod.DoIt($mod.v, $mod.v, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.v;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.v = v;',
|
|
' }',
|
|
'}, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.v;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.v = v;',
|
|
' }',
|
|
'});',
|
|
'$mod.i = Math.floor($mod.DoSome($mod.i, $mod.i));',
|
|
'$mod.b = !($mod.DoSome($mod.b, $mod.b) == false);',
|
|
'$mod.d = rtl.getNumber($mod.DoSome($mod.d, $mod.d));',
|
|
'$mod.s = "" + $mod.DoSome($mod.s, $mod.s);',
|
|
'$mod.c = rtl.getChar($mod.DoSome($mod.c, $mod.c));',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_UntypedParam;
|
|
begin
|
|
StartProgram(false);
|
|
Add('function DoIt(const a; var b; out c): jsvalue;');
|
|
Add('begin');
|
|
Add(' Result:=a;');
|
|
Add(' Result:=b;');
|
|
Add(' Result:=c;');
|
|
Add(' b:=Result;');
|
|
Add(' c:=Result;');
|
|
Add('end;');
|
|
Add('var i: longint;');
|
|
Add('begin');
|
|
Add(' doit(i,i,i);');
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_UntypedParam',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (a, b, c) {',
|
|
' var Result = undefined;',
|
|
' Result = a;',
|
|
' Result = b.get();',
|
|
' Result = c.get();',
|
|
' b.set(Result);',
|
|
' c.set(Result);',
|
|
' return Result;',
|
|
'};',
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt($mod.i, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'}, {',
|
|
' p: $mod,',
|
|
' get: function () {',
|
|
' return this.p.i;',
|
|
' },',
|
|
' set: function (v) {',
|
|
' this.p.i = v;',
|
|
' }',
|
|
'});',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_FuncResultType;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TJSValueArray = array of JSValue;');
|
|
Add(' TListSortCompare = function(Item1, Item2: JSValue): Integer;');
|
|
Add('procedure Sort(P: JSValue; aList: TJSValueArray; const Compare: TListSortCompare);');
|
|
Add('begin');
|
|
Add(' while Compare(P,aList[0])>0 do ;');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' Compare: TListSortCompare;');
|
|
Add(' V: JSValue;');
|
|
Add(' i: integer;');
|
|
Add('begin');
|
|
Add(' if Compare(V,V)>0 then ;');
|
|
Add(' if Compare(i,i)>1 then ;');
|
|
Add(' if Compare(nil,false)>2 then ;');
|
|
Add(' if Compare(1,true)>3 then ;');
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_UntypedParam',
|
|
LinesToStr([ // statements
|
|
'this.Sort = function (P, aList, Compare) {',
|
|
' while (Compare(P, aList[0]) > 0) {',
|
|
' };',
|
|
'};',
|
|
'this.Compare = null;',
|
|
'this.V = undefined;',
|
|
'this.i = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'if ($mod.Compare($mod.V, $mod.V) > 0) ;',
|
|
'if ($mod.Compare($mod.i, $mod.i) > 1) ;',
|
|
'if ($mod.Compare(null, false) > 2) ;',
|
|
'if ($mod.Compare(1, true) > 3) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_ProcType_Assign;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TObject = class');
|
|
Add(' class function GetGlob: integer;');
|
|
Add(' function Getter: integer;');
|
|
Add(' end;');
|
|
Add('class function TObject.GetGlob: integer;');
|
|
Add('var v1: jsvalue;');
|
|
Add('begin');
|
|
Add(' v1:=@GetGlob;');
|
|
Add(' v1:=@Self.GetGlob;');
|
|
Add('end;');
|
|
Add('function TObject.Getter: integer;');
|
|
Add('var v2: jsvalue;');
|
|
Add('begin');
|
|
Add(' v2:=@Getter;');
|
|
Add(' v2:=@Self.Getter;');
|
|
Add(' v2:=@GetGlob;');
|
|
Add(' v2:=@Self.GetGlob;');
|
|
Add('end;');
|
|
Add('function GetIt(i: integer): integer;');
|
|
Add('var v3: jsvalue;');
|
|
Add('begin');
|
|
Add(' v3:=@GetIt;');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' V: JSValue;');
|
|
Add(' o: TObject;');
|
|
Add('begin');
|
|
Add(' v:=@GetIt;');
|
|
Add(' v:=@o.Getter;');
|
|
Add(' v:=@o.GetGlob;');
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_ProcType_Assign',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.GetGlob = function () {',
|
|
' var Result = 0;',
|
|
' var v1 = undefined;',
|
|
' v1 = rtl.createCallback(this, "GetGlob");',
|
|
' v1 = rtl.createCallback(this, "GetGlob");',
|
|
' return Result;',
|
|
' };',
|
|
' this.Getter = function () {',
|
|
' var Result = 0;',
|
|
' var v2 = undefined;',
|
|
' v2 = rtl.createCallback(this, "Getter");',
|
|
' v2 = rtl.createCallback(this, "Getter");',
|
|
' v2 = rtl.createCallback(this.$class, "GetGlob");',
|
|
' v2 = rtl.createCallback(this.$class, "GetGlob");',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.GetIt = function (i) {',
|
|
' var Result = 0;',
|
|
' var v3 = undefined;',
|
|
' v3 = $mod.GetIt;',
|
|
' return Result;',
|
|
'};',
|
|
'this.V = undefined;',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.V = $mod.GetIt;',
|
|
'$mod.V = rtl.createCallback($mod.o, "Getter");',
|
|
'$mod.V = rtl.createCallback($mod.o.$class, "GetGlob");',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_ProcType_Equal;
|
|
begin
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TObject = class');
|
|
Add(' class function GetGlob: integer;');
|
|
Add(' function Getter: integer;');
|
|
Add(' end;');
|
|
Add('class function TObject.GetGlob: integer;');
|
|
Add('var v1: jsvalue;');
|
|
Add('begin');
|
|
Add(' if v1=@GetGlob then;');
|
|
Add(' if v1=@Self.GetGlob then ;');
|
|
Add('end;');
|
|
Add('function TObject.Getter: integer;');
|
|
Add('var v2: jsvalue;');
|
|
Add('begin');
|
|
Add(' if v2=@Getter then;');
|
|
Add(' if v2=@Self.Getter then ;');
|
|
Add(' if v2=@GetGlob then;');
|
|
Add(' if v2=@Self.GetGlob then;');
|
|
Add('end;');
|
|
Add('function GetIt(i: integer): integer;');
|
|
Add('var v3: jsvalue;');
|
|
Add('begin');
|
|
Add(' if v3=@GetIt then;');
|
|
Add('end;');
|
|
Add('var');
|
|
Add(' V: JSValue;');
|
|
Add(' o: TObject;');
|
|
Add('begin');
|
|
Add(' if v=@GetIt then;');
|
|
Add(' if v=@o.Getter then;');
|
|
Add(' if v=@o.GetGlob then;');
|
|
Add(' if @GetIt=v then;');
|
|
Add(' if @o.Getter=v then;');
|
|
Add(' if @o.GetGlob=v then;');
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_ProcType_Equal',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.GetGlob = function () {',
|
|
' var Result = 0;',
|
|
' var v1 = undefined;',
|
|
' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
|
|
' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
|
|
' return Result;',
|
|
' };',
|
|
' this.Getter = function () {',
|
|
' var Result = 0;',
|
|
' var v2 = undefined;',
|
|
' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
|
|
' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
|
|
' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
|
|
' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.GetIt = function (i) {',
|
|
' var Result = 0;',
|
|
' var v3 = undefined;',
|
|
' if (rtl.eqCallback(v3, $mod.GetIt)) ;',
|
|
' return Result;',
|
|
'};',
|
|
'this.V = undefined;',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'if (rtl.eqCallback($mod.V, $mod.GetIt)) ;',
|
|
'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o, "Getter"))) ;',
|
|
'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o.$class, "GetGlob"))) ;',
|
|
'if (rtl.eqCallback($mod.GetIt, $mod.V)) ;',
|
|
'if (rtl.eqCallback(rtl.createCallback($mod.o, "Getter"), $mod.V)) ;',
|
|
'if (rtl.eqCallback(rtl.createCallback($mod.o.$class, "GetGlob"), $mod.V)) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_ProcType_Param;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' variant = jsvalue;',
|
|
' TArrVariant = array of variant;',
|
|
' TArrVar2 = TArrVariant;',
|
|
' TFuncInt = function: longint;',
|
|
'function GetIt: longint;',
|
|
'begin',
|
|
'end;',
|
|
'procedure DoIt(p: jsvalue; Arr: TArrVar2);',
|
|
'var v: variant;',
|
|
'begin',
|
|
' v:=arr[1];',
|
|
'end;',
|
|
'var s: string;',
|
|
'begin',
|
|
' DoIt(GetIt,[]);',
|
|
' DoIt(@GetIt,[]);',
|
|
' DoIt(1,[s,GetIt]);',
|
|
' DoIt(1,[s,@GetIt]);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_ProcType_Param',
|
|
LinesToStr([ // statements
|
|
'this.GetIt = function () {',
|
|
' var Result = 0;',
|
|
' return Result;',
|
|
'};',
|
|
'this.DoIt = function (p, Arr) {',
|
|
' var v = undefined;',
|
|
' v = Arr[1];',
|
|
'};',
|
|
'this.s = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt($mod.GetIt(), []);',
|
|
'$mod.DoIt($mod.GetIt, []);',
|
|
'$mod.DoIt(1, [$mod.s, $mod.GetIt()]);',
|
|
'$mod.DoIt(1, [$mod.s, $mod.GetIt]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_AssignToPointerFail;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' v: JSValue;',
|
|
' p: Pointer;',
|
|
'begin',
|
|
' p:=v;',
|
|
'']);
|
|
SetExpectedPasResolverError('Incompatible types: got "JSValue" expected "Pointer"',
|
|
nIncompatibleTypesGotExpected);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_OverloadDouble;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' integer = longint;',
|
|
' tdatetime = double;',
|
|
'procedure DoIt(d: double); begin end;',
|
|
'procedure DoIt(v: jsvalue); begin end;',
|
|
'var',
|
|
' d: double;',
|
|
' dt: tdatetime;',
|
|
' i: integer;',
|
|
' b: byte;',
|
|
' shi: shortint;',
|
|
' w: word;',
|
|
' smi: smallint;',
|
|
' lw: longword;',
|
|
' li: longint;',
|
|
' ni: nativeint;',
|
|
' nu: nativeuint;',
|
|
'begin',
|
|
' DoIt(d);',
|
|
' DoIt(dt);',
|
|
' DoIt(i);',
|
|
' DoIt(b);',
|
|
' DoIt(shi);',
|
|
' DoIt(w);',
|
|
' DoIt(smi);',
|
|
' DoIt(lw);',
|
|
' DoIt(li);',
|
|
' DoIt(ni);',
|
|
' DoIt(nu);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_OverloadDouble',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (d) {',
|
|
'};',
|
|
'this.DoIt$1 = function (v) {',
|
|
'};',
|
|
'this.d = 0.0;',
|
|
'this.dt = 0.0;',
|
|
'this.i = 0;',
|
|
'this.b = 0;',
|
|
'this.shi = 0;',
|
|
'this.w = 0;',
|
|
'this.smi = 0;',
|
|
'this.lw = 0;',
|
|
'this.li = 0;',
|
|
'this.ni = 0;',
|
|
'this.nu = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt($mod.d);',
|
|
'$mod.DoIt($mod.dt);',
|
|
'$mod.DoIt$1($mod.i);',
|
|
'$mod.DoIt$1($mod.b);',
|
|
'$mod.DoIt$1($mod.shi);',
|
|
'$mod.DoIt$1($mod.w);',
|
|
'$mod.DoIt$1($mod.smi);',
|
|
'$mod.DoIt$1($mod.lw);',
|
|
'$mod.DoIt$1($mod.li);',
|
|
'$mod.DoIt$1($mod.ni);',
|
|
'$mod.DoIt$1($mod.nu);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_OverloadNativeInt;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' integer = longint;',
|
|
' int53 = nativeint;',
|
|
' tdatetime = double;',
|
|
'procedure DoIt(n: nativeint); begin end;',
|
|
'procedure DoIt(v: jsvalue); begin end;',
|
|
'var',
|
|
' d: double;',
|
|
' dt: tdatetime;',
|
|
' i: integer;',
|
|
' b: byte;',
|
|
' shi: shortint;',
|
|
' w: word;',
|
|
' smi: smallint;',
|
|
' lw: longword;',
|
|
' li: longint;',
|
|
' ni: nativeint;',
|
|
' nu: nativeuint;',
|
|
'begin',
|
|
' DoIt(d);',
|
|
' DoIt(dt);',
|
|
' DoIt(i);',
|
|
' DoIt(b);',
|
|
' DoIt(shi);',
|
|
' DoIt(w);',
|
|
' DoIt(smi);',
|
|
' DoIt(lw);',
|
|
' DoIt(li);',
|
|
' DoIt(ni);',
|
|
' DoIt(nu);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_OverloadNativeInt',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (n) {',
|
|
'};',
|
|
'this.DoIt$1 = function (v) {',
|
|
'};',
|
|
'this.d = 0.0;',
|
|
'this.dt = 0.0;',
|
|
'this.i = 0;',
|
|
'this.b = 0;',
|
|
'this.shi = 0;',
|
|
'this.w = 0;',
|
|
'this.smi = 0;',
|
|
'this.lw = 0;',
|
|
'this.li = 0;',
|
|
'this.ni = 0;',
|
|
'this.nu = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt$1($mod.d);',
|
|
'$mod.DoIt$1($mod.dt);',
|
|
'$mod.DoIt($mod.i);',
|
|
'$mod.DoIt($mod.b);',
|
|
'$mod.DoIt($mod.shi);',
|
|
'$mod.DoIt($mod.w);',
|
|
'$mod.DoIt($mod.smi);',
|
|
'$mod.DoIt($mod.lw);',
|
|
'$mod.DoIt($mod.li);',
|
|
'$mod.DoIt($mod.ni);',
|
|
'$mod.DoIt($mod.nu);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_OverloadWord;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' integer = longint;',
|
|
' int53 = nativeint;',
|
|
' tdatetime = double;',
|
|
'procedure DoIt(w: word); begin end;',
|
|
'procedure DoIt(v: jsvalue); begin end;',
|
|
'var',
|
|
' d: double;',
|
|
' dt: tdatetime;',
|
|
' i: integer;',
|
|
' b: byte;',
|
|
' shi: shortint;',
|
|
' w: word;',
|
|
' smi: smallint;',
|
|
' lw: longword;',
|
|
' li: longint;',
|
|
' ni: nativeint;',
|
|
' nu: nativeuint;',
|
|
'begin',
|
|
' DoIt(d);',
|
|
' DoIt(dt);',
|
|
' DoIt(i);',
|
|
' DoIt(b);',
|
|
' DoIt(shi);',
|
|
' DoIt(w);',
|
|
' DoIt(smi);',
|
|
' DoIt(lw);',
|
|
' DoIt(li);',
|
|
' DoIt(ni);',
|
|
' DoIt(nu);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_OverloadWord',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (w) {',
|
|
'};',
|
|
'this.DoIt$1 = function (v) {',
|
|
'};',
|
|
'this.d = 0.0;',
|
|
'this.dt = 0.0;',
|
|
'this.i = 0;',
|
|
'this.b = 0;',
|
|
'this.shi = 0;',
|
|
'this.w = 0;',
|
|
'this.smi = 0;',
|
|
'this.lw = 0;',
|
|
'this.li = 0;',
|
|
'this.ni = 0;',
|
|
'this.nu = 0;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt$1($mod.d);',
|
|
'$mod.DoIt$1($mod.dt);',
|
|
'$mod.DoIt$1($mod.i);',
|
|
'$mod.DoIt($mod.b);',
|
|
'$mod.DoIt($mod.shi);',
|
|
'$mod.DoIt($mod.w);',
|
|
'$mod.DoIt$1($mod.smi);',
|
|
'$mod.DoIt$1($mod.lw);',
|
|
'$mod.DoIt$1($mod.li);',
|
|
'$mod.DoIt$1($mod.ni);',
|
|
'$mod.DoIt$1($mod.nu);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_OverloadString;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' uni = string;',
|
|
' WChar = char;',
|
|
'procedure DoIt(s: string); begin end;',
|
|
'procedure DoIt(v: jsvalue); begin end;',
|
|
'var',
|
|
' s: string;',
|
|
' c: char;',
|
|
' u: uni;',
|
|
'begin',
|
|
' DoIt(s);',
|
|
' DoIt(c);',
|
|
' DoIt(u);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_OverloadString',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (s) {',
|
|
'};',
|
|
'this.DoIt$1 = function (v) {',
|
|
'};',
|
|
'this.s = "";',
|
|
'this.c = "";',
|
|
'this.u = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt($mod.s);',
|
|
'$mod.DoIt($mod.c);',
|
|
'$mod.DoIt($mod.u);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_OverloadChar;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' uni = string;',
|
|
' WChar = char;',
|
|
'procedure DoIt(c: char); begin end;',
|
|
'procedure DoIt(v: jsvalue); begin end;',
|
|
'var',
|
|
' s: string;',
|
|
' c: char;',
|
|
' u: uni;',
|
|
'begin',
|
|
' DoIt(s);',
|
|
' DoIt(c);',
|
|
' DoIt(u);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_OverloadChar',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function (c) {',
|
|
'};',
|
|
'this.DoIt$1 = function (v) {',
|
|
'};',
|
|
'this.s = "";',
|
|
'this.c = "";',
|
|
'this.u = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt$1($mod.s);',
|
|
'$mod.DoIt($mod.c);',
|
|
'$mod.DoIt$1($mod.u);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_OverloadPointer;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class end;',
|
|
'procedure DoIt(p: pointer); begin end;',
|
|
'procedure DoIt(v: jsvalue); begin end;',
|
|
'var',
|
|
' o: TObject;',
|
|
'begin',
|
|
' DoIt(o);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_OverloadPointer',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.DoIt = function (p) {',
|
|
'};',
|
|
'this.DoIt$1 = function (v) {',
|
|
'};',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt($mod.o);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestJSValue_ForIn;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'var',
|
|
' v: JSValue;',
|
|
' key: string;',
|
|
'begin',
|
|
' for key in v do begin',
|
|
' if key=''abc'' then ;',
|
|
' end;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestJSValue_ForIn',
|
|
LinesToStr([ // statements
|
|
'this.v = undefined;',
|
|
'this.key = "";',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'for ($mod.key in $mod.v) {',
|
|
' if ($mod.key === "abc") ;',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_IntRange;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TTypeInfo = class external name ''rtl.tTypeInfo''',
|
|
' end;',
|
|
' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo)',
|
|
' end;',
|
|
' TGraphicsColor = -$7FFFFFFF-1..$7FFFFFFF;',
|
|
' TColor = type TGraphicsColor;',
|
|
'var',
|
|
' p: TTypeInfo;',
|
|
'begin',
|
|
' p:=typeinfo(TGraphicsColor);',
|
|
' p:=typeinfo(TColor);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_IntRange',
|
|
LinesToStr([ // statements
|
|
'$mod.$rtti.$Int("TGraphicsColor", {',
|
|
' minvalue: -2147483648,',
|
|
' maxvalue: 2147483647,',
|
|
' ordtype: 4',
|
|
'});',
|
|
'$mod.$rtti.$inherited("TColor", $mod.$rtti["TGraphicsColor"], {});',
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.$rtti["TGraphicsColor"];',
|
|
'$mod.p = $mod.$rtti["TColor"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_Double;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TTypeInfo = class external name ''rtl.tTypeInfo''',
|
|
' end;',
|
|
' TFloat = type double;',
|
|
'var',
|
|
' p: TTypeInfo;',
|
|
'begin',
|
|
' p:=typeinfo(double);',
|
|
' p:=typeinfo(TFloat);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Double',
|
|
LinesToStr([ // statements
|
|
'$mod.$rtti.$inherited("TFloat", rtl.double, {});',
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = rtl.double;',
|
|
'$mod.p = $mod.$rtti["TFloat"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_ProcType;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TProcA = procedure;');
|
|
Add(' TMethodB = procedure of object;');
|
|
Add(' TProcC = procedure; varargs;');
|
|
Add(' TProcD = procedure(i: longint; const j: string; var c: char; out d: double);');
|
|
Add(' TProcE = function: nativeint;');
|
|
Add(' TProcF = function(const p: TProcA): nativeuint;');
|
|
Add('var p: pointer;');
|
|
Add('begin');
|
|
Add(' p:=typeinfo(tproca);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_ProcType',
|
|
LinesToStr([ // statements
|
|
'$mod.$rtti.$ProcVar("TProcA", {',
|
|
' procsig: rtl.newTIProcSig(null)',
|
|
'});',
|
|
'$mod.$rtti.$MethodVar("TMethodB", {',
|
|
' procsig: rtl.newTIProcSig(null),',
|
|
' methodkind: 0',
|
|
'});',
|
|
'$mod.$rtti.$ProcVar("TProcC", {',
|
|
' procsig: rtl.newTIProcSig(null, 2)',
|
|
'});',
|
|
'$mod.$rtti.$ProcVar("TProcD", {',
|
|
' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
|
|
'});',
|
|
'$mod.$rtti.$ProcVar("TProcE", {',
|
|
' procsig: rtl.newTIProcSig(null, rtl.nativeint)',
|
|
'});',
|
|
'$mod.$rtti.$ProcVar("TProcF", {',
|
|
' procsig: rtl.newTIProcSig([["p", $mod.$rtti["TProcA"], 2]], rtl.nativeuint)',
|
|
'});',
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.$rtti["TProcA"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_ProcType_ArgFromOtherUnit;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
|
|
AddModuleWithIntfImplSrc('unit2.pas',
|
|
LinesToStr([
|
|
'type',
|
|
' TObject = class end;'
|
|
]),
|
|
'');
|
|
StartUnit(true);
|
|
Add('interface');
|
|
Add('uses unit2;');
|
|
Add('type');
|
|
Add(' TProcA = function(o: tobject): tobject;');
|
|
Add('implementation');
|
|
Add('type');
|
|
Add(' TProcB = function(o: tobject): tobject;');
|
|
Add('var p: Pointer;');
|
|
Add('initialization');
|
|
Add(' p:=typeinfo(tproca);');
|
|
Add(' p:=typeinfo(tprocb);');
|
|
ConvertUnit;
|
|
CheckSource('TestRTTI_ProcType_ArgFromOtherUnit',
|
|
LinesToStr([ // statements
|
|
'var $impl = $mod.$impl;',
|
|
'$mod.$rtti.$ProcVar("TProcA", {',
|
|
' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // this.$init
|
|
'$impl.p = $mod.$rtti["TProcA"];',
|
|
'$impl.p = $mod.$rtti["TProcB"];',
|
|
'']),
|
|
LinesToStr([ // implementation
|
|
'$mod.$rtti.$ProcVar("TProcB", {',
|
|
' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
|
|
'});',
|
|
'$impl.p = null;',
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_EnumAndSetType;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TFlag = (light,dark);');
|
|
Add(' TFlags = set of TFlag;');
|
|
Add(' TProc = function(f: TFlags): TFlag;');
|
|
Add('var p: pointer;');
|
|
Add('begin');
|
|
Add(' p:=typeinfo(tflag);');
|
|
Add(' p:=typeinfo(tflags);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_EnumAndType',
|
|
LinesToStr([ // statements
|
|
'this.TFlag = {',
|
|
' "0": "light",',
|
|
' light: 0,',
|
|
' "1": "dark",',
|
|
' dark: 1',
|
|
'};',
|
|
'$mod.$rtti.$Enum("TFlag", {',
|
|
' minvalue: 0,',
|
|
' maxvalue: 1,',
|
|
' ordtype: 1,',
|
|
' enumtype: this.TFlag',
|
|
'});',
|
|
'$mod.$rtti.$Set("TFlags", {',
|
|
' comptype: $mod.$rtti["TFlag"]',
|
|
'});',
|
|
'$mod.$rtti.$ProcVar("TProc", {',
|
|
' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TFlags"]]], $mod.$rtti["TFlag"])',
|
|
'});',
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.$rtti["TFlag"];',
|
|
'$mod.p = $mod.$rtti["TFlags"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_EnumRange;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TCol = (red,green,blue);',
|
|
' TColRg = green..blue;',
|
|
' TSetOfColRg = set of TColRg;',
|
|
'var p: pointer;',
|
|
'begin',
|
|
' p:=typeinfo(tcolrg);',
|
|
' p:=typeinfo(tsetofcolrg);',
|
|
'']);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_AnonymousEnumType;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TFlags = set of (red, green);');
|
|
Add('var');
|
|
Add(' f: TFlags;');
|
|
Add('begin');
|
|
Add(' Include(f,red);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_AnonymousEnumType',
|
|
LinesToStr([ // statements
|
|
'this.TFlags$a = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "green",',
|
|
' green: 1',
|
|
'};',
|
|
'$mod.$rtti.$Enum("TFlags$a", {',
|
|
' minvalue: 0,',
|
|
' maxvalue: 1,',
|
|
' ordtype: 1,',
|
|
' enumtype: this.TFlags$a',
|
|
'});',
|
|
'$mod.$rtti.$Set("TFlags", {',
|
|
' comptype: $mod.$rtti["TFlags$a"]',
|
|
'});',
|
|
'this.f = {};',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_StaticArray;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TFlag = (light,dark);');
|
|
Add(' TFlagNames = array[TFlag] of string;');
|
|
Add(' TBoolNames = array[boolean] of string;');
|
|
Add(' TByteArray = array[1..32768] of byte;');
|
|
Add(' TProc = function(f: TBoolNames): TFlagNames;');
|
|
Add('var p: pointer;');
|
|
Add('begin');
|
|
Add(' p:=typeinfo(TFlagNames);');
|
|
Add(' p:=typeinfo(TBoolNames);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_StaticArray',
|
|
LinesToStr([ // statements
|
|
'this.TFlag = {',
|
|
' "0": "light",',
|
|
' light: 0,',
|
|
' "1": "dark",',
|
|
' dark: 1',
|
|
'};',
|
|
'$mod.$rtti.$Enum("TFlag", {',
|
|
' minvalue: 0,',
|
|
' maxvalue: 1,',
|
|
' ordtype: 1,',
|
|
' enumtype: this.TFlag',
|
|
'});',
|
|
'$mod.$rtti.$StaticArray("TFlagNames", {',
|
|
' dims: [2],',
|
|
' eltype: rtl.string',
|
|
'});',
|
|
'$mod.$rtti.$StaticArray("TBoolNames", {',
|
|
' dims: [2],',
|
|
' eltype: rtl.string',
|
|
'});',
|
|
'$mod.$rtti.$StaticArray("TByteArray", {',
|
|
' dims: [32768],',
|
|
' eltype: rtl.byte',
|
|
'});',
|
|
'$mod.$rtti.$ProcVar("TProc", {',
|
|
' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TBoolNames"]]], $mod.$rtti["TFlagNames"])',
|
|
'});',
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.$rtti["TFlagNames"];',
|
|
'$mod.p = $mod.$rtti["TBoolNames"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_DynArray;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TArrStr = array of string;');
|
|
Add(' TArr2Dim = array of tarrstr;');
|
|
Add(' TProc = function(f: TArrStr): TArr2Dim;');
|
|
Add('var p: pointer;');
|
|
Add('begin');
|
|
Add(' p:=typeinfo(tarrstr);');
|
|
Add(' p:=typeinfo(tarr2dim);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_DynArray',
|
|
LinesToStr([ // statements
|
|
'$mod.$rtti.$DynArray("TArrStr", {',
|
|
' eltype: rtl.string',
|
|
'});',
|
|
'$mod.$rtti.$DynArray("TArr2Dim", {',
|
|
' eltype: $mod.$rtti["TArrStr"]',
|
|
'});',
|
|
'$mod.$rtti.$ProcVar("TProc", {',
|
|
' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TArrStr"]]], $mod.$rtti["TArr2Dim"])',
|
|
'});',
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.$rtti["TArrStr"];',
|
|
'$mod.p = $mod.$rtti["TArr2Dim"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_ArrayNestedAnonymous;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TArr = array of array of longint;');
|
|
Add('var a: TArr;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_ArrayNestedAnonymous',
|
|
LinesToStr([ // statements
|
|
'$mod.$rtti.$DynArray("TArr$a", {',
|
|
' eltype: rtl.longint',
|
|
'});',
|
|
'$mod.$rtti.$DynArray("TArr", {',
|
|
' eltype: $mod.$rtti["TArr$a"]',
|
|
'});',
|
|
'this.a = [];',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
]));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_PublishedMethodOverloadFail;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' published');
|
|
Add(' procedure Proc; virtual; abstract;');
|
|
Add(' procedure Proc(Sender: tobject); virtual; abstract;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError('Duplicate identifier "Proc" at test1.pp(6,19)',
|
|
nDuplicateIdentifier);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_PublishedMethodExternalFail;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' published');
|
|
Add(' procedure Proc; external name ''foo'';');
|
|
Add(' end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
|
|
nPublishedNameMustMatchExternal);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_PublishedClassPropertyFail;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' class var FA: longint;');
|
|
Add(' published');
|
|
Add(' class property A: longint read FA;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError('Invalid published property modifier "class"',
|
|
nInvalidXModifierY);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_PublishedClassFieldFail;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' published');
|
|
Add(' class var FA: longint;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError(sSymbolCannotBePublished,
|
|
nSymbolCannotBePublished);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_PublishedFieldExternalFail;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' published');
|
|
Add(' V: longint; external name ''foo'';');
|
|
Add(' end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
|
|
nPublishedNameMustMatchExternal);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_Class_Field;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' private');
|
|
Add(' FPropA: string;');
|
|
Add(' published');
|
|
Add(' VarLI: longint;');
|
|
Add(' VarC: char;');
|
|
Add(' VarS: string;');
|
|
Add(' VarD: double;');
|
|
Add(' VarB: boolean;');
|
|
Add(' VarLW: longword;');
|
|
Add(' VarSmI: smallint;');
|
|
Add(' VarW: word;');
|
|
Add(' VarShI: shortint;');
|
|
Add(' VarBy: byte;');
|
|
Add(' VarExt: longint external name ''VarExt'';');
|
|
Add(' end;');
|
|
Add('var p: pointer;');
|
|
Add(' Obj: tobject;');
|
|
Add('begin');
|
|
Add(' p:=typeinfo(tobject);');
|
|
Add(' p:=typeinfo(p);');
|
|
Add(' p:=typeinfo(obj);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Class_Field',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FPropA = "";',
|
|
' this.VarLI = 0;',
|
|
' this.VarC = "";',
|
|
' this.VarS = "";',
|
|
' this.VarD = 0.0;',
|
|
' this.VarB = false;',
|
|
' this.VarLW = 0;',
|
|
' this.VarSmI = 0;',
|
|
' this.VarW = 0;',
|
|
' this.VarShI = 0;',
|
|
' this.VarBy = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addField("VarLI", rtl.longint);',
|
|
' $r.addField("VarC", rtl.char);',
|
|
' $r.addField("VarS", rtl.string);',
|
|
' $r.addField("VarD", rtl.double);',
|
|
' $r.addField("VarB", rtl.boolean);',
|
|
' $r.addField("VarLW", rtl.longword);',
|
|
' $r.addField("VarSmI", rtl.smallint);',
|
|
' $r.addField("VarW", rtl.word);',
|
|
' $r.addField("VarShI", rtl.shortint);',
|
|
' $r.addField("VarBy", rtl.byte);',
|
|
' $r.addField("VarExt", rtl.longint);',
|
|
'});',
|
|
'this.p = null;',
|
|
'this.Obj = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.$rtti["TObject"];',
|
|
'$mod.p = rtl.pointer;',
|
|
'$mod.p = $mod.Obj.$rtti;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_Class_Method;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' private');
|
|
Add(' procedure Internal; external name ''$intern'';');
|
|
Add(' published');
|
|
Add(' procedure Click; virtual; abstract;');
|
|
Add(' procedure Notify(Sender: TObject); virtual; abstract;');
|
|
Add(' function GetNotify: boolean; external name ''GetNotify'';');
|
|
Add(' procedure Println(a,b: longint); varargs; virtual; abstract;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Class_Method',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addMethod("Click", 0, null);',
|
|
' $r.addMethod("Notify", 0, [["Sender", $r]]);',
|
|
' $r.addMethod("GetNotify", 1, null, rtl.boolean,{flags: 4});',
|
|
' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], null, {',
|
|
' flags: 2',
|
|
' });',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_Class_MethodArgFlags;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' published');
|
|
Add(' procedure OpenArray(const Args: array of string); virtual; abstract;');
|
|
Add(' procedure ByRef(var Value: longint; out Item: longint); virtual; abstract;');
|
|
Add(' procedure Untyped(var Value; out Item); virtual; abstract;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Class_MethodOpenArray',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
'$r.addMethod("OpenArray", 0, [["Args", rtl.string, 10]]);',
|
|
'$r.addMethod("ByRef", 0, [["Value", rtl.longint, 1], ["Item", rtl.longint, 4]]);',
|
|
'$r.addMethod("Untyped", 0, [["Value", null, 1], ["Item", null, 4]]);',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_Class_Property;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' private');
|
|
Add(' FColor: longint;');
|
|
Add(' FColorStored: boolean;');
|
|
Add(' procedure SetColor(Value: longint); virtual; abstract;');
|
|
Add(' function GetColor: longint; virtual; abstract;');
|
|
Add(' function GetColorStored: boolean; virtual; abstract;');
|
|
Add(' FExtSize: longint external name ''$extSize'';');
|
|
Add(' FExtSizeStored: boolean external name ''$extSizeStored'';');
|
|
Add(' procedure SetExtSize(Value: longint); external name ''$setSize'';');
|
|
Add(' function GetExtSize: longint; external name ''$getSize'';');
|
|
Add(' function GetExtSizeStored: boolean; external name ''$getExtSizeStored'';');
|
|
Add(' published');
|
|
Add(' property ColorA: longint read FColor;');
|
|
Add(' property ColorB: longint write FColor;');
|
|
Add(' property ColorC: longint read GetColor write SetColor;');
|
|
Add(' property ColorD: longint read FColor write FColor stored FColorStored;');
|
|
Add(' property ExtSizeA: longint read FExtSize write FExtSize;');
|
|
Add(' property ExtSizeB: longint read GetExtSize write SetExtSize stored FExtSizeStored;');
|
|
Add(' property ExtSizeC: longint read FExtSize write FExtSize stored GetExtSizeStored;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Class_Property',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FColor = 0;',
|
|
' this.FColorStored = false;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty("ColorA", 0, rtl.longint, "FColor", "");',
|
|
' $r.addProperty("ColorB", 0, rtl.longint, "", "FColor");',
|
|
' $r.addProperty("ColorC", 3, rtl.longint, "GetColor", "SetColor");',
|
|
' $r.addProperty(',
|
|
' "ColorD",',
|
|
' 8,',
|
|
' rtl.longint,',
|
|
' "FColor",',
|
|
' "FColor",',
|
|
' {',
|
|
' stored: "FColorStored"',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty("ExtSizeA", 0, rtl.longint, "$extSize", "$extSize");',
|
|
' $r.addProperty(',
|
|
' "ExtSizeB",',
|
|
' 11,',
|
|
' rtl.longint,',
|
|
' "$getSize",',
|
|
' "$setSize",',
|
|
' {',
|
|
' stored: "$extSizeStored"',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "ExtSizeC",',
|
|
' 12,',
|
|
' rtl.longint,',
|
|
' "$extSize",',
|
|
' "$extSize",',
|
|
' {',
|
|
' stored: "$getExtSizeStored"',
|
|
' }',
|
|
' );',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_Class_PropertyParams;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TObject = class');
|
|
Add(' private');
|
|
Add(' function GetItems(i: integer): tobject; virtual; abstract;');
|
|
Add(' procedure SetItems(i: integer; value: tobject); virtual; abstract;');
|
|
Add(' function GetValues(const i: integer; var b: boolean): char; virtual; abstract;');
|
|
Add(' procedure SetValues(const i: integer; var b: boolean; value: char); virtual; abstract;');
|
|
Add(' published');
|
|
Add(' property Items[Index: integer]: tobject read getitems write setitems;');
|
|
Add(' property Values[const keya: integer; var keyb: boolean]: char read getvalues write setvalues;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Class_PropertyParams',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty("Items", 3, $r, "GetItems", "SetItems");',
|
|
' $r.addProperty("Values", 3, rtl.char, "GetValues", "SetValues");',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_Class_OtherUnit_TypeAlias;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
AddModuleWithIntfImplSrc('unit1.pas',
|
|
'type TColor = -5..5;',
|
|
'');
|
|
|
|
StartProgram(true);
|
|
Add([
|
|
'uses unit1;',
|
|
'type',
|
|
' TColorAlias = TColor;',
|
|
' TColorTypeAlias = type TColor;',
|
|
' TObject = class',
|
|
' private',
|
|
' fColor: TColor;',
|
|
' fAlias: TColorAlias;',
|
|
' fTypeAlias: TColorTypeAlias;',
|
|
' published',
|
|
' property Color: TColor read fcolor;',
|
|
' property Alias: TColorAlias read falias;',
|
|
' property TypeAlias: TColorTypeAlias read ftypealias;',
|
|
' end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Class_OtherUnit_TypeAlias',
|
|
LinesToStr([ // statements
|
|
'$mod.$rtti.$inherited("TColorTypeAlias", pas.unit1.$rtti["TColor"], {});',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.fColor = 0;',
|
|
' this.fAlias = 0;',
|
|
' this.fTypeAlias = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty("Color", 0, pas.unit1.$rtti["TColor"], "fColor", "");',
|
|
' $r.addProperty("Alias", 0, pas.unit1.$rtti["TColor"], "fAlias", "");',
|
|
' $r.addProperty("TypeAlias", 0, $mod.$rtti["TColorTypeAlias"], "fTypeAlias", "");',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_IndexModifier;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (red, blue);',
|
|
' TObject = class',
|
|
' FB: boolean;',
|
|
' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
|
|
' function GetBoolBool(Index: boolean): boolean; virtual; abstract;',
|
|
' procedure SetBoolBool(Index: boolean; b: boolean); virtual; abstract;',
|
|
' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
|
|
' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
|
|
' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
|
|
' published',
|
|
' property B1: boolean index 1 read FB write SetIntBool;',
|
|
' property B2: boolean index TEnum.blue read GetEnumBool write FB;',
|
|
' property I1[A: String]: boolean index 2 read GetStrIntBool write SetStrIntBool;',
|
|
' end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_IndexModifier',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "blue",',
|
|
' blue: 1',
|
|
'};',
|
|
'$mod.$rtti.$Enum("TEnum", {',
|
|
' minvalue: 0,',
|
|
' maxvalue: 1,',
|
|
' ordtype: 1,',
|
|
' enumtype: this.TEnum',
|
|
'});',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FB = false;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty(',
|
|
' "B1",',
|
|
' 18,',
|
|
' rtl.boolean,',
|
|
' "FB",',
|
|
' "SetIntBool",',
|
|
' {',
|
|
' index: 1',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "B2",',
|
|
' 17,',
|
|
' rtl.boolean,',
|
|
' "GetEnumBool",',
|
|
' "FB",',
|
|
' {',
|
|
' index: $mod.TEnum.blue',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "I1",',
|
|
' 19,',
|
|
' rtl.boolean,',
|
|
' "GetStrIntBool",',
|
|
' "SetStrIntBool",',
|
|
' {',
|
|
' index: 2',
|
|
' }',
|
|
' );',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_StoredModifier;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'const',
|
|
' ConstB = true;',
|
|
'type',
|
|
' TObject = class',
|
|
' private',
|
|
' FB: boolean;',
|
|
' function IsBStored: boolean; virtual; abstract;',
|
|
' published',
|
|
' property BoolA: boolean read FB stored true;',
|
|
' property BoolB: boolean read FB stored false;',
|
|
' property BoolC: boolean read FB stored FB;',
|
|
' property BoolD: boolean read FB stored ConstB;',
|
|
' property BoolE: boolean read FB stored IsBStored;',
|
|
' end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_StoredModifier',
|
|
LinesToStr([ // statements
|
|
'this.ConstB = true;',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FB = false;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty("BoolA", 0, rtl.boolean, "FB", "");',
|
|
' $r.addProperty("BoolB", 4, rtl.boolean, "FB", "");',
|
|
' $r.addProperty(',
|
|
' "BoolC",',
|
|
' 8,',
|
|
' rtl.boolean,',
|
|
' "FB",',
|
|
' "",',
|
|
' {',
|
|
' stored: "FB"',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty("BoolD", 0, rtl.boolean, "FB", "");',
|
|
' $r.addProperty(',
|
|
' "BoolE",',
|
|
' 12,',
|
|
' rtl.boolean,',
|
|
' "FB",',
|
|
' "",',
|
|
' {',
|
|
' stored: "IsBStored"',
|
|
' }',
|
|
' );',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_DefaultValue;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (red, blue);',
|
|
'const',
|
|
' CB = true or false;',
|
|
' CI = 1+2;',
|
|
'type',
|
|
' TObject = class',
|
|
' FB: boolean;',
|
|
' FI: longint;',
|
|
' FE: TEnum;',
|
|
' published',
|
|
' property B1: boolean read FB default true;',
|
|
' property B2: boolean read FB default CB;',
|
|
' property B3: boolean read FB default test1.cb;',
|
|
' property I1: longint read FI default 2;',
|
|
' property I2: longint read FI default CI;',
|
|
' property E1: TEnum read FE default red;',
|
|
' property E2: TEnum read FE default TEnum.blue;',
|
|
' end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_DefaultValue',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "blue",',
|
|
' blue: 1',
|
|
'};',
|
|
'$mod.$rtti.$Enum("TEnum", {',
|
|
' minvalue: 0,',
|
|
' maxvalue: 1,',
|
|
' ordtype: 1,',
|
|
' enumtype: this.TEnum',
|
|
'});',
|
|
'this.CB = true || false;',
|
|
'this.CI = 1 + 2;',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FB = false;',
|
|
' this.FI = 0;',
|
|
' this.FE = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty(',
|
|
' "B1",',
|
|
' 0,',
|
|
' rtl.boolean,',
|
|
' "FB",',
|
|
' "",',
|
|
' {',
|
|
' Default: true',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "B2",',
|
|
' 0,',
|
|
' rtl.boolean,',
|
|
' "FB",',
|
|
' "",',
|
|
' {',
|
|
' Default: true',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "B3",',
|
|
' 0,',
|
|
' rtl.boolean,',
|
|
' "FB",',
|
|
' "",',
|
|
' {',
|
|
' Default: true',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "I1",',
|
|
' 0,',
|
|
' rtl.longint,',
|
|
' "FI",',
|
|
' "",',
|
|
' {',
|
|
' Default: 2',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "I2",',
|
|
' 0,',
|
|
' rtl.longint,',
|
|
' "FI",',
|
|
' "",',
|
|
' {',
|
|
' Default: 3',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "E1",',
|
|
' 0,',
|
|
' $mod.$rtti["TEnum"],',
|
|
' "FE",',
|
|
' "",',
|
|
' {',
|
|
' Default: $mod.TEnum.red',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "E2",',
|
|
' 0,',
|
|
' $mod.$rtti["TEnum"],',
|
|
' "FE",',
|
|
' "",',
|
|
' {',
|
|
' Default: $mod.TEnum.blue',
|
|
' }',
|
|
' );',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_DefaultValueSet;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TEnum = (red, blue);',
|
|
' TSet = set of TEnum;',
|
|
'const',
|
|
' CSet = [red,blue];',
|
|
'type',
|
|
' TObject = class',
|
|
' FSet: TSet;',
|
|
' published',
|
|
' property Set1: TSet read FSet default [];',
|
|
' property Set2: TSet read FSet default [red];',
|
|
' property Set3: TSet read FSet default [red,blue];',
|
|
' property Set4: TSet read FSet default CSet;',
|
|
' end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_DefaultValueSet',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "blue",',
|
|
' blue: 1',
|
|
'};',
|
|
'$mod.$rtti.$Enum("TEnum", {',
|
|
' minvalue: 0,',
|
|
' maxvalue: 1,',
|
|
' ordtype: 1,',
|
|
' enumtype: this.TEnum',
|
|
'});',
|
|
'$mod.$rtti.$Set("TSet", {',
|
|
' comptype: $mod.$rtti["TEnum"]',
|
|
'});',
|
|
'this.CSet = rtl.createSet($mod.TEnum.red, $mod.TEnum.blue);',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FSet = {};',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FSet = undefined;',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty(',
|
|
' "Set1",',
|
|
' 0,',
|
|
' $mod.$rtti["TSet"],',
|
|
' "FSet",',
|
|
' "",',
|
|
' {',
|
|
' Default: {}',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "Set2",',
|
|
' 0,',
|
|
' $mod.$rtti["TSet"],',
|
|
' "FSet",',
|
|
' "",',
|
|
' {',
|
|
' Default: rtl.createSet($mod.TEnum.red)',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "Set3",',
|
|
' 0,',
|
|
' $mod.$rtti["TSet"],',
|
|
' "FSet",',
|
|
' "",',
|
|
' {',
|
|
' Default: rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty(',
|
|
' "Set4",',
|
|
' 0,',
|
|
' $mod.$rtti["TSet"],',
|
|
' "FSet",',
|
|
' "",',
|
|
' {',
|
|
' Default: $mod.CSet',
|
|
' }',
|
|
' );',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_DefaultValueRangeType;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TRg = -1..1;',
|
|
'const',
|
|
' l = low(TRg);',
|
|
' h = high(TRg);',
|
|
'type',
|
|
' TObject = class',
|
|
' FV: TRg;',
|
|
' published',
|
|
' property V1: TRg read FV default -1;',
|
|
' end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_DefaultValueRangeType',
|
|
LinesToStr([ // statements
|
|
'$mod.$rtti.$Int("TRg", {',
|
|
' minvalue: -1,',
|
|
' maxvalue: 1,',
|
|
' ordtype: 0',
|
|
'});',
|
|
'this.l = -1;',
|
|
'this.h = 1;',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FV = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty(',
|
|
' "V1",',
|
|
' 0,',
|
|
' $mod.$rtti["TRg"],',
|
|
' "FV",',
|
|
' "",',
|
|
' {',
|
|
' Default: -1',
|
|
' }',
|
|
' );',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_DefaultValueInherit;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' FA, FB: byte;',
|
|
' property A: byte read FA default 1;',
|
|
' property B: byte read FB default 2;',
|
|
' end;',
|
|
' TBird = class',
|
|
' published',
|
|
' property A;',
|
|
' property B nodefault;',
|
|
' end;',
|
|
'begin']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_DefaultValueInherit',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FA = 0;',
|
|
' this.FB = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty(',
|
|
' "A",',
|
|
' 0,',
|
|
' rtl.byte,',
|
|
' "FA",',
|
|
' "",',
|
|
' {',
|
|
' Default: 1',
|
|
' }',
|
|
' );',
|
|
' $r.addProperty("B", 0, rtl.byte, "FB", "");',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_OverrideMethod;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' published');
|
|
Add(' procedure DoIt; virtual; abstract;');
|
|
Add(' end;');
|
|
Add(' TSky = class');
|
|
Add(' published');
|
|
Add(' procedure DoIt; override;');
|
|
Add(' end;');
|
|
Add('procedure TSky.DoIt; begin end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_OverrideMethod',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addMethod("DoIt", 0, null);',
|
|
'});',
|
|
'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
|
|
' this.DoIt = function () {',
|
|
' };',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_OverloadProperty;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class');
|
|
Add(' protected');
|
|
Add(' FFlag: longint;');
|
|
Add(' published');
|
|
Add(' property Flag: longint read fflag;');
|
|
Add(' end;');
|
|
Add(' TSky = class');
|
|
Add(' published');
|
|
Add(' property FLAG: longint write fflag;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_OverrideMethod',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FFlag = 0;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty("Flag", 0, rtl.longint, "FFlag", "");',
|
|
'});',
|
|
'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
|
|
' var $r = this.$rtti;',
|
|
' $r.addProperty("Flag", 0, rtl.longint, "", "FFlag");',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_ClassForward;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TObject = class end;');
|
|
Add(' tbridge = class;');
|
|
Add(' TProc = function: tbridge;');
|
|
Add(' TOger = class');
|
|
Add(' published');
|
|
Add(' FBridge: tbridge;');
|
|
Add(' procedure SetBridge(Value: tbridge); virtual; abstract;');
|
|
Add(' property Bridge: tbridge read fbridge write setbridge;');
|
|
Add(' end;');
|
|
Add(' TBridge = class');
|
|
Add(' FOger: toger;');
|
|
Add(' end;');
|
|
Add('var p: Pointer;');
|
|
Add(' b: tbridge;');
|
|
Add('begin');
|
|
Add(' p:=typeinfo(tbridge);');
|
|
Add(' p:=typeinfo(b);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_ClassForward',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'$mod.$rtti.$Class("TBridge");',
|
|
'$mod.$rtti.$ProcVar("TProc", {',
|
|
' procsig: rtl.newTIProcSig(null, $mod.$rtti["TBridge"])',
|
|
'});',
|
|
'rtl.createClass($mod, "TOger", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.FBridge = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FBridge = undefined;',
|
|
' $mod.TObject.$final.call(this);',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addField("FBridge", $mod.$rtti["TBridge"]);',
|
|
' $r.addMethod("SetBridge", 0, [["Value", $mod.$rtti["TBridge"]]]);',
|
|
' $r.addProperty("Bridge", 2, $mod.$rtti["TBridge"], "FBridge", "SetBridge");',
|
|
'});',
|
|
'rtl.createClass($mod, "TBridge", $mod.TObject, function () {',
|
|
' this.$init = function () {',
|
|
' $mod.TObject.$init.call(this);',
|
|
' this.FOger = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.FOger = undefined;',
|
|
' $mod.TObject.$final.call(this);',
|
|
' };',
|
|
'});',
|
|
'this.p = null;',
|
|
'this.b = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.$rtti["TBridge"];',
|
|
'$mod.p = $mod.b.$rtti;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_ClassOf;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TClass = class of tobject;');
|
|
Add(' TProcA = function: TClass;');
|
|
Add(' TObject = class');
|
|
Add(' published');
|
|
Add(' C: tclass;');
|
|
Add(' end;');
|
|
Add(' tfox = class;');
|
|
Add(' TBird = class end;');
|
|
Add(' TBirds = class of tbird;');
|
|
Add(' TFox = class end;');
|
|
Add(' TFoxes = class of tfox;');
|
|
Add(' TCows = class of TCow;');
|
|
Add(' TCow = class;');
|
|
Add(' TCow = class end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_ClassOf',
|
|
LinesToStr([ // statements
|
|
'$mod.$rtti.$Class("TObject");',
|
|
'$mod.$rtti.$ClassRef("TClass", {',
|
|
' instancetype: $mod.$rtti["TObject"]',
|
|
'});',
|
|
'$mod.$rtti.$ProcVar("TProcA", {',
|
|
' procsig: rtl.newTIProcSig(null, $mod.$rtti["TClass"])',
|
|
'});',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.C = null;',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.C = undefined;',
|
|
' };',
|
|
' var $r = this.$rtti;',
|
|
' $r.addField("C", $mod.$rtti["TClass"]);',
|
|
'});',
|
|
'$mod.$rtti.$Class("TFox");',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
'});',
|
|
'$mod.$rtti.$ClassRef("TBirds", {',
|
|
' instancetype: $mod.$rtti["TBird"]',
|
|
'});',
|
|
'rtl.createClass($mod, "TFox", $mod.TObject, function () {',
|
|
'});',
|
|
'$mod.$rtti.$ClassRef("TFoxes", {',
|
|
' instancetype: $mod.$rtti["TFox"]',
|
|
'});',
|
|
'$mod.$rtti.$Class("TCow");',
|
|
'$mod.$rtti.$ClassRef("TCows", {',
|
|
' instancetype: $mod.$rtti["TCow"]',
|
|
'});',
|
|
'rtl.createClass($mod, "TCow", $mod.TObject, function () {',
|
|
'});',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_Record;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TPoint = record');
|
|
Add(' x,y: integer;');
|
|
Add(' end;');
|
|
Add('var p: pointer;');
|
|
Add(' r: tpoint;');
|
|
Add('begin');
|
|
Add(' p:=typeinfo(tpoint);');
|
|
Add(' p:=typeinfo(r);');
|
|
Add(' p:=typeinfo(r.x);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Record',
|
|
LinesToStr([ // statements
|
|
'this.TPoint = function (s) {',
|
|
' if (s) {',
|
|
' this.x = s.x;',
|
|
' this.y = s.y;',
|
|
' } else {',
|
|
' this.x = 0;',
|
|
' this.y = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.x === b.x) && (this.y === b.y);',
|
|
' };',
|
|
'};',
|
|
'$mod.$rtti.$Record("TPoint", {}).addFields("x", rtl.longint, "y", rtl.longint);',
|
|
'this.p = null;',
|
|
'this.r = new $mod.TPoint();',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.$rtti["TPoint"];',
|
|
'$mod.p = $mod.$rtti["TPoint"];',
|
|
'$mod.p = rtl.longint;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_RecordAnonymousArray;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('type');
|
|
Add(' TFloatRec = record');
|
|
Add(' d: array of char;');
|
|
// Add(' i: array of array of longint;');
|
|
Add(' end;');
|
|
Add('var p: pointer;');
|
|
Add(' r: tfloatrec;');
|
|
Add('begin');
|
|
Add(' p:=typeinfo(tfloatrec);');
|
|
Add(' p:=typeinfo(r);');
|
|
Add(' p:=typeinfo(r.d);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Record',
|
|
LinesToStr([ // statements
|
|
'this.TFloatRec = function (s) {',
|
|
' if (s) {',
|
|
' this.d = s.d;',
|
|
' } else {',
|
|
' this.d = [];',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return this.d === b.d;',
|
|
' };',
|
|
'};',
|
|
'$mod.$rtti.$DynArray("TFloatRec.d$a", {',
|
|
' eltype: rtl.char',
|
|
'});',
|
|
'$mod.$rtti.$Record("TFloatRec", {}).addFields("d", $mod.$rtti["TFloatRec.d$a"]);',
|
|
'this.p = null;',
|
|
'this.r = new $mod.TFloatRec();',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.$rtti["TFloatRec"];',
|
|
'$mod.p = $mod.$rtti["TFloatRec"];',
|
|
'$mod.p = $mod.$rtti["TFloatRec.d$a"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_LocalTypes;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('procedure DoIt;');
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TPoint = record');
|
|
Add(' x,y: integer;');
|
|
Add(' end;');
|
|
Add('begin');
|
|
Add('end;');
|
|
Add('begin');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_LocalTypes',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function () {',
|
|
' function TPoint(s) {',
|
|
' if (s) {',
|
|
' this.x = s.x;',
|
|
' this.y = s.y;',
|
|
' } else {',
|
|
' this.x = 0;',
|
|
' this.y = 0;',
|
|
' };',
|
|
' this.$equal = function (b) {',
|
|
' return (this.x === b.x) && (this.y === b.y);',
|
|
' };',
|
|
' };',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_TypeInfo_BaseTypes;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TCaption = string;',
|
|
' TYesNo = boolean;',
|
|
' TLetter = char;',
|
|
' TFloat = double;',
|
|
' TPtr = pointer;',
|
|
' TShortInt = shortint;',
|
|
' TByte = byte;',
|
|
' TSmallInt = smallint;',
|
|
' TWord = word;',
|
|
' TInt32 = longint;',
|
|
' TDWord = longword;',
|
|
' TValue = jsvalue;',
|
|
'var p: TPtr;',
|
|
'begin',
|
|
' p:=typeinfo(string);',
|
|
' p:=typeinfo(tcaption);',
|
|
' p:=typeinfo(boolean);',
|
|
' p:=typeinfo(tyesno);',
|
|
' p:=typeinfo(char);',
|
|
' p:=typeinfo(tletter);',
|
|
' p:=typeinfo(double);',
|
|
' p:=typeinfo(tfloat);',
|
|
' p:=typeinfo(pointer);',
|
|
' p:=typeinfo(tptr);',
|
|
' p:=typeinfo(shortint);',
|
|
' p:=typeinfo(tshortint);',
|
|
' p:=typeinfo(byte);',
|
|
' p:=typeinfo(tbyte);',
|
|
' p:=typeinfo(smallint);',
|
|
' p:=typeinfo(tsmallint);',
|
|
' p:=typeinfo(word);',
|
|
' p:=typeinfo(tword);',
|
|
' p:=typeinfo(longword);',
|
|
' p:=typeinfo(tdword);',
|
|
' p:=typeinfo(jsvalue);',
|
|
' p:=typeinfo(tvalue);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_TypeInfo_BaseTypes',
|
|
LinesToStr([ // statements
|
|
'this.p = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = rtl.string;',
|
|
'$mod.p = rtl.string;',
|
|
'$mod.p = rtl.boolean;',
|
|
'$mod.p = rtl.boolean;',
|
|
'$mod.p = rtl.char;',
|
|
'$mod.p = rtl.char;',
|
|
'$mod.p = rtl.double;',
|
|
'$mod.p = rtl.double;',
|
|
'$mod.p = rtl.pointer;',
|
|
'$mod.p = rtl.pointer;',
|
|
'$mod.p = rtl.shortint;',
|
|
'$mod.p = rtl.shortint;',
|
|
'$mod.p = rtl.byte;',
|
|
'$mod.p = rtl.byte;',
|
|
'$mod.p = rtl.smallint;',
|
|
'$mod.p = rtl.smallint;',
|
|
'$mod.p = rtl.word;',
|
|
'$mod.p = rtl.word;',
|
|
'$mod.p = rtl.longword;',
|
|
'$mod.p = rtl.longword;',
|
|
'$mod.p = rtl.jsvalue;',
|
|
'$mod.p = rtl.jsvalue;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_TypeInfo_Type_BaseTypes;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TCaption = type string;',
|
|
' TYesNo = type boolean;',
|
|
' TLetter = type char;',
|
|
' TFloat = type double;',
|
|
' TPtr = type pointer;',
|
|
' TShortInt = type shortint;',
|
|
' TByte = type byte;',
|
|
' TSmallInt = type smallint;',
|
|
' TWord = type word;',
|
|
' TInt32 = type longint;',
|
|
' TDWord = type longword;',
|
|
' TValue = type jsvalue;',
|
|
' TAliasValue = type TValue;',
|
|
'var',
|
|
' p: TPtr;',
|
|
' a: TAliasValue;',
|
|
'begin',
|
|
' p:=typeinfo(tcaption);',
|
|
' p:=typeinfo(tyesno);',
|
|
' p:=typeinfo(tletter);',
|
|
' p:=typeinfo(tfloat);',
|
|
' p:=typeinfo(tptr);',
|
|
' p:=typeinfo(tshortint);',
|
|
' p:=typeinfo(tbyte);',
|
|
' p:=typeinfo(tsmallint);',
|
|
' p:=typeinfo(tword);',
|
|
' p:=typeinfo(tdword);',
|
|
' p:=typeinfo(tvalue);',
|
|
' p:=typeinfo(taliasvalue);',
|
|
' p:=typeinfo(a);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_TypeInfo_Type_BaseTypes',
|
|
LinesToStr([ // statements
|
|
'$mod.$rtti.$inherited("TCaption", rtl.string, {});',
|
|
'$mod.$rtti.$inherited("TYesNo", rtl.boolean, {});',
|
|
'$mod.$rtti.$inherited("TLetter", rtl.char, {});',
|
|
'$mod.$rtti.$inherited("TFloat", rtl.double, {});',
|
|
'$mod.$rtti.$inherited("TPtr", rtl.pointer, {});',
|
|
'$mod.$rtti.$inherited("TShortInt", rtl.shortint, {});',
|
|
'$mod.$rtti.$inherited("TByte", rtl.byte, {});',
|
|
'$mod.$rtti.$inherited("TSmallInt", rtl.smallint, {});',
|
|
'$mod.$rtti.$inherited("TWord", rtl.word, {});',
|
|
'$mod.$rtti.$inherited("TInt32", rtl.longint, {});',
|
|
'$mod.$rtti.$inherited("TDWord", rtl.longword, {});',
|
|
'$mod.$rtti.$inherited("TValue", rtl.jsvalue, {});',
|
|
'$mod.$rtti.$inherited("TAliasValue", $mod.$rtti["TValue"], {});',
|
|
'this.p = null;',
|
|
'this.a = undefined;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.p = $mod.$rtti["TCaption"];',
|
|
'$mod.p = $mod.$rtti["TYesNo"];',
|
|
'$mod.p = $mod.$rtti["TLetter"];',
|
|
'$mod.p = $mod.$rtti["TFloat"];',
|
|
'$mod.p = $mod.$rtti["TPtr"];',
|
|
'$mod.p = $mod.$rtti["TShortInt"];',
|
|
'$mod.p = $mod.$rtti["TByte"];',
|
|
'$mod.p = $mod.$rtti["TSmallInt"];',
|
|
'$mod.p = $mod.$rtti["TWord"];',
|
|
'$mod.p = $mod.$rtti["TDWord"];',
|
|
'$mod.p = $mod.$rtti["TValue"];',
|
|
'$mod.p = $mod.$rtti["TAliasValue"];',
|
|
'$mod.p = $mod.$rtti["TAliasValue"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_TypeInfo_LocalFail;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('procedure DoIt;');
|
|
Add('type');
|
|
Add(' integer = longint;');
|
|
Add(' TPoint = record');
|
|
Add(' x,y: integer;');
|
|
Add(' end;');
|
|
Add('var p: pointer;');
|
|
Add('begin');
|
|
Add(' p:=typeinfo(tpoint);');
|
|
Add('end;');
|
|
Add('begin');
|
|
SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished);
|
|
ConvertProgram;
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses1;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
|
|
' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;',
|
|
' TFlag = (up,down);',
|
|
' TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;',
|
|
' TFlags = set of TFlag;',
|
|
' TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;',
|
|
'var',
|
|
' ti: TTypeInfo;',
|
|
' tiInt: TTypeInfoInteger;',
|
|
' tiEnum: TTypeInfoEnum;',
|
|
' tiSet: TTypeInfoSet;',
|
|
'begin',
|
|
' ti:=typeinfo(string);',
|
|
' ti:=typeinfo(boolean);',
|
|
' ti:=typeinfo(char);',
|
|
' ti:=typeinfo(double);',
|
|
' tiInt:=typeinfo(shortint);',
|
|
' tiInt:=typeinfo(byte);',
|
|
' tiInt:=typeinfo(smallint);',
|
|
' tiInt:=typeinfo(word);',
|
|
' tiInt:=typeinfo(longint);',
|
|
' tiInt:=typeinfo(longword);',
|
|
' ti:=typeinfo(jsvalue);',
|
|
' tiEnum:=typeinfo(tflag);',
|
|
' tiSet:=typeinfo(tflags);']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses1',
|
|
LinesToStr([ // statements
|
|
'this.TFlag = {',
|
|
' "0": "up",',
|
|
' up: 0,',
|
|
' "1": "down",',
|
|
' down: 1',
|
|
'};',
|
|
'$mod.$rtti.$Enum("TFlag", {',
|
|
' minvalue: 0,',
|
|
' maxvalue: 1,',
|
|
' ordtype: 1,',
|
|
' enumtype: this.TFlag',
|
|
'});',
|
|
'$mod.$rtti.$Set("TFlags", {',
|
|
' comptype: $mod.$rtti["TFlag"]',
|
|
'});',
|
|
'this.ti = null;',
|
|
'this.tiInt = null;',
|
|
'this.tiEnum = null;',
|
|
'this.tiSet = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.ti = rtl.string;',
|
|
'$mod.ti = rtl.boolean;',
|
|
'$mod.ti = rtl.char;',
|
|
'$mod.ti = rtl.double;',
|
|
'$mod.tiInt = rtl.shortint;',
|
|
'$mod.tiInt = rtl.byte;',
|
|
'$mod.tiInt = rtl.smallint;',
|
|
'$mod.tiInt = rtl.word;',
|
|
'$mod.tiInt = rtl.longint;',
|
|
'$mod.tiInt = rtl.longword;',
|
|
'$mod.ti = rtl.jsvalue;',
|
|
'$mod.tiEnum = $mod.$rtti["TFlag"];',
|
|
'$mod.tiSet = $mod.$rtti["TFlags"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses2;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
|
|
Add(' TStaticArr = array[boolean] of string;');
|
|
Add(' TTypeInfoStaticArray = class external name ''rtl.tTypeInfoStaticArray''(TTypeInfo) end;');
|
|
Add(' TDynArr = array of string;');
|
|
Add(' TTypeInfoDynArray = class external name ''rtl.tTypeInfoDynArray''(TTypeInfo) end;');
|
|
Add(' TProc = procedure;');
|
|
Add(' TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;');
|
|
Add(' TMethod = procedure of object;');
|
|
Add(' TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;');
|
|
Add('var');
|
|
Add(' StaticArray: TStaticArr;');
|
|
Add(' tiStaticArray: TTypeInfoStaticArray;');
|
|
Add(' DynArray: TDynArr;');
|
|
Add(' tiDynArray: TTypeInfoDynArray;');
|
|
Add(' ProcVar: TProc;');
|
|
Add(' tiProcVar: TTypeInfoProcVar;');
|
|
Add(' MethodVar: TMethod;');
|
|
Add(' tiMethodVar: TTypeInfoMethodVar;');
|
|
Add('begin');
|
|
Add(' tiStaticArray:=typeinfo(StaticArray);');
|
|
Add(' tiStaticArray:=typeinfo(TStaticArr);');
|
|
Add(' tiDynArray:=typeinfo(DynArray);');
|
|
Add(' tiDynArray:=typeinfo(TDynArr);');
|
|
Add(' tiProcVar:=typeinfo(ProcVar);');
|
|
Add(' tiProcVar:=typeinfo(TProc);');
|
|
Add(' tiMethodVar:=typeinfo(MethodVar);');
|
|
Add(' tiMethodVar:=typeinfo(TMethod);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses2',
|
|
LinesToStr([ // statements
|
|
' $mod.$rtti.$StaticArray("TStaticArr", {',
|
|
' dims: [2],',
|
|
' eltype: rtl.string',
|
|
'});',
|
|
'$mod.$rtti.$DynArray("TDynArr", {',
|
|
' eltype: rtl.string',
|
|
'});',
|
|
'$mod.$rtti.$ProcVar("TProc", {',
|
|
' procsig: rtl.newTIProcSig(null)',
|
|
'});',
|
|
'$mod.$rtti.$MethodVar("TMethod", {',
|
|
' procsig: rtl.newTIProcSig(null),',
|
|
' methodkind: 0',
|
|
'});',
|
|
'this.StaticArray = rtl.arraySetLength(null,"",2);',
|
|
'this.tiStaticArray = null;',
|
|
'this.DynArray = [];',
|
|
'this.tiDynArray = null;',
|
|
'this.ProcVar = null;',
|
|
'this.tiProcVar = null;',
|
|
'this.MethodVar = null;',
|
|
'this.tiMethodVar = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
|
|
'$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
|
|
'$mod.tiDynArray = $mod.$rtti["TDynArr"];',
|
|
'$mod.tiDynArray = $mod.$rtti["TDynArr"];',
|
|
'$mod.tiProcVar = $mod.$rtti["TProc"];',
|
|
'$mod.tiProcVar = $mod.$rtti["TProc"];',
|
|
'$mod.tiMethodVar = $mod.$rtti["TMethod"];',
|
|
'$mod.tiMethodVar = $mod.$rtti["TMethod"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses3;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add('{$modeswitch externalclass}');
|
|
Add('type');
|
|
Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
|
|
Add(' TRec = record end;');
|
|
Add(' TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;');
|
|
// ToDo: ^PRec
|
|
Add(' TObject = class end;');
|
|
Add(' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;');
|
|
Add(' TClass = class of tobject;');
|
|
Add(' TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;');
|
|
Add(' TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;');
|
|
Add('var');
|
|
Add(' Rec: trec;');
|
|
Add(' tiRecord: ttypeinforecord;');
|
|
Add(' Obj: tobject;');
|
|
Add(' tiClass: ttypeinfoclass;');
|
|
Add(' aClass: tclass;');
|
|
Add(' tiClassRef: ttypeinfoclassref;');
|
|
// ToDo: ^PRec
|
|
Add(' tiPointer: ttypeinfopointer;');
|
|
Add('begin');
|
|
Add(' tirecord:=typeinfo(trec);');
|
|
Add(' tirecord:=typeinfo(trec);');
|
|
Add(' ticlass:=typeinfo(obj);');
|
|
Add(' ticlass:=typeinfo(tobject);');
|
|
Add(' ticlass:=typeinfo(aclass);');
|
|
Add(' ticlassref:=typeinfo(tclass);');
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses3',
|
|
LinesToStr([ // statements
|
|
'this.TRec = function (s) {',
|
|
' this.$equal = function (b) {',
|
|
' return true;',
|
|
' };',
|
|
'};',
|
|
'$mod.$rtti.$Record("TRec", {});',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'$mod.$rtti.$ClassRef("TClass", {',
|
|
' instancetype: $mod.$rtti["TObject"]',
|
|
'});',
|
|
'this.Rec = new $mod.TRec();',
|
|
'this.tiRecord = null;',
|
|
'this.Obj = null;',
|
|
'this.tiClass = null;',
|
|
'this.aClass = null;',
|
|
'this.tiClassRef = null;',
|
|
'this.tiPointer = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.tiRecord = $mod.$rtti["TRec"];',
|
|
'$mod.tiRecord = $mod.$rtti["TRec"];',
|
|
'$mod.tiClass = $mod.Obj.$rtti;',
|
|
'$mod.tiClass = $mod.$rtti["TObject"];',
|
|
'$mod.tiClass = $mod.aClass.$rtti;',
|
|
'$mod.tiClassRef = $mod.$rtti["TClass"];',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_TypeInfo_FunctionClassType;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TClass = class of tobject;',
|
|
' TObject = class',
|
|
' function MyClass: TClass;',
|
|
' class function ClassType: TClass;',
|
|
' end;',
|
|
' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
|
|
' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;',
|
|
'function TObject.MyClass: TClass;',
|
|
'var t: TTypeInfoClass;',
|
|
'begin',
|
|
' t:=TypeInfo(Self);',
|
|
' t:=TypeInfo(Result);',
|
|
' t:=TypeInfo(TObject);',
|
|
'end;',
|
|
'class function TObject.ClassType: TClass;',
|
|
'var t: TTypeInfoClass;',
|
|
'begin',
|
|
' t:=TypeInfo(Self);',
|
|
' t:=TypeInfo(Result);',
|
|
'end;',
|
|
'var',
|
|
' Obj: TObject;',
|
|
' t: TTypeInfoClass;',
|
|
'begin',
|
|
' t:=TypeInfo(TObject.ClassType);',
|
|
' t:=TypeInfo(Obj.ClassType);',
|
|
' t:=TypeInfo(Obj.MyClass);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_TypeInfo_FunctionClassType',
|
|
LinesToStr([ // statements
|
|
'$mod.$rtti.$Class("TObject");',
|
|
'$mod.$rtti.$ClassRef("TClass", {',
|
|
' instancetype: $mod.$rtti["TObject"]',
|
|
'});',
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.MyClass = function () {',
|
|
' var Result = null;',
|
|
' var t = null;',
|
|
' t = this.$rtti;',
|
|
' t = Result.$rtti;',
|
|
' t = $mod.$rtti["TObject"];',
|
|
' return Result;',
|
|
' };',
|
|
' this.ClassType = function () {',
|
|
' var Result = null;',
|
|
' var t = null;',
|
|
' t = this.$rtti;',
|
|
' t = Result.$rtti;',
|
|
' return Result;',
|
|
' };',
|
|
'});',
|
|
'this.Obj = null;',
|
|
'this.t = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.t = $mod.TObject.ClassType().$rtti;',
|
|
'$mod.t = $mod.Obj.$class.ClassType().$rtti;',
|
|
'$mod.t = $mod.Obj.MyClass().$rtti;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_TypeInfo_MixedUnits_PointerAndClass;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
AddModuleWithIntfImplSrc('typinfo.pas',
|
|
LinesToStr([
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
|
|
' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;',
|
|
'']),
|
|
'');
|
|
AddModuleWithIntfImplSrc('unit2.pas',
|
|
LinesToStr([
|
|
'uses typinfo;',
|
|
'type PTypeInfo = TTypeInfo;', // delphi compatibility code
|
|
'procedure DoPtr(p: PTypeInfo);',
|
|
'procedure DoInfo(t: TTypeInfo);',
|
|
'procedure DoInt(t: TTypeInfoInteger);',
|
|
'']),
|
|
LinesToStr([
|
|
'procedure DoPtr(p: PTypeInfo);',
|
|
'begin end;',
|
|
'procedure DoInfo(t: TTypeInfo);',
|
|
'begin end;',
|
|
'procedure DoInt(t: TTypeInfoInteger);',
|
|
'begin end;',
|
|
'']));
|
|
StartUnit(true);
|
|
Add([
|
|
'interface',
|
|
'uses unit2;', // does not use unit typinfo
|
|
'implementation',
|
|
'var',
|
|
' i: byte;',
|
|
' p: pointer;',
|
|
' t: PTypeInfo;',
|
|
'initialization',
|
|
' p:=typeinfo(i);',
|
|
' t:=typeinfo(i);',
|
|
' if p=t then ;',
|
|
' if p=typeinfo(i) then ;',
|
|
' if typeinfo(i)=p then ;',
|
|
' if t=typeinfo(i) then ;',
|
|
' if typeinfo(i)=t then ;',
|
|
' DoPtr(p);',
|
|
' DoPtr(t);',
|
|
' DoPtr(typeinfo(i));',
|
|
' DoInfo(p);',
|
|
' DoInfo(t);',
|
|
' DoInfo(typeinfo(i));',
|
|
' DoInt(typeinfo(i));',
|
|
'']);
|
|
ConvertUnit;
|
|
CheckSource('TestRTTI_TypeInfo_MixedUnits_PointerAndClass',
|
|
LinesToStr([ // statements
|
|
'var $impl = $mod.$impl;',
|
|
'']),
|
|
LinesToStr([ // this.$init
|
|
'$impl.p = rtl.byte;',
|
|
'$impl.t = rtl.byte;',
|
|
'if ($impl.p === $impl.t) ;',
|
|
'if ($impl.p === rtl.byte) ;',
|
|
'if (rtl.byte === $impl.p) ;',
|
|
'if ($impl.t === rtl.byte) ;',
|
|
'if (rtl.byte === $impl.t) ;',
|
|
'pas.unit2.DoPtr($impl.p);',
|
|
'pas.unit2.DoPtr($impl.t);',
|
|
'pas.unit2.DoPtr(rtl.byte);',
|
|
'pas.unit2.DoInfo($impl.p);',
|
|
'pas.unit2.DoInfo($impl.t);',
|
|
'pas.unit2.DoInfo(rtl.byte);',
|
|
'pas.unit2.DoInt(rtl.byte);',
|
|
'']),
|
|
LinesToStr([ // implementation
|
|
'$impl.i = 0;',
|
|
'$impl.p = null;',
|
|
'$impl.t = null;',
|
|
'']) );
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_Interface_Corba;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces corba}',
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' end;',
|
|
' IBird = interface',
|
|
' function GetItem: longint;',
|
|
' procedure SetItem(Value: longint);',
|
|
' property Item: longint read GetItem write SetItem;',
|
|
' end;',
|
|
' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
|
|
' TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
|
|
'procedure DoIt(t: TTypeInfoInterface); begin end;',
|
|
'var',
|
|
' i: IBird;',
|
|
' t: TTypeInfoInterface;',
|
|
'begin',
|
|
' t:=TypeInfo(IBird);',
|
|
' t:=TypeInfo(i);',
|
|
' DoIt(t);',
|
|
' DoIt(TypeInfo(IBird));',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Interface_Corba',
|
|
LinesToStr([ // statements
|
|
'rtl.createInterface(',
|
|
' $mod,',
|
|
' "IUnknown",',
|
|
' "{B92D5841-758A-322B-B800-000000000000}",',
|
|
' [],',
|
|
' null,',
|
|
' function () {',
|
|
' }',
|
|
');',
|
|
'rtl.createInterface(',
|
|
' $mod,',
|
|
' "IBird",',
|
|
' "{D32D5841-6264-3AE3-A2C9-B91CE922C9B9}",',
|
|
' ["GetItem", "SetItem"],',
|
|
' null,',
|
|
' function () {',
|
|
' var $r = this.$rtti;',
|
|
' $r.addMethod("GetItem", 1, null, rtl.longint);',
|
|
' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
|
|
' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
|
|
' }',
|
|
');',
|
|
'this.DoIt = function (t) {',
|
|
'}; ',
|
|
'this.i = null;',
|
|
'this.t = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.t = $mod.$rtti["IBird"];',
|
|
'$mod.t = $mod.i.$rtti;',
|
|
'$mod.DoIt($mod.t);',
|
|
'$mod.DoIt($mod.$rtti["IBird"]);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRTTI_Interface_COM;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartProgram(false);
|
|
Add([
|
|
'{$interfaces com}',
|
|
'{$modeswitch externalclass}',
|
|
'type',
|
|
' TGuid = record end;',
|
|
' integer = longint;',
|
|
' IUnknown = interface',
|
|
' function QueryInterface(const iid: TGuid; out obj): Integer;',
|
|
' function _AddRef: Integer;',
|
|
' function _Release: Integer;',
|
|
' end;',
|
|
' IBird = interface',
|
|
' function GetItem: longint;',
|
|
' procedure SetItem(Value: longint);',
|
|
' property Item: longint read GetItem write SetItem;',
|
|
' end;',
|
|
' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
|
|
' TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
|
|
'var',
|
|
' i: IBird;',
|
|
' t: TTypeInfoInterface;',
|
|
'begin',
|
|
' t:=TypeInfo(IBird);',
|
|
' t:=TypeInfo(i);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRTTI_Interface_COM',
|
|
LinesToStr([ // statements
|
|
'this.TGuid = function (s) {',
|
|
' this.$equal = function (b) {',
|
|
' return true;',
|
|
' };',
|
|
'};',
|
|
'$mod.$rtti.$Record("TGuid", {});',
|
|
'rtl.createInterface(',
|
|
' $mod,',
|
|
' "IUnknown",',
|
|
' "{D7ADB00D-1A9B-3EDC-B123-730E661DDFA9}",',
|
|
' ["QueryInterface", "_AddRef", "_Release"],',
|
|
' null,',
|
|
' function () {',
|
|
' this.$kind = "com";',
|
|
' var $r = this.$rtti;',
|
|
' $r.addMethod("QueryInterface", 1, [["iid", $mod.$rtti["TGuid"], 2], ["obj", null, 4]], rtl.longint);',
|
|
' $r.addMethod("_AddRef", 1, null, rtl.longint);',
|
|
' $r.addMethod("_Release", 1, null, rtl.longint);',
|
|
' }',
|
|
');',
|
|
'rtl.createInterface(',
|
|
' $mod,',
|
|
' "IBird",',
|
|
' "{9CC77572-0E45-3594-9A88-9E8D865C9E0A}",',
|
|
' ["GetItem", "SetItem"],',
|
|
' $mod.IUnknown,',
|
|
' function () {',
|
|
' var $r = this.$rtti;',
|
|
' $r.addMethod("GetItem", 1, null, rtl.longint);',
|
|
' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
|
|
' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
|
|
' }',
|
|
');',
|
|
'this.i = null;',
|
|
'this.t = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.t = $mod.$rtti["IBird"];',
|
|
'$mod.t = $mod.i.$rtti;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestResourcestringProgram;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'const Bar = ''bar'';',
|
|
'resourcestring',
|
|
' Red = ''red'';',
|
|
' Foobar = ''fOo''+bar;',
|
|
'var s: string;',
|
|
' c: char;',
|
|
'begin',
|
|
' s:=red;',
|
|
' s:=test1.red;',
|
|
' c:=red[1];',
|
|
' c:=test1.red[2];',
|
|
' if red=foobar then ;',
|
|
' if red[3]=red[4] then ;']);
|
|
ConvertProgram;
|
|
CheckSource('TestResourcestringProgram',
|
|
LinesToStr([ // statements
|
|
'this.Bar = "bar";',
|
|
'this.s = "";',
|
|
'this.c = "";',
|
|
'$mod.$resourcestrings = {',
|
|
' Red: {',
|
|
' org: "red"',
|
|
' },',
|
|
' Foobar: {',
|
|
' org: "fOobar"',
|
|
' }',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.s = rtl.getResStr(pas.program, "Red");',
|
|
'$mod.s = rtl.getResStr(pas.program, "Red");',
|
|
'$mod.c = rtl.getResStr(pas.program, "Red").charAt(0);',
|
|
'$mod.c = rtl.getResStr(pas.program, "Red").charAt(1);',
|
|
'if (rtl.getResStr(pas.program, "Red") === rtl.getResStr(pas.program, "Foobar")) ;',
|
|
'if (rtl.getResStr(pas.program, "Red").charAt(2) === rtl.getResStr(pas.program, "Red").charAt(3)) ;',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestResourcestringUnit;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'const Red = ''rEd'';',
|
|
'resourcestring',
|
|
' Blue = ''blue'';',
|
|
' NotRed = ''not''+Red;',
|
|
'var s: string;',
|
|
'implementation',
|
|
'resourcestring',
|
|
' ImplGreen = ''green'';',
|
|
'initialization',
|
|
' s:=blue+ImplGreen;',
|
|
' s:=test1.blue+test1.implgreen;',
|
|
' s:=blue[1]+implgreen[2];']);
|
|
ConvertUnit;
|
|
CheckSource('TestResourcestringUnit',
|
|
LinesToStr([ // statements
|
|
'this.Red = "rEd";',
|
|
'this.s = "";',
|
|
'$mod.$resourcestrings = {',
|
|
' Blue: {',
|
|
' org: "blue"',
|
|
' },',
|
|
' NotRed: {',
|
|
' org: "notrEd"',
|
|
' },',
|
|
' ImplGreen: {',
|
|
' org: "green"',
|
|
' }',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
|
|
'$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
|
|
'$mod.s = rtl.getResStr(pas.Test1, "Blue").charAt(0) + rtl.getResStr(pas.Test1, "ImplGreen").charAt(1);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestResourcestringImplementation;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'implementation',
|
|
'resourcestring',
|
|
' ImplRed = ''red'';']);
|
|
ConvertUnit;
|
|
CheckSource('TestResourcestringImplementation',
|
|
LinesToStr([ // intf statements
|
|
'var $impl = $mod.$impl;']),
|
|
LinesToStr([ // $mod.$init
|
|
'']),
|
|
LinesToStr([ // impl statements
|
|
'$mod.$resourcestrings = {',
|
|
' ImplRed: {',
|
|
' org: "red"',
|
|
' }',
|
|
'};',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestAtributes_Ignore;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$modeswitch ignoreattributes}',
|
|
'type',
|
|
' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
|
|
' TObject = class',
|
|
' [custom5()] FS: string;',
|
|
' [customProp] property S: string read FS;',
|
|
' end;',
|
|
'var',
|
|
' [custom6]',
|
|
' o: TObject;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestAtributes_Ignore',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.FS = "";',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.o = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestAssert;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'procedure DoIt;',
|
|
'var',
|
|
' b: boolean;',
|
|
' s: string;',
|
|
'begin',
|
|
' {$Assertions on}',
|
|
' Assert(b);',
|
|
'end;',
|
|
'begin',
|
|
' DoIt;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestAssert',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function () {',
|
|
' var b = false;',
|
|
' var s = "";',
|
|
' if (b) throw "assert failed";',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestAssert_SysUtils;
|
|
begin
|
|
AddModuleWithIntfImplSrc('SysUtils.pas',
|
|
LinesToStr([
|
|
'type',
|
|
' TObject = class',
|
|
' constructor Create;',
|
|
' end;',
|
|
' EAssertionFailed = class',
|
|
' constructor Create(s: string);',
|
|
' end;',
|
|
'']),
|
|
LinesToStr([
|
|
'constructor TObject.Create;',
|
|
'begin end;',
|
|
'constructor EAssertionFailed.Create(s: string);',
|
|
'begin end;',
|
|
'']) );
|
|
|
|
StartProgram(true);
|
|
Add([
|
|
'uses sysutils;',
|
|
'procedure DoIt;',
|
|
'var',
|
|
' b: boolean;',
|
|
' s: string;',
|
|
'begin',
|
|
' {$Assertions on}',
|
|
' Assert(b);',
|
|
' Assert(b,''msg'');',
|
|
'end;',
|
|
'begin',
|
|
' DoIt;',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestAssert_SysUtils',
|
|
LinesToStr([ // statements
|
|
'this.DoIt = function () {',
|
|
' var b = false;',
|
|
' var s = "";',
|
|
' if (b) throw pas.SysUtils.EAssertionFailed.$create("Create");',
|
|
' if (b) throw pas.SysUtils.EAssertionFailed.$create("Create$1", ["msg"]);',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.DoIt();',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestObjectChecks;
|
|
begin
|
|
Scanner.CurrentBoolSwitches:=Scanner.CurrentBoolSwitches+[bsObjectChecks];
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' procedure DoIt;',
|
|
' end;',
|
|
' TClass = class of tobject;',
|
|
' TBird = class',
|
|
' end;',
|
|
' TBirdClass = class of TBird;',
|
|
'var',
|
|
' o : TObject;',
|
|
' c: TClass;',
|
|
' b: TBird;',
|
|
' bc: TBirdClass;',
|
|
'procedure TObject.DoIt;',
|
|
'begin',
|
|
' b:=TBird(o);',
|
|
'end;',
|
|
'begin',
|
|
' o.DoIt;',
|
|
' b:=TBird(o);',
|
|
' bc:=TBirdClass(c);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestCheckMethodCall',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
' this.DoIt = function () {',
|
|
' rtl.checkMethodCall(this,$mod.TObject);',
|
|
' $mod.b = rtl.asExt($mod.o, $mod.TBird, 1);',
|
|
' };',
|
|
'});',
|
|
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
|
'});',
|
|
'this.o = null;',
|
|
'this.c = null;',
|
|
'this.b = null;',
|
|
'this.bc = null;',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'$mod.o.DoIt();',
|
|
'$mod.b = rtl.asExt($mod.o,$mod.TBird, 1);',
|
|
'$mod.bc = rtl.asExt($mod.c, $mod.TBird, 2);',
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRangeChecks_AssignInt;
|
|
begin
|
|
Scanner.Options:=Scanner.Options+[po_CAssignments];
|
|
StartProgram(false);
|
|
Add([
|
|
'{$R+}',
|
|
'var',
|
|
' b: byte = 2;',
|
|
' w: word = 3;',
|
|
'procedure DoIt(p: byte);',
|
|
'begin',
|
|
' b:=w;',
|
|
' b+=w;',
|
|
' b:=1;',
|
|
'end;',
|
|
'{$R-}',
|
|
'procedure DoSome;',
|
|
'begin',
|
|
' DoIt(w);',
|
|
' b:=w;',
|
|
' b:=2;',
|
|
'end;',
|
|
'begin',
|
|
'{$R+}',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRangeChecks_AssignInt',
|
|
LinesToStr([ // statements
|
|
'this.b = 2;',
|
|
'this.w = 3;',
|
|
'this.DoIt = function (p) {',
|
|
' rtl.rc(p, 0, 255);',
|
|
' $mod.b = rtl.rc($mod.w,0,255);',
|
|
' rtl.rc($mod.b += $mod.w, 0, 255);',
|
|
' $mod.b = 1;',
|
|
'};',
|
|
'this.DoSome = function () {',
|
|
' $mod.DoIt($mod.w);',
|
|
' $mod.b = $mod.w;',
|
|
' $mod.b = 2;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRangeChecks_AssignIntRange;
|
|
begin
|
|
Scanner.Options:=Scanner.Options+[po_CAssignments];
|
|
StartProgram(false);
|
|
Add([
|
|
'{$R+}',
|
|
'type Ten = 1..10;',
|
|
'var',
|
|
' b: Ten = 2;',
|
|
' w: Ten = 3;',
|
|
'procedure DoIt(p: Ten);',
|
|
'begin',
|
|
' b:=w;',
|
|
' b+=w;',
|
|
' b:=1;',
|
|
'end;',
|
|
'{$R-}',
|
|
'procedure DoSome;',
|
|
'begin',
|
|
' DoIt(w);',
|
|
' b:=w;',
|
|
' b:=2;',
|
|
'end;',
|
|
'begin',
|
|
'{$R+}',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRangeChecks_AssignIntRange',
|
|
LinesToStr([ // statements
|
|
'this.b = 2;',
|
|
'this.w = 3;',
|
|
'this.DoIt = function (p) {',
|
|
' rtl.rc(p, 1, 10);',
|
|
' $mod.b = rtl.rc($mod.w, 1, 10);',
|
|
' rtl.rc($mod.b += $mod.w, 1, 10);',
|
|
' $mod.b = 1;',
|
|
'};',
|
|
'this.DoSome = function () {',
|
|
' $mod.DoIt($mod.w);',
|
|
' $mod.b = $mod.w;',
|
|
' $mod.b = 2;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRangeChecks_AssignEnum;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$R+}',
|
|
'type TEnum = (red,green);',
|
|
'var',
|
|
' e: TEnum = red;',
|
|
'procedure DoIt(p: TEnum);',
|
|
'begin',
|
|
' e:=p;',
|
|
' p:=TEnum(0);',
|
|
' p:=succ(e);',
|
|
'end;',
|
|
'{$R-}',
|
|
'procedure DoSome;',
|
|
'begin',
|
|
' DoIt(e);',
|
|
' e:=TEnum(1);',
|
|
' e:=pred(e);',
|
|
'end;',
|
|
'begin',
|
|
'{$R+}',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRangeChecks_AssignEnum',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "green",',
|
|
' green: 1',
|
|
'};',
|
|
'this.e = $mod.TEnum.red;',
|
|
'this.DoIt = function (p) {',
|
|
' rtl.rc(p, 0, 1);',
|
|
' $mod.e = rtl.rc(p, 0, 1);',
|
|
' p = 0;',
|
|
' p = rtl.rc($mod.e + 1, 0, 1);',
|
|
'};',
|
|
'this.DoSome = function () {',
|
|
' $mod.DoIt($mod.e);',
|
|
' $mod.e = 1;',
|
|
' $mod.e = $mod.e - 1;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRangeChecks_AssignEnumRange;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$R+}',
|
|
'type',
|
|
' TEnum = (red,green);',
|
|
' TEnumRg = red..green;',
|
|
'var',
|
|
' e: TEnumRg = red;',
|
|
'procedure DoIt(p: TEnumRg);',
|
|
'begin',
|
|
' e:=p;',
|
|
' p:=TEnumRg(0);',
|
|
' p:=succ(e);',
|
|
'end;',
|
|
'{$R-}',
|
|
'procedure DoSome;',
|
|
'begin',
|
|
' DoIt(e);',
|
|
' e:=TEnum(1);',
|
|
' e:=pred(e);',
|
|
'end;',
|
|
'begin',
|
|
'{$R+}',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRangeChecks_AssignEnumRange',
|
|
LinesToStr([ // statements
|
|
'this.TEnum = {',
|
|
' "0": "red",',
|
|
' red: 0,',
|
|
' "1": "green",',
|
|
' green: 1',
|
|
'};',
|
|
'this.e = $mod.TEnum.red;',
|
|
'this.DoIt = function (p) {',
|
|
' rtl.rc(p, 0, 1);',
|
|
' $mod.e = rtl.rc(p, 0, 1);',
|
|
' p = 0;',
|
|
' p = rtl.rc($mod.e + 1, 0, 1);',
|
|
'};',
|
|
'this.DoSome = function () {',
|
|
' $mod.DoIt($mod.e);',
|
|
' $mod.e = 1;',
|
|
' $mod.e = $mod.e - 1;',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRangeChecks_AssignChar;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$R+}',
|
|
'type',
|
|
' TLetter = char;',
|
|
'var',
|
|
' b: TLetter = ''2'';',
|
|
' w: TLetter = ''3'';',
|
|
'procedure DoIt(p: TLetter);',
|
|
'begin',
|
|
' b:=w;',
|
|
' b:=''1'';',
|
|
'end;',
|
|
'{$R-}',
|
|
'procedure DoSome;',
|
|
'begin',
|
|
' DoIt(w);',
|
|
' b:=w;',
|
|
' b:=''2'';',
|
|
'end;',
|
|
'begin',
|
|
'{$R+}',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRangeChecks_AssignChar',
|
|
LinesToStr([ // statements
|
|
'this.b = "2";',
|
|
'this.w = "3";',
|
|
'this.DoIt = function (p) {',
|
|
' rtl.rcc(p, 0, 65535);',
|
|
' $mod.b = rtl.rcc($mod.w, 0, 65535);',
|
|
' $mod.b = "1";',
|
|
'};',
|
|
'this.DoSome = function () {',
|
|
' $mod.DoIt($mod.w);',
|
|
' $mod.b = $mod.w;',
|
|
' $mod.b = "2";',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRangeChecks_AssignCharRange;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$R+}',
|
|
'type TDigit = ''0''..''9'';',
|
|
'var',
|
|
' b: TDigit = ''2'';',
|
|
' w: TDigit = ''3'';',
|
|
'procedure DoIt(p: TDigit);',
|
|
'begin',
|
|
' b:=w;',
|
|
' b:=''1'';',
|
|
'end;',
|
|
'{$R-}',
|
|
'procedure DoSome;',
|
|
'begin',
|
|
' DoIt(w);',
|
|
' b:=w;',
|
|
' b:=''2'';',
|
|
'end;',
|
|
'begin',
|
|
'{$R+}',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRangeChecks_AssignCharRange',
|
|
LinesToStr([ // statements
|
|
'this.b = "2";',
|
|
'this.w = "3";',
|
|
'this.DoIt = function (p) {',
|
|
' rtl.rcc(p, 48, 57);',
|
|
' $mod.b = rtl.rcc($mod.w, 48, 57);',
|
|
' $mod.b = "1";',
|
|
'};',
|
|
'this.DoSome = function () {',
|
|
' $mod.DoIt($mod.w);',
|
|
' $mod.b = $mod.w;',
|
|
' $mod.b = "2";',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRangeChecks_ArrayIndex;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$R+}',
|
|
'type',
|
|
' Ten = 1..10;',
|
|
' TArr = array of Ten;',
|
|
' TArrArr = array of TArr;',
|
|
' TArrByte = array[byte] of Ten;',
|
|
' TArrChar = array[''0''..''9''] of Ten;',
|
|
' TArrByteChar = array[byte,''0''..''9''] of Ten;',
|
|
' TObject = class',
|
|
' A: TArr;',
|
|
' end;',
|
|
'procedure DoIt;',
|
|
'var',
|
|
' Arr: TArr;',
|
|
' ArrArr: TArrArr;',
|
|
' ArrByte: TArrByte;',
|
|
' ArrChar: TArrChar;',
|
|
' ArrByteChar: TArrByteChar;',
|
|
' i: Ten;',
|
|
' c: char;',
|
|
' o: tobject;',
|
|
'begin',
|
|
' i:=Arr[1];',
|
|
' i:=ArrByteChar[1,''2''];',
|
|
' Arr[1]:=Arr[1];',
|
|
' Arr[i]:=Arr[i];',
|
|
' ArrByte[3]:=ArrByte[3];',
|
|
' ArrByte[i]:=ArrByte[i];',
|
|
' ArrChar[''5'']:=ArrChar[''5''];',
|
|
' ArrChar[c]:=ArrChar[c];',
|
|
' ArrByteChar[7,''7'']:=ArrByteChar[7,''7''];',
|
|
' ArrByteChar[i,c]:=ArrByteChar[i,c];',
|
|
' o.a[i]:=o.a[i];',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRangeChecks_ArrayIndex',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.A = [];',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' this.A = undefined;',
|
|
' };',
|
|
'});',
|
|
'this.DoIt = function () {',
|
|
' var Arr = [];',
|
|
' var ArrArr = [];',
|
|
' var ArrByte = rtl.arraySetLength(null, 0, 256);',
|
|
' var ArrChar = rtl.arraySetLength(null, 0, 10);',
|
|
' var ArrByteChar = rtl.arraySetLength(null, 0, 256, 10);',
|
|
' var i = 0;',
|
|
' var c = "";',
|
|
' var o = null;',
|
|
' i = rtl.rc(Arr[1], 1, 10);',
|
|
' i = rtl.rc(ArrByteChar[1][2], 1, 10);',
|
|
' Arr[1] = rtl.rc(Arr[1], 1, 10);',
|
|
' rtl.rcArrW(Arr, i, rtl.rcArrR(Arr, i));',
|
|
' ArrByte[3] = rtl.rc(ArrByte[3], 1, 10);',
|
|
' rtl.rcArrW(ArrByte, i, rtl.rcArrR(ArrByte, i));',
|
|
' ArrChar[5] = rtl.rc(ArrChar[5], 1, 10);',
|
|
' rtl.rcArrW(ArrChar, c.charCodeAt() - 48, rtl.rcArrR(ArrChar, c.charCodeAt() - 48));',
|
|
' ArrByteChar[7][7] = rtl.rc(ArrByteChar[7][7], 1, 10);',
|
|
' rtl.rcArrW(ArrByteChar, i, c.charCodeAt() - 48, rtl.rcArrR(ArrByteChar, i, c.charCodeAt() - 48));',
|
|
' o.A[i] = rtl.rc(o.A[i], 1, 10);',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRangeChecks_StringIndex;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'type',
|
|
' TObject = class',
|
|
' S: string;',
|
|
' end;',
|
|
'{$R+}',
|
|
'procedure DoIt(var h: string);',
|
|
'var',
|
|
' s: string;',
|
|
' i: longint;',
|
|
' c: char;',
|
|
' o: tobject;',
|
|
'begin',
|
|
' c:=s[1];',
|
|
' s[i]:=s[i];',
|
|
' h[i]:=h[i];',
|
|
' c:=o.s[i];',
|
|
'end;',
|
|
'begin',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRangeChecks_StringIndex',
|
|
LinesToStr([ // statements
|
|
'rtl.createClass($mod, "TObject", null, function () {',
|
|
' this.$init = function () {',
|
|
' this.S = "";',
|
|
' };',
|
|
' this.$final = function () {',
|
|
' };',
|
|
'});',
|
|
'this.DoIt = function (h) {',
|
|
' var s = "";',
|
|
' var i = 0;',
|
|
' var c = "";',
|
|
' var o = null;',
|
|
' c = rtl.rcc(rtl.rcCharAt(s, 0), 0, 65535);',
|
|
' s = rtl.rcSetCharAt(s, i - 1, rtl.rcCharAt(s, i - 1));',
|
|
' h.set(rtl.rcSetCharAt(h.get(), i - 1, rtl.rcCharAt(h.get(), i - 1)));',
|
|
' c = rtl.rcc(o.S.charAt(i - 1), 0, 65535);',
|
|
'};',
|
|
'']),
|
|
LinesToStr([ // $mod.$main
|
|
'']));
|
|
end;
|
|
|
|
procedure TTestModule.TestRangeChecks_TypecastInt;
|
|
begin
|
|
StartProgram(false);
|
|
Add([
|
|
'{$R+}',
|
|
'var',
|
|
' i: nativeint;',
|
|
' b: byte;',
|
|
' sh: shortint;',
|
|
' w: word;',
|
|
' sm: smallint;',
|
|
' lw: longword;',
|
|
' li: longint;',
|
|
'begin',
|
|
' b:=12+byte(i);',
|
|
' sh:=12+shortint(i);',
|
|
' w:=12+word(i);',
|
|
' sm:=12+smallint(i);',
|
|
' lw:=12+longword(i);',
|
|
' li:=12+longint(i);',
|
|
'']);
|
|
ConvertProgram;
|
|
CheckSource('TestRangeChecks_TypecastInt',
|
|
LinesToStr([
|
|
'this.i = 0;',
|
|
'this.b = 0;',
|
|
'this.sh = 0;',
|
|
'this.w = 0;',
|
|
'this.sm = 0;',
|
|
'this.lw = 0;',
|
|
'this.li = 0;',
|
|
'']),
|
|
LinesToStr([
|
|
'$mod.b = rtl.rc(12 + rtl.rc($mod.i, 0, 255), 0, 255);',
|
|
'$mod.sh = rtl.rc(12 + rtl.rc($mod.i, -128, 127), -128, 127);',
|
|
'$mod.w = rtl.rc(12 + rtl.rc($mod.i, 0, 65535), 0, 65535);',
|
|
'$mod.sm = rtl.rc(12 + rtl.rc($mod.i, -32768, 32767), -32768, 32767);',
|
|
'$mod.lw = rtl.rc(12 + rtl.rc($mod.i, 0, 4294967295), 0, 4294967295);',
|
|
'$mod.li = rtl.rc(12 + rtl.rc($mod.i, -2147483648, 2147483647), -2147483648, 2147483647);',
|
|
'']));
|
|
end;
|
|
|
|
Initialization
|
|
RegisterTests([TTestModule]);
|
|
end.
|
|
|