pastojs: array of const

git-svn-id: trunk@41327 -
This commit is contained in:
Mattias Gaertner 2019-02-15 22:38:44 +00:00
parent 28e509f8f9
commit d4512cc714
11 changed files with 711 additions and 83 deletions

1
.gitattributes vendored
View File

@ -7029,6 +7029,7 @@ packages/pastojs/src/pas2jslibcompiler.pp svneol=native#text/plain
packages/pastojs/src/pas2jslogger.pp svneol=native#text/plain packages/pastojs/src/pas2jslogger.pp svneol=native#text/plain
packages/pastojs/src/pas2jspcucompiler.pp svneol=native#text/plain packages/pastojs/src/pas2jspcucompiler.pp svneol=native#text/plain
packages/pastojs/src/pas2jspparser.pp svneol=native#text/plain packages/pastojs/src/pas2jspparser.pp svneol=native#text/plain
packages/pastojs/src/pas2jsuseanalyzer.pp svneol=native#text/plain
packages/pastojs/src/pas2jsutils.pp svneol=native#text/plain packages/pastojs/src/pas2jsutils.pp svneol=native#text/plain
packages/pastojs/tests/tcconverter.pp svneol=native#text/plain packages/pastojs/tests/tcconverter.pp svneol=native#text/plain
packages/pastojs/tests/tcfiler.pas svneol=native#text/plain packages/pastojs/tests/tcfiler.pas svneol=native#text/plain

View File

@ -55,6 +55,7 @@ begin
T.Dependencies.AddInclude('pas2jsfileutilswin.inc',AllWindowsOSes); T.Dependencies.AddInclude('pas2jsfileutilswin.inc',AllWindowsOSes);
T:=P.Targets.AddUnit('pas2jslogger.pp'); T:=P.Targets.AddUnit('pas2jslogger.pp');
T:=P.Targets.AddUnit('pas2jspparser.pp'); T:=P.Targets.AddUnit('pas2jspparser.pp');
T:=P.Targets.AddUnit('pas2jsuseanalyzer.pp');
T:=P.Targets.AddUnit('pas2jscompiler.pp'); T:=P.Targets.AddUnit('pas2jscompiler.pp');
T:=P.Targets.AddUnit('pas2jsfscompiler.pp'); T:=P.Targets.AddUnit('pas2jsfscompiler.pp');
T.Dependencies.AddUnit('pas2jscompiler'); T.Dependencies.AddUnit('pas2jscompiler');

View File

@ -87,6 +87,7 @@ Works:
- skip clone record of new record - skip clone record of new record
- use rtl.recNewT to create a record type - use rtl.recNewT to create a record type
- use TRec.$new to instantiate records, using Object.create to instantiate - use TRec.$new to instantiate records, using Object.create to instantiate
- record field external name
- advanced records: - advanced records:
- public, private, strict private - public, private, strict private
- class var - class var
@ -396,6 +397,7 @@ Works:
- pass property getter field, property getter function, - pass property getter field, property getter function,
- pass class property, static class property - pass class property, static class property
- pass array property - pass array property
- array of const, TVarRec
ToDos: ToDos:
- cmd line param to set modeswitch - cmd line param to set modeswitch
@ -418,7 +420,6 @@ ToDos:
- range check: - range check:
arr[i]:=value check if value is in range arr[i]:=value check if value is in range
astring[i]:=value check if value is in range astring[i]:=value check if value is in range
- record field external name
- 1 as TEnum, ERangeError - 1 as TEnum, ERangeError
- ifthen<T> - ifthen<T>
- stdcall of methods: pass original 'this' as first parameter - stdcall of methods: pass original 'this' as first parameter
@ -1067,6 +1068,7 @@ type
TPas2JSModuleScope = class(TPasModuleScope) TPas2JSModuleScope = class(TPasModuleScope)
public public
SystemVarRecs: TPasFunction;
end; end;
{ TPas2JSSectionScope } { TPas2JSSectionScope }
@ -1304,6 +1306,12 @@ type
procedure FinishArgument(El: TPasArgument); override; procedure FinishArgument(El: TPasArgument); override;
procedure FinishProcedureType(El: TPasProcedureType); override; procedure FinishProcedureType(El: TPasProcedureType); override;
procedure FinishProperty(PropEl: TPasProperty); override; procedure FinishProperty(PropEl: TPasProperty); override;
procedure FinishProcParamAccess(ProcType: TPasProcedureType;
Params: TParamsExpr); override;
procedure FinishPropertyParamAccess(Params: TParamsExpr; Prop: TPasProperty
); override;
procedure FindCreatorArrayOfConst(Args: TFPList; ErrorEl: TPasElement);
function FindProc_ArrLitToArrayOfConst(ErrorEl: TPasElement): TPasFunction; virtual;
procedure CheckExternalClassConstructor(Ref: TResolvedReference); virtual; procedure CheckExternalClassConstructor(Ref: TResolvedReference); virtual;
procedure CheckConditionExpr(El: TPasExpr; procedure CheckConditionExpr(El: TPasExpr;
const ResolvedEl: TPasResolverResult); override; const ResolvedEl: TPasResolverResult); override;
@ -1974,6 +1982,31 @@ type
otUIntDouble // 7 NativeUInt otUIntDouble // 7 NativeUInt
); );
Function GetOrdType(MinValue, MaxValue: TMaxPrecInt; ErrorEl: TPasElement): TOrdType; virtual; Function GetOrdType(MinValue, MaxValue: TMaxPrecInt; ErrorEl: TPasElement): TOrdType; virtual;
Public
// array of const, TVarRec
const
pas2js_vtInteger = 0;
pas2js_vtBoolean = 1;
//vtChar = 2; // Delphi/FPC: ansichar
pas2js_vtExtended = 3; // Note: double in pas2js, PExtended in Delphi/FPC
//vtString = 4; // Delphi/FPC: PShortString
pas2js_vtPointer = 5;
//vtPChar = 6;
pas2js_vtObject = 7;
pas2js_vtClass = 8;
pas2js_vtWideChar = 9;
//vtPWideChar = 10;
//vtAnsiString = 11;
pas2js_vtCurrency = 12; // Note: currency in pas2js, PCurrency in Delphi/FPC
//vtVariant = 13;
pas2js_vtInterface = 14;
//vtWideString = 15;
//vtInt64 = 16;
//vtQWord = 17;
pas2js_vtUnicodeString = 18;
// only pas2js, not in Delphi/FPC:
pas2js_vtNativeInt = 19;
pas2js_vtJSValue = 20;
Public Public
Constructor Create; Constructor Create;
Destructor Destroy; override; Destructor Destroy; override;
@ -3952,6 +3985,87 @@ begin
end; end;
end; end;
procedure TPas2JSResolver.FinishProcParamAccess(ProcType: TPasProcedureType;
Params: TParamsExpr);
begin
inherited FinishProcParamAccess(ProcType, Params);
FindCreatorArrayOfConst(ProcType.Args,Params);
end;
procedure TPas2JSResolver.FinishPropertyParamAccess(Params: TParamsExpr;
Prop: TPasProperty);
var
Args: TFPList;
begin
inherited FinishPropertyParamAccess(Params, Prop);
Args:=GetPasPropertyArgs(Prop);
if Args=nil then
RaiseNotYetImplemented(20190215210914,Params,GetObjName(Prop));
FindCreatorArrayOfConst(Args,Params);
end;
procedure TPas2JSResolver.FindCreatorArrayOfConst(Args: TFPList;
ErrorEl: TPasElement);
var
i: Integer;
Arg: TPasArgument;
begin
for i:=0 to Args.Count-1 do
begin
Arg:=TPasArgument(Args[i]);
if not IsArrayOfConst(Arg.ArgType) then continue;
FindProc_ArrLitToArrayOfConst(ErrorEl);
end;
end;
function TPas2JSResolver.FindProc_ArrLitToArrayOfConst(ErrorEl: TPasElement
): TPasFunction;
var
aMod, UtilsMod: TPasModule;
ModScope: TPas2JSModuleScope;
SectionScope: TPasSectionScope;
Identifier: TPasIdentifier;
El: TPasElement;
FuncType: TPasFunctionType;
begin
aMod:=RootElement;
ModScope:=aMod.CustomData as TPas2JSModuleScope;
Result:=ModScope.SystemVarRecs;
if Result<>nil then exit;
// find unit in uses clauses
UtilsMod:=FindUsedUnit('system',aMod);
if UtilsMod=nil then
RaiseIdentifierNotFound(20190215211531,'System.VarRecs',ErrorEl);
// find class in interface
if UtilsMod.InterfaceSection=nil then
RaiseIdentifierNotFound(20190215211538,'System.VarRecs',ErrorEl);
// find function VarRecs
SectionScope:=NoNil(UtilsMod.InterfaceSection.CustomData) as TPasSectionScope;
Identifier:=SectionScope.FindLocalIdentifier('VarRecs');
if Identifier=nil then
RaiseIdentifierNotFound(20190215211551,'System.VarRecs',ErrorEl);
El:=Identifier.Element;
if El.ClassType<>TPasFunction then
RaiseXExpectedButYFound(20190215211559,'function System.VarRecs',GetElementTypeName(El),ErrorEl);
Result:=TPasFunction(El);
ModScope.SystemVarRecs:=Result;
// check signature
FuncType:=Result.ProcType as TPasFunctionType;
if FuncType.Args.Count>0 then
RaiseXExpectedButYFound(20190215211953,'function System.VarRecs with 0 args',
IntToStr(FuncType.Args.Count),ErrorEl);
if FuncType.Modifiers<>[ptmVarargs] then
RaiseXExpectedButYFound(20190215212151,'function System.VarRecs; varargs',
'?',ErrorEl);
if FuncType.CallingConvention<>ccDefault then
RaiseXExpectedButYFound(20190215211824,'function System.VarRecs with default calling convention',
cCallingConventions[FuncType.CallingConvention],ErrorEl);
end;
procedure TPas2JSResolver.CheckExternalClassConstructor(Ref: TResolvedReference procedure TPas2JSResolver.CheckExternalClassConstructor(Ref: TResolvedReference
); );
var var
@ -4253,7 +4367,7 @@ begin
exit; exit;
if (RHS.BaseType<>btContext) or (RTypeEl.ClassType<>TPasArrayType) then if (RHS.BaseType<>btContext) or (RTypeEl.ClassType<>TPasArrayType) then
exit; exit;
ComputeElement(LArray.ElType,ElTypeResolved,[rcType]); ComputeElement(GetArrayElType(LArray),ElTypeResolved,[rcType]);
if IsJSBaseType(ElTypeResolved,pbtJSValue) then if IsJSBaseType(ElTypeResolved,pbtJSValue) then
begin begin
// array of jsvalue := array // array of jsvalue := array
@ -8555,7 +8669,7 @@ var
break; break;
// continue in sub array // continue in sub array
ArrayEl:=AContext.Resolver.ResolveAliasType(ArrayEl.ElType) as TPasArrayType; ArrayEl:=AContext.Resolver.ResolveAliasType(ArrayEl.ElType) as TPasArrayType;
until false; until ArrayEl=nil;
IsRangeCheck:=NeedRangeCheck IsRangeCheck:=NeedRangeCheck
and (bsRangeChecks in AContext.ScannerBoolSwitches) and (bsRangeChecks in AContext.ScannerBoolSwitches)
@ -10107,12 +10221,14 @@ var
AssignContext: TAssignContext; AssignContext: TAssignContext;
ElType, TypeEl: TPasType; ElType, TypeEl: TPasType;
i: Integer; i: Integer;
aResolver: TPas2JSResolver;
begin begin
Result:=nil; Result:=nil;
Param0:=El.Params[0]; Param0:=El.Params[0];
if AContext.Access<>caRead then if AContext.Access<>caRead then
RaiseInconsistency(20170213213621,El); RaiseInconsistency(20170213213621,El);
AContext.Resolver.ComputeElement(Param0,ResolvedParam0,[rcNoImplicitProc]); aResolver:=AContext.Resolver;
aResolver.ComputeElement(Param0,ResolvedParam0,[rcNoImplicitProc]);
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasToJSConverter.ConvertBuiltInSetLength ',GetResolverResultDbg(ResolvedParam0)); writeln('TPasToJSConverter.ConvertBuiltInSetLength ',GetResolverResultDbg(ResolvedParam0));
{$ENDIF} {$ENDIF}
@ -10128,7 +10244,7 @@ begin
// -> AnArray = rtl.setArrayLength(AnArray,defaultvalue,dim1,dim2,...) // -> AnArray = rtl.setArrayLength(AnArray,defaultvalue,dim1,dim2,...)
AssignContext:=TAssignContext.Create(El,nil,AContext); AssignContext:=TAssignContext.Create(El,nil,AContext);
try try
AContext.Resolver.ComputeElement(Param0,AssignContext.LeftResolved,[rcNoImplicitProc]); aResolver.ComputeElement(Param0,AssignContext.LeftResolved,[rcNoImplicitProc]);
AssignContext.RightResolved:=ResolvedParam0; AssignContext.RightResolved:=ResolvedParam0;
// create right side // create right side
@ -10141,10 +10257,10 @@ begin
// 2nd param: default value // 2nd param: default value
for i:=3 to length(El.Params) do for i:=3 to length(El.Params) do
begin begin
ElType:=AContext.Resolver.ResolveAliasType(ArrayType.ElType); ElType:=aResolver.ResolveAliasType(aResolver.GetArrayElType(ArrayType));
ArrayType:=ElType as TPasArrayType; ArrayType:=ElType as TPasArrayType;
end; end;
ElType:=AContext.Resolver.ResolveAliasType(ArrayType.ElType); ElType:=aResolver.ResolveAliasType(aResolver.GetArrayElType(ArrayType));
if ElType.ClassType=TPasRecordType then if ElType.ClassType=TPasRecordType then
ValInit:=CreateReferencePathExpr(ElType,AContext) ValInit:=CreateReferencePathExpr(ElType,AContext)
else else
@ -10169,7 +10285,7 @@ begin
{$ENDIF} {$ENDIF}
AssignContext:=TAssignContext.Create(El,nil,AContext); AssignContext:=TAssignContext.Create(El,nil,AContext);
try try
AContext.Resolver.ComputeElement(Param0,AssignContext.LeftResolved,[rcNoImplicitProc]); aResolver.ComputeElement(Param0,AssignContext.LeftResolved,[rcNoImplicitProc]);
AssignContext.RightResolved:=AssignContext.LeftResolved; AssignContext.RightResolved:=AssignContext.LeftResolved;
// create right side rtl.strSetLength(aString,NewLen) // create right side rtl.strSetLength(aString,NewLen)
@ -11395,17 +11511,19 @@ var
TypeParam: TJSElement; TypeParam: TJSElement;
Call: TJSCallExpression; Call: TJSCallExpression;
ArrayType: TPasArrayType; ArrayType: TPasArrayType;
aResolver: TPas2JSResolver;
begin begin
Result:=nil; Result:=nil;
aResolver:=AContext.Resolver;
Call:=nil; Call:=nil;
try try
Param:=El.Params[0]; Param:=El.Params[0];
AContext.Resolver.ComputeElement(El,ParamResolved,[]); aResolver.ComputeElement(El,ParamResolved,[]);
if (ParamResolved.BaseType=btContext) if (ParamResolved.BaseType=btContext)
and (ParamResolved.LoTypeEl.ClassType=TPasArrayType) then and (ParamResolved.LoTypeEl.ClassType=TPasArrayType) then
begin begin
ArrayType:=TPasArrayType(ParamResolved.LoTypeEl); ArrayType:=TPasArrayType(ParamResolved.LoTypeEl);
AContext.Resolver.ComputeElement(ArrayType.ElType,ElTypeResolved,[rcType]); aResolver.ComputeElement(aResolver.GetArrayElType(ArrayType),ElTypeResolved,[rcType]);
end end
else if ParamResolved.BaseType=btArrayLit then else if ParamResolved.BaseType=btArrayLit then
begin begin
@ -14906,16 +15024,23 @@ function TPasToJSConverter.CreateArrayConcat(ArrayType: TPasArrayType;
PosEl: TPasElement; AContext: TConvertContext): TJSCallExpression; PosEl: TPasElement; AContext: TConvertContext): TJSCallExpression;
var var
ElTypeResolved: TPasResolverResult; ElTypeResolved: TPasResolverResult;
aResolver: TPas2JSResolver;
begin begin
if length(ArrayType.Ranges)>1 then if length(ArrayType.Ranges)>1 then
RaiseNotSupported(PosEl,AContext,20170331001021); RaiseNotSupported(PosEl,AContext,20170331001021);
AContext.Resolver.ComputeElement(ArrayType.ElType,ElTypeResolved,[rcType]); aResolver:=AContext.Resolver;
aResolver.ComputeElement(aResolver.GetArrayElType(ArrayType),ElTypeResolved,[rcType]);
Result:=CreateArrayConcat(ElTypeResolved,PosEl,AContext); Result:=CreateArrayConcat(ElTypeResolved,PosEl,AContext);
end; end;
function TPasToJSConverter.CreateArrayInit(ArrayType: TPasArrayType; function TPasToJSConverter.CreateArrayInit(ArrayType: TPasArrayType;
Expr: TPasExpr; El: TPasElement; AContext: TConvertContext): TJSElement; Expr: TPasExpr; El: TPasElement; AContext: TConvertContext): TJSElement;
function IsAdd(AnExpr: TPasExpr): Boolean;
begin
Result:=(AnExpr.ClassType=TBinaryExpr) and (AnExpr.OpCode=eopAdd);
end;
function ConvertArrayExpr(CurArrType: TPasArrayType; RgIndex: integer; function ConvertArrayExpr(CurArrType: TPasArrayType; RgIndex: integer;
CurExpr: TPasExpr): TJSElement; CurExpr: TPasExpr): TJSElement;
var var
@ -14947,11 +15072,6 @@ function TPasToJSConverter.CreateArrayInit(ArrayType: TPasArrayType;
end; end;
end; end;
function IsAdd(AnExpr: TPasExpr): Boolean;
begin
Result:=(AnExpr.ClassType=TBinaryExpr) and (AnExpr.OpCode=eopAdd);
end;
procedure TraverseAdd(Bin: TBinaryExpr; ConcatCall: TJSCallExpression); procedure TraverseAdd(Bin: TBinaryExpr; ConcatCall: TJSCallExpression);
// A+B -> A,B // A+B -> A,B
// (A+B)+C -> A,B,C // (A+B)+C -> A,B,C
@ -14969,6 +15089,7 @@ function TPasToJSConverter.CreateArrayInit(ArrayType: TPasArrayType;
var var
ElTypeResolved: TPasResolverResult; ElTypeResolved: TPasResolverResult;
Call: TJSCallExpression; Call: TJSCallExpression;
aResolver: TPas2JSResolver;
begin begin
Result:=nil; Result:=nil;
IsLastRange:=false; IsLastRange:=false;
@ -14976,7 +15097,8 @@ function TPasToJSConverter.CreateArrayInit(ArrayType: TPasArrayType;
NextRgIndex:=RgIndex+1; NextRgIndex:=RgIndex+1;
if RgIndex>=length(CurArrType.Ranges)-1 then if RgIndex>=length(CurArrType.Ranges)-1 then
begin begin
AContext.Resolver.ComputeElement(CurArrType.ElType,ElTypeResolved,[rcType]); aResolver:=AContext.Resolver;
aResolver.ComputeElement(aResolver.GetArrayElType(CurArrType),ElTypeResolved,[rcType]);
if (ElTypeResolved.BaseType=btContext) if (ElTypeResolved.BaseType=btContext)
and (ElTypeResolved.LoTypeEl.ClassType=TPasArrayType) then and (ElTypeResolved.LoTypeEl.ClassType=TPasArrayType) then
begin begin
@ -15015,6 +15137,112 @@ function TPasToJSConverter.CreateArrayInit(ArrayType: TPasArrayType;
Result:=ConvertExpression(CurExpr,AContext); Result:=ConvertExpression(CurExpr,AContext);
end; end;
function ConvertExprToVarRec(CurExpr: TPasExpr): TJSElement;
// convert [true,Int] to system.varrecs(1,true,0,Int)
var
aResolver: TPas2JSResolver;
Param: TPasExpr;
ParamResolved: TPasResolverResult;
procedure RaiseWrongTypeInArrayConstructor(id: TMaxPrecInt);
begin
aResolver.RaiseMsg(id,nWrongTypeXInArrayConstructor,sWrongTypeXInArrayConstructor,
[aResolver.GetResolverResultDescription(ParamResolved)],Param);
end;
var
Params: TParamsExpr;
ModScope: TPas2JSModuleScope;
Call: TJSCallExpression;
i, VType: Integer;
LoTypeEl: TPasType;
ParamsArr: TPasExprArray;
begin
Result:=nil;
aResolver:=AContext.Resolver;
if IsAdd(CurExpr) then
aResolver.RaiseMsg(20190215222435,nXExpectedButYFound,sXExpectedButYFound,
['array of const',GetElementTypeName(CurExpr)],CurExpr);
if (not (CurExpr is TParamsExpr)) or (TParamsExpr(CurExpr).Kind<>pekSet) then
begin
// e.g. Format(args)
Result:=ConvertExpression(CurExpr,AContext);
exit;
end;
Params:=TParamsExpr(CurExpr);
ParamsArr:=Params.Params;
if length(ParamsArr)=0 then
begin
// e.g. Format([])
Result:=CreateElement(TJSArrayLiteral,Params);
exit;
end;
ModScope:=NoNil(aResolver.RootElement.CustomData) as TPas2JSModuleScope;
if ModScope.SystemVarRecs=nil then
RaiseNotSupported(Params,AContext,20190215215148);
Call:=CreateCallExpression(Params);
try
Call.Expr:=CreateReferencePathExpr(ModScope.SystemVarRecs,AContext);
for i:=0 to length(ParamsArr)-1 do
begin
Param:=ParamsArr[i];
aResolver.ComputeElement(Param,ParamResolved,[]);
if not (rrfReadable in ParamResolved.Flags) then
begin
if (ParamResolved.BaseType=btContext)
and (ParamResolved.IdentEl is TPasClassType)
and (TPasClassType(ParamResolved.IdentEl).ObjKind=okClass) then
VType:=pas2js_vtClass
else
RaiseWrongTypeInArrayConstructor(20190215221549);
end
else if ParamResolved.BaseType in [btByte,btShortInt,btWord,btSmallInt,btLongint] then
VType:=pas2js_vtInteger
else if ParamResolved.BaseType in [btLongWord,btUIntDouble,btIntDouble] then
VType:=pas2js_vtNativeInt
else if ParamResolved.BaseType in btAllJSBooleans then
VType:=pas2js_vtBoolean
else if ParamResolved.BaseType in btAllJSFloats then
VType:=pas2js_vtExtended
else if ParamResolved.BaseType in btAllJSChars then
VType:=pas2js_vtWideChar
else if ParamResolved.BaseType in btAllJSStrings then
VType:=pas2js_vtUnicodeString
else if ParamResolved.BaseType in [btNil,btPointer] then
VType:=pas2js_vtPointer
else if ParamResolved.BaseType=btCurrency then
VType:=pas2js_vtCurrency
else if ParamResolved.BaseType=btContext then
begin
LoTypeEl:=ParamResolved.LoTypeEl;
if LoTypeEl.ClassType=TPasClassType then
case TPasClassType(LoTypeEl).ObjKind of
okClass: VType:=pas2js_vtObject;
okInterface: VType:=pas2js_vtInterface;
else
RaiseWrongTypeInArrayConstructor(20190215221106);
end
else if LoTypeEl.ClassType=TPasClassOfType then
VType:=pas2js_vtClass
else
RaiseWrongTypeInArrayConstructor(20190215221122);
end
else if (ParamResolved.BaseType=btCustom)
and aResolver.IsJSBaseType(ParamResolved,pbtJSValue) then
VType:=pas2js_vtJSValue
else
RaiseWrongTypeInArrayConstructor(20190215221457);
Call.AddArg(CreateLiteralNumber(Param,VType));
Call.AddArg(ConvertExpression(Param,AContext));
end;
Result:=Call;
finally
if Result=nil then
Call.Free;
end;
end;
var var
Call: TJSCallExpression; Call: TJSCallExpression;
ArrLit: TJSArrayLiteral; ArrLit: TJSArrayLiteral;
@ -15027,7 +15255,6 @@ var
US: TJSString; US: TJSString;
DimLits: TObjectList; DimLits: TObjectList;
aResolver: TPas2JSResolver; aResolver: TPas2JSResolver;
CompFlags: TPasResolverComputeFlags;
begin begin
{$IFDEF VerbosePas2JS} {$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateArrayInit ',GetObjName(ArrayType),' ',ArrayType.ParentPath,' Expr=',GetObjName(Expr)); writeln('TPasToJSConverter.CreateArrayInit ',GetObjName(ArrayType),' ',ArrayType.ParentPath,' Expr=',GetObjName(Expr));
@ -15035,18 +15262,19 @@ begin
aResolver:=AContext.Resolver; aResolver:=AContext.Resolver;
if Assigned(Expr) then if Assigned(Expr) then
begin begin
// init array with constant(s) // init array with expression
if aResolver=nil then if aResolver=nil then
DoError(20161024192739,nInitializedArraysNotSupported,sInitializedArraysNotSupported,[],ArrayType); DoError(20161024192739,nInitializedArraysNotSupported,sInitializedArraysNotSupported,[],ArrayType);
if aResolver.ExprEvaluator.IsConst(Expr) then aResolver.ComputeElement(Expr,ExprResolved,[]);
CompFlags:=[rcConstant]
else
CompFlags:=[];
aResolver.ComputeElement(Expr,ExprResolved,CompFlags);
if (ExprResolved.BaseType in [btArrayOrSet,btArrayLit]) if (ExprResolved.BaseType in [btArrayOrSet,btArrayLit])
or ((ExprResolved.BaseType=btContext) or ((ExprResolved.BaseType=btContext)
and (ExprResolved.LoTypeEl.ClassType=TPasArrayType)) then and (ExprResolved.LoTypeEl.ClassType=TPasArrayType)) then
Result:=ConvertArrayExpr(ArrayType,0,Expr) begin
if ArrayType.ElType=nil then
Result:=ConvertExprToVarRec(Expr)
else
Result:=ConvertArrayExpr(ArrayType,0,Expr);
end
else if ExprResolved.BaseType in btAllStringAndChars then else if ExprResolved.BaseType in btAllStringAndChars then
begin begin
US:=StrToJSString(aResolver.ComputeConstString(Expr,false,true)); US:=StrToJSString(aResolver.ComputeConstString(Expr,false,true));
@ -15094,7 +15322,7 @@ begin
Lit:=CreateLiteralNumber(El,DimSize); Lit:=CreateLiteralNumber(El,DimSize);
DimLits.Add(Lit); DimLits.Add(Lit);
end; end;
aResolver.ComputeElement(CurArrayType.ElType,ElTypeResolved,[rcType]); aResolver.ComputeElement(aResolver.GetArrayElType(CurArrayType),ElTypeResolved,[rcType]);
if (ElTypeResolved.LoTypeEl is TPasArrayType) then if (ElTypeResolved.LoTypeEl is TPasArrayType) then
begin begin
CurArrayType:=TPasArrayType(ElTypeResolved.LoTypeEl); CurArrayType:=TPasArrayType(ElTypeResolved.LoTypeEl);
@ -16034,7 +16262,9 @@ var
ArgName: String; ArgName: String;
Flags: Integer; Flags: Integer;
ArrType: TPasArrayType; ArrType: TPasArrayType;
aResolver: TPas2JSResolver;
begin begin
aResolver:=AContext.Resolver;
// for each param add "["argname",argtype,flags]" Note: flags only if >0 // for each param add "["argname",argtype,flags]" Note: flags only if >0
Param:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,Arg)); Param:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,Arg));
TargetParams.Elements.AddElement.Expr:=Param; TargetParams.Elements.AddElement.Expr:=Param;
@ -16051,7 +16281,8 @@ begin
// open array param // open array param
inc(Flags,pfArray); inc(Flags,pfArray);
ArrType:=TPasArrayType(Arg.ArgType); ArrType:=TPasArrayType(Arg.ArgType);
Param.Elements.AddElement.Expr:=CreateTypeInfoRef(ArrType.ElType,AContext,Arg); Param.Elements.AddElement.Expr:=
CreateTypeInfoRef(aResolver.GetArrayElType(ArrType),AContext,Arg);
end end
else else
Param.Elements.AddElement.Expr:=CreateTypeInfoRef(Arg.ArgType,AContext,Arg); Param.Elements.AddElement.Expr:=CreateTypeInfoRef(Arg.ArgType,AContext,Arg);

View File

@ -38,8 +38,8 @@ uses
// !! No filesystem units here. // !! No filesystem units here.
Classes, SysUtils, contnrs, Classes, SysUtils, contnrs,
jsbase, jstree, jswriter, JSSrcMap, jsbase, jstree, jswriter, JSSrcMap,
PScanner, PParser, PasTree, PasResolver, PasUseAnalyzer, PasResolveEval, PScanner, PParser, PasTree, PasResolver, PasResolveEval, PasUseAnalyzer,
FPPas2Js, FPPJsSrcMap, Pas2jsLogger, Pas2jsFS, Pas2jsPParser; FPPas2Js, FPPJsSrcMap, Pas2jsLogger, Pas2jsFS, Pas2jsPParser, Pas2jsUseAnalyzer;
const const
VersionMajor = 1; VersionMajor = 1;
@ -346,7 +346,7 @@ type
FScanner: TPas2jsPasScanner; FScanner: TPas2jsPasScanner;
FShowDebug: boolean; FShowDebug: boolean;
FUnitFilename: string; FUnitFilename: string;
FUseAnalyzer: TPasAnalyzer; FUseAnalyzer: TPas2JSAnalyzer;
FUsedBy: array[TUsedBySection] of TFPList; // list of TPas2jsCompilerFile FUsedBy: array[TUsedBySection] of TFPList; // list of TPas2jsCompilerFile
function GetUsedBy(Section: TUsedBySection; Index: integer): TPas2jsCompilerFile; function GetUsedBy(Section: TUsedBySection; Index: integer): TPas2jsCompilerFile;
function GetUsedByCount(Section: TUsedBySection): integer; function GetUsedByCount(Section: TUsedBySection): integer;
@ -413,7 +413,7 @@ type
property Scanner: TPas2jsPasScanner read FScanner; property Scanner: TPas2jsPasScanner read FScanner;
property ShowDebug: boolean read FShowDebug write FShowDebug; property ShowDebug: boolean read FShowDebug write FShowDebug;
property UnitFilename: string read FUnitFilename; property UnitFilename: string read FUnitFilename;
property UseAnalyzer: TPasAnalyzer read FUseAnalyzer; // unit analysis property UseAnalyzer: TPas2JSAnalyzer read FUseAnalyzer; // unit analysis
property UsedByCount[Section: TUsedBySection]: integer read GetUsedByCount; property UsedByCount[Section: TUsedBySection]: integer read GetUsedByCount;
property UsedBy[Section: TUsedBySection; Index: integer]: TPas2jsCompilerFile read GetUsedBy; property UsedBy[Section: TUsedBySection; Index: integer]: TPas2jsCompilerFile read GetUsedBy;
end; end;
@ -454,11 +454,6 @@ type
property Compiler: TPas2jsCompiler Read FCompiler; property Compiler: TPas2jsCompiler Read FCompiler;
end; end;
{ TPas2JSWPOptimizer }
TPas2JSWPOptimizer = class(TPasAnalyzer)
end;
{ TPas2jsCompiler } { TPas2jsCompiler }
TPas2jsCompiler = class TPas2jsCompiler = class
@ -484,7 +479,7 @@ type
FParamMacros: TPas2jsMacroEngine; FParamMacros: TPas2jsMacroEngine;
FSrcMapSourceRoot: string; FSrcMapSourceRoot: string;
FUnits: TPasAnalyzerKeySet; // set of TPas2jsCompilerFile, key is PasUnitName FUnits: TPasAnalyzerKeySet; // set of TPas2jsCompilerFile, key is PasUnitName
FWPOAnalyzer: TPas2JSWPOptimizer; FWPOAnalyzer: TPas2JSAnalyzer;
FInterfaceType: TPasClassInterfaceType; FInterfaceType: TPasClassInterfaceType;
FPrecompileGUID: TGUID; FPrecompileGUID: TGUID;
FInsertFilenames: TStringList; FInsertFilenames: TStringList;
@ -564,7 +559,7 @@ type
function CreateLog: TPas2jsLogger; virtual; function CreateLog: TPas2jsLogger; virtual;
function CreateMacroEngine: TPas2jsMacroEngine;virtual; function CreateMacroEngine: TPas2jsMacroEngine;virtual;
function CreateSrcMap(const aFileName: String): TPas2JSSrcMap; virtual; function CreateSrcMap(const aFileName: String): TPas2JSSrcMap; virtual;
function CreateOptimizer: TPas2JSWPOptimizer; function CreateOptimizer: TPas2JSAnalyzer;
// These are mandatory ! // These are mandatory !
function CreateSetOfCompilerFiles(keyType: TKeyCompareType): TPasAnalyzerKeySet; virtual; abstract; function CreateSetOfCompilerFiles(keyType: TKeyCompareType): TPasAnalyzerKeySet; virtual; abstract;
function CreateFS: TPas2JSFS; virtual; abstract; function CreateFS: TPas2JSFS; virtual; abstract;
@ -672,7 +667,7 @@ type
property SkipDefaultConfig: Boolean read GetSkipDefaultConfig write SetSkipDefaultConfig; property SkipDefaultConfig: Boolean read GetSkipDefaultConfig write SetSkipDefaultConfig;
property TargetPlatform: TPasToJsPlatform read GetTargetPlatform write SetTargetPlatform; property TargetPlatform: TPasToJsPlatform read GetTargetPlatform write SetTargetPlatform;
property TargetProcessor: TPasToJsProcessor read GetTargetProcessor write SetTargetProcessor; property TargetProcessor: TPasToJsProcessor read GetTargetProcessor write SetTargetProcessor;
property WPOAnalyzer: TPas2JSWPOptimizer read FWPOAnalyzer; // Whole Program Optimization property WPOAnalyzer: TPas2JSAnalyzer read FWPOAnalyzer; // Whole Program Optimization
property WriteDebugLog: boolean read GetWriteDebugLog write SetWriteDebugLog; property WriteDebugLog: boolean read GetWriteDebugLog write SetWriteDebugLog;
property WriteMsgToStdErr: boolean read GetWriteMsgToStdErr write SetWriteMsgToStdErr; property WriteMsgToStdErr: boolean read GetWriteMsgToStdErr write SetWriteMsgToStdErr;
property AllJSIntoMainJS: Boolean Read FAllJSIntoMainJS Write SetAllJSIntoMainJS; property AllJSIntoMainJS: Boolean Read FAllJSIntoMainJS Write SetAllJSIntoMainJS;
@ -936,7 +931,7 @@ begin
for ub in TUsedBySection do for ub in TUsedBySection do
FUsedBy[ub]:=TFPList.Create; FUsedBy[ub]:=TFPList.Create;
FUseAnalyzer:=TPasAnalyzer.Create; FUseAnalyzer:=TPas2JSAnalyzer.Create;
FUseAnalyzer.OnMessage:=@OnUseAnalyzerMessage; FUseAnalyzer.OnMessage:=@OnUseAnalyzerMessage;
FUseAnalyzer.Resolver:=FPasResolver; FUseAnalyzer.Resolver:=FPasResolver;
@ -1938,10 +1933,10 @@ begin
Result:=aFile.NeedBuild; Result:=aFile.NeedBuild;
end; end;
function TPas2jsCompiler.CreateOptimizer: TPas2JSWPOptimizer; function TPas2jsCompiler.CreateOptimizer: TPas2JSAnalyzer;
begin begin
Result:=TPas2JSWPOptimizer.Create; Result:=TPas2JSAnalyzer.Create;
end; end;
procedure TPas2jsCompiler.OptimizeProgram(aFile: TPas2jsCompilerFile); procedure TPas2jsCompiler.OptimizeProgram(aFile: TPas2jsCompilerFile);

View File

@ -860,6 +860,8 @@ type
procedure Set_ModScope_AssertMsgConstructor(RefEl: TPasElement; Data: TObject); procedure Set_ModScope_AssertMsgConstructor(RefEl: TPasElement; Data: TObject);
procedure Set_ModScope_RangeErrorClass(RefEl: TPasElement; Data: TObject); procedure Set_ModScope_RangeErrorClass(RefEl: TPasElement; Data: TObject);
procedure Set_ModScope_RangeErrorConstructor(RefEl: TPasElement; Data: TObject); procedure Set_ModScope_RangeErrorConstructor(RefEl: TPasElement; Data: TObject);
procedure Set_ModScope_SystemTVarRec(RefEl: TPasElement; Data: TObject);
procedure Set_ModScope_SystemVarRecs(RefEl: TPasElement; Data: TObject);
procedure Set_EnumTypeScope_CanonicalSet(RefEl: TPasElement; Data: TObject); procedure Set_EnumTypeScope_CanonicalSet(RefEl: TPasElement; Data: TObject);
procedure Set_PropertyScope_AncestorProp(RefEl: TPasElement; Data: TObject); procedure Set_PropertyScope_AncestorProp(RefEl: TPasElement; Data: TObject);
procedure Set_ProcedureScope_ImplProc(RefEl: TPasElement; Data: TObject); procedure Set_ProcedureScope_ImplProc(RefEl: TPasElement; Data: TObject);
@ -2511,6 +2513,8 @@ begin
AddReferenceToObj(Obj,'AssertMsgConstructor',Scope.AssertMsgConstructor); AddReferenceToObj(Obj,'AssertMsgConstructor',Scope.AssertMsgConstructor);
AddReferenceToObj(Obj,'RangeErrorClass',Scope.RangeErrorClass); AddReferenceToObj(Obj,'RangeErrorClass',Scope.RangeErrorClass);
AddReferenceToObj(Obj,'RangeErrorConstructor',Scope.RangeErrorConstructor); AddReferenceToObj(Obj,'RangeErrorConstructor',Scope.RangeErrorConstructor);
AddReferenceToObj(Obj,'SystemTVarRec',Scope.SystemTVarRec);
AddReferenceToObj(Obj,'SystemVarRecs',Scope.SystemVarRecs);
WritePasScope(Obj,Scope,aContext); WritePasScope(Obj,Scope,aContext);
end; end;
@ -4399,6 +4403,28 @@ begin
RaiseMsg(20180211123100,Scope.Element,GetObjName(RefEl)); RaiseMsg(20180211123100,Scope.Element,GetObjName(RefEl));
end; end;
procedure TPCUReader.Set_ModScope_SystemTVarRec(RefEl: TPasElement;
Data: TObject);
var
Scope: TPas2JSModuleScope absolute Data;
begin
if RefEl is TPasRecordType then
Scope.SystemTVarRec:=TPasRecordType(RefEl)
else
RaiseMsg(20190215230826,Scope.Element,GetObjName(RefEl));
end;
procedure TPCUReader.Set_ModScope_SystemVarRecs(RefEl: TPasElement;
Data: TObject);
var
Scope: TPas2JSModuleScope absolute Data;
begin
if RefEl is TPasFunction then
Scope.SystemVarRecs:=TPasFunction(RefEl)
else
RaiseMsg(20190215230857,Scope.Element,GetObjName(RefEl));
end;
procedure TPCUReader.Set_EnumTypeScope_CanonicalSet(RefEl: TPasElement; procedure TPCUReader.Set_EnumTypeScope_CanonicalSet(RefEl: TPasElement;
Data: TObject); Data: TObject);
var var
@ -6262,6 +6288,8 @@ begin
ReadElementReference(Obj,Scope,'AssertMsgConstructor',@Set_ModScope_AssertMsgConstructor); ReadElementReference(Obj,Scope,'AssertMsgConstructor',@Set_ModScope_AssertMsgConstructor);
ReadElementReference(Obj,Scope,'RangeErrorClass',@Set_ModScope_RangeErrorClass); ReadElementReference(Obj,Scope,'RangeErrorClass',@Set_ModScope_RangeErrorClass);
ReadElementReference(Obj,Scope,'RangeErrorConstructor',@Set_ModScope_RangeErrorConstructor); ReadElementReference(Obj,Scope,'RangeErrorConstructor',@Set_ModScope_RangeErrorConstructor);
ReadElementReference(Obj,Scope,'SystemTVarRec',@Set_ModScope_SystemTVarRec);
ReadElementReference(Obj,Scope,'SystemVarRecs',@Set_ModScope_SystemVarRecs);
ReadPasScope(Obj,Scope,aContext); ReadPasScope(Obj,Scope,aContext);
end; end;

View File

@ -0,0 +1,58 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2019 Mattias Gaertner mattias@freepascal.org
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.
**********************************************************************
Abstract:
Extends the FCL Pascal use analyzer for the language subset of pas2js.
}
unit Pas2jsUseAnalyzer;
{$mode objfpc}{$H+}
{$inline on}
interface
uses
Classes, SysUtils,
PasUseAnalyzer, PasTree,
FPPas2Js;
type
{ TPas2JSAnalyzer }
TPas2JSAnalyzer = class(TPasAnalyzer)
public
function UseModule(aModule: TPasModule; Mode: TPAUseMode): boolean;
override;
end;
implementation
{ TPas2JSAnalyzer }
function TPas2JSAnalyzer.UseModule(aModule: TPasModule; Mode: TPAUseMode
): boolean;
var
ModScope: TPas2JSModuleScope;
begin
Result:=inherited UseModule(aModule, Mode);
if not Result then exit;
ModScope:=aModule.CustomData as TPas2JSModuleScope;
if ModScope.SystemVarRecs<>nil then
UseProcedure(ModScope.SystemVarRecs);
end;
end.

View File

@ -24,9 +24,10 @@ interface
uses uses
Classes, SysUtils, fpcunit, testregistry, Classes, SysUtils, fpcunit, testregistry,
jstree,
PasTree, PScanner, PParser, PasResolveEval, PasResolver, PasUseAnalyzer, PasTree, PScanner, PParser, PasResolveEval, PasResolver, PasUseAnalyzer,
FPPas2Js, Pas2JsFiler, Pas2jsUseAnalyzer, FPPas2Js, Pas2JsFiler,
tcmodules, jstree; tcmodules;
type type
@ -34,11 +35,11 @@ type
TCustomTestPrecompile = Class(TCustomTestModule) TCustomTestPrecompile = Class(TCustomTestModule)
private private
FAnalyzer: TPasAnalyzer; FAnalyzer: TPas2JSAnalyzer;
FInitialFlags: TPCUInitialFlags; FInitialFlags: TPCUInitialFlags;
FPCUReader: TPCUReader; FPCUReader: TPCUReader;
FPCUWriter: TPCUWriter; FPCUWriter: TPCUWriter;
FRestAnalyzer: TPasAnalyzer; FRestAnalyzer: TPas2JSAnalyzer;
procedure OnFilerGetSrc(Sender: TObject; aFilename: string; out p: PChar; procedure OnFilerGetSrc(Sender: TObject; aFilename: string; out p: PChar;
out Count: integer); out Count: integer);
function OnConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean; function OnConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean;
@ -121,8 +122,8 @@ type
procedure CheckRestoredProcedure(const Path: string; Orig, Rest: TPasProcedure); virtual; procedure CheckRestoredProcedure(const Path: string; Orig, Rest: TPasProcedure); virtual;
procedure CheckRestoredOperator(const Path: string; Orig, Rest: TPasOperator); virtual; procedure CheckRestoredOperator(const Path: string; Orig, Rest: TPasOperator); virtual;
public public
property Analyzer: TPasAnalyzer read FAnalyzer; property Analyzer: TPas2JSAnalyzer read FAnalyzer;
property RestAnalyzer: TPasAnalyzer read FRestAnalyzer; property RestAnalyzer: TPas2JSAnalyzer read FRestAnalyzer;
property PCUWriter: TPCUWriter read FPCUWriter write FPCUWriter; property PCUWriter: TPCUWriter read FPCUWriter write FPCUWriter;
property PCUReader: TPCUReader read FPCUReader write FPCUReader; property PCUReader: TPCUReader read FPCUReader write FPCUReader;
property InitialFlags: TPCUInitialFlags read FInitialFlags; property InitialFlags: TPCUInitialFlags read FInitialFlags;
@ -155,6 +156,7 @@ type
procedure TestPC_Proc_Arg; procedure TestPC_Proc_Arg;
procedure TestPC_ProcType; procedure TestPC_ProcType;
procedure TestPC_Proc_Anonymous; procedure TestPC_Proc_Anonymous;
procedure TestPC_Proc_ArrayOfConst;
procedure TestPC_Class; procedure TestPC_Class;
procedure TestPC_ClassForward; procedure TestPC_ClassForward;
procedure TestPC_ClassConstructor; procedure TestPC_ClassConstructor;
@ -278,7 +280,7 @@ procedure TCustomTestPrecompile.SetUp;
begin begin
inherited SetUp; inherited SetUp;
FInitialFlags:=TPCUInitialFlags.Create; FInitialFlags:=TPCUInitialFlags.Create;
FAnalyzer:=TPasAnalyzer.Create; FAnalyzer:=TPas2JSAnalyzer.Create;
Analyzer.Resolver:=Engine; Analyzer.Resolver:=Engine;
Analyzer.Options:=Analyzer.Options+[paoImplReferences]; Analyzer.Options:=Analyzer.Options+[paoImplReferences];
Converter.OnIsElementUsed:=@OnConverterIsElementUsed; Converter.OnIsElementUsed:=@OnConverterIsElementUsed;
@ -378,7 +380,7 @@ begin
end; end;
// analyze // analyze
FRestAnalyzer:=TPasAnalyzer.Create; FRestAnalyzer:=TPas2JSAnalyzer.Create;
FRestAnalyzer.Resolver:=RestResolver; FRestAnalyzer.Resolver:=RestResolver;
try try
RestAnalyzer.AnalyzeModule(RestResolver.RootElement); RestAnalyzer.AnalyzeModule(RestResolver.RootElement);
@ -617,6 +619,8 @@ begin
CheckRestoredReference(Path+'.AssertMsgConstructor',Orig.AssertMsgConstructor,Rest.AssertMsgConstructor); CheckRestoredReference(Path+'.AssertMsgConstructor',Orig.AssertMsgConstructor,Rest.AssertMsgConstructor);
CheckRestoredReference(Path+'.RangeErrorClass',Orig.RangeErrorClass,Rest.RangeErrorClass); CheckRestoredReference(Path+'.RangeErrorClass',Orig.RangeErrorClass,Rest.RangeErrorClass);
CheckRestoredReference(Path+'.RangeErrorConstructor',Orig.RangeErrorConstructor,Rest.RangeErrorConstructor); CheckRestoredReference(Path+'.RangeErrorConstructor',Orig.RangeErrorConstructor,Rest.RangeErrorConstructor);
CheckRestoredReference(Path+'.SystemTVarRec',Orig.SystemTVarRec,Rest.SystemTVarRec);
CheckRestoredReference(Path+'.SystemVarRecs',Orig.SystemVarRecs,Rest.SystemVarRecs);
CheckRestoredPasScope(Path,Orig,Rest); CheckRestoredPasScope(Path,Orig,Rest);
end; end;
@ -2021,6 +2025,23 @@ begin
WriteReadUnit; WriteReadUnit;
end; end;
procedure TTestPrecompile.TestPC_Proc_ArrayOfConst;
begin
StartUnit(true,[supTVarRec]);
Add([
'interface',
'procedure Fly(arr: array of const);',
'implementation',
'procedure Fly(arr: array of const);',
'begin',
' if arr[1].VType=1 then ;',
' if arr[2].VInteger=1 then ;',
' Fly([true,0.3]);',
'end;',
'']);
WriteReadUnit;
end;
procedure TTestPrecompile.TestPC_Class; procedure TTestPrecompile.TestPC_Class;
begin begin
StartUnit(false); StartUnit(false);

View File

@ -49,6 +49,12 @@ type
Next: PSrcMarker; Next: PSrcMarker;
end; end;
TSystemUnitPart = (
supTObject,
supTVarRec
);
TSystemUnitParts = set of TSystemUnitPart;
{ TTestHintMessage } { TTestHintMessage }
TTestHintMessage = class TTestHintMessage = class
@ -153,9 +159,9 @@ type
function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; virtual; function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; virtual;
function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc, function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
ImplementationSrc: string): TTestEnginePasResolver; virtual; ImplementationSrc: string): TTestEnginePasResolver; virtual;
procedure AddSystemUnit; virtual; procedure AddSystemUnit(Parts: TSystemUnitParts = []); virtual;
procedure StartProgram(NeedSystemUnit: boolean); virtual; procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual;
procedure StartUnit(NeedSystemUnit: boolean); virtual; procedure StartUnit(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual;
procedure ConvertModule; virtual; procedure ConvertModule; virtual;
procedure ConvertProgram; virtual; procedure ConvertProgram; virtual;
procedure ConvertUnit; virtual; procedure ConvertUnit; virtual;
@ -412,8 +418,6 @@ type
Procedure TestArrayOfRecord; Procedure TestArrayOfRecord;
Procedure TestArray_StaticRecord; Procedure TestArray_StaticRecord;
Procedure TestArrayOfSet; Procedure TestArrayOfSet;
// call(set) literal and clone var
// call([set]) literal and clone var
Procedure TestArray_DynAsParam; Procedure TestArray_DynAsParam;
Procedure TestArray_StaticAsParam; Procedure TestArray_StaticAsParam;
Procedure TestArrayElement_AsParams; Procedure TestArrayElement_AsParams;
@ -434,6 +438,10 @@ type
Procedure TestArray_ForInArrOfString; Procedure TestArray_ForInArrOfString;
Procedure TestExternalClass_TypeCastArrayToExternalClass; Procedure TestExternalClass_TypeCastArrayToExternalClass;
Procedure TestExternalClass_TypeCastArrayFromExternalClass; Procedure TestExternalClass_TypeCastArrayFromExternalClass;
Procedure TestArrayOfConst_TVarRec;
Procedure TestArrayOfConst_PassBaseTypes;
Procedure TestArrayOfConst_PassObj;
// ToDo: tcfiler TPasModuleScope.SystemTVarRec TPas2JSModuleScope.SystemVarRecs
// record // record
Procedure TestRecord_Empty; Procedure TestRecord_Empty;
@ -452,7 +460,6 @@ type
Procedure TestRecord_Const; Procedure TestRecord_Const;
Procedure TestRecord_TypecastFail; Procedure TestRecord_TypecastFail;
Procedure TestRecord_InFunction; Procedure TestRecord_InFunction;
// ToDo: Procedure TestRecord_ExternalField;
// ToDo: RTTI of local record // ToDo: RTTI of local record
// ToDo: pcu local record, name clash and rtti // ToDo: pcu local record, name clash and rtti
@ -1512,36 +1519,136 @@ begin
Result:=AddModuleWithSrc(aFilename,Src); Result:=AddModuleWithSrc(aFilename,Src);
end; end;
procedure TCustomTestModule.AddSystemUnit; procedure TCustomTestModule.AddSystemUnit(Parts: TSystemUnitParts);
var
Intf, Impl: TStringList;
begin begin
AddModuleWithIntfImplSrc('system.pp', Intf:=TStringList.Create;
// interface // interface
LinesToStr([ if supTVarRec in Parts then
Intf.Add('{$modeswitch externalclass}');
Intf.Add('type');
Intf.Add(' integer=longint;');
Intf.Add(' sizeint=nativeint;');
//'const',
//' LineEnding = #10;',
//' DirectorySeparator = ''/'';',
//' DriveSeparator = '''';',
//' AllowDirectorySeparators : set of char = [''\'',''/''];',
//' AllowDriveSeparators : set of char = [];',
if supTObject in Parts then
Intf.AddStrings([
'type', 'type',
' integer=longint;', ' TClass = class of TObject;',
'var', ' TObject = class',
' ExitCode: Longint;', ' constructor Create;',
'' ' destructor Destroy; virtual;',
' class function ClassType: TClass; assembler;',
' class function ClassName: String; assembler;',
' class function ClassNameIs(const Name: string): boolean;',
' class function ClassParent: TClass; assembler;',
' class function InheritsFrom(aClass: TClass): boolean; assembler;',
' class function UnitName: String; assembler;',
' procedure AfterConstruction; virtual;',
' procedure BeforeDestruction;virtual;',
' function Equals(Obj: TObject): boolean; virtual;',
' function ToString: String; virtual;',
' end;']);
if supTVarRec in Parts then
Intf.AddStrings([
'const',
' vtInteger = 0;',
' vtBoolean = 1;',
' vtJSValue = 19;',
'type',
' PVarRec = ^TVarRec;',
' TVarRec = record',
' VType : byte;',
' VJSValue: JSValue;',
' vInteger: longint external name ''VJSValue'';',
' vBoolean: boolean external name ''VJSValue'';',
' end;',
' TVarRecArray = array of TVarRec;',
'function VarRecs: TVarRecArray; varargs;',
'']);
Intf.Add('var');
Intf.Add(' ExitCode: Longint = 0;');
// implementation // implementation
]),LinesToStr([ Impl:=TStringList.Create;
'' if supTObject in Parts then
])); Impl.AddStrings([
'// needed by ClassNameIs, the real SameText is in SysUtils',
'function SameText(const s1, s2: String): Boolean; assembler;',
'asm',
'end;',
'constructor TObject.Create; begin end;',
'destructor TObject.Destroy; begin end;',
'class function TObject.ClassType: TClass; assembler;',
'asm',
'end;',
'class function TObject.ClassName: String; assembler;',
'asm',
'end;',
'class function TObject.ClassNameIs(const Name: string): boolean;',
'begin',
' Result:=SameText(Name,ClassName);',
'end;',
'class function TObject.ClassParent: TClass; assembler;',
'asm',
'end;',
'class function TObject.InheritsFrom(aClass: TClass): boolean; assembler;',
'asm',
'end;',
'class function TObject.UnitName: String; assembler;',
'asm',
'end;',
'procedure TObject.AfterConstruction; begin end;',
'procedure TObject.BeforeDestruction; begin end;',
'function TObject.Equals(Obj: TObject): boolean;',
'begin',
' Result:=Obj=Self;',
'end;',
'function TObject.ToString: String;',
'begin',
' Result:=ClassName;',
'end;'
]);
if supTVarRec in Parts then
Impl.AddStrings([
'function VarRecs: TVarRecArray; varargs;',
'var',
' v: PVarRec;',
'begin',
' v^.VType:=1;',
' v^.VJSValue:=2;',
'end;',
'']);
try
AddModuleWithIntfImplSrc('system.pp',Intf.Text,Impl.Text);
finally
Intf.Free;
Impl.Free;
end;
end; end;
procedure TCustomTestModule.StartProgram(NeedSystemUnit: boolean); procedure TCustomTestModule.StartProgram(NeedSystemUnit: boolean;
SystemUnitParts: TSystemUnitParts);
begin begin
if NeedSystemUnit then if NeedSystemUnit then
AddSystemUnit AddSystemUnit(SystemUnitParts)
else else
Parser.ImplicitUses.Clear; Parser.ImplicitUses.Clear;
Add('program '+ExtractFileUnitName(Filename)+';'); Add('program '+ExtractFileUnitName(Filename)+';');
Add(''); Add('');
end; end;
procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean); procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean;
SystemUnitParts: TSystemUnitParts);
begin begin
if NeedSystemUnit then if NeedSystemUnit then
AddSystemUnit AddSystemUnit(SystemUnitParts)
else else
Parser.ImplicitUses.Clear; Parser.ImplicitUses.Clear;
Add('unit Test1;'); Add('unit Test1;');
@ -9481,10 +9588,154 @@ begin
''])); '']));
end; end;
procedure TTestModule.TestArrayOfConst_TVarRec;
begin
StartProgram(true,[supTVarRec]);
Add([
'procedure Say(args: array of const);',
'var',
' i: longint;',
' v: TVarRec;',
'begin',
' for i:=low(args) to high(args) do begin',
' v:=args[i];',
' case v.vtype of',
' vtInteger: if length(args)=args[i].vInteger then ;',
' end;',
' end;',
' for v in args do ;',
' args:=nil;',
' SetLength(args,2);',
'end;',
'begin']);
ConvertProgram;
CheckSource('TestArrayOfConst_TVarRec',
LinesToStr([ // statements
'this.Say = function (args) {',
' var i = 0;',
' var v = pas.system.TVarRec.$new();',
' for (var $l1 = 0, $end2 = rtl.length(args) - 1; $l1 <= $end2; $l1++) {',
' i = $l1;',
' v.$assign(args[i]);',
' var $tmp3 = v.VType;',
' if ($tmp3 === 0) if (rtl.length(args) === args[i].VJSValue) ;',
' };',
' for (var $in4 = args, $l5 = 0, $end6 = rtl.length($in4) - 1; $l5 <= $end6; $l5++) v = $in4[$l5];',
' args = [];',
' args = rtl.arraySetLength(args, pas.system.TVarRec, 2);',
'};',
'']),
LinesToStr([ // $mod.$main
]));
end;
procedure TTestModule.TestArrayOfConst_PassBaseTypes;
begin
StartProgram(true,[supTVarRec]);
Add([
'procedure Say(args: array of const);',
'begin',
' Say(args);',
'end;',
'var',
' p: Pointer;',
' j: jsvalue;',
' c: currency;',
'begin',
' Say([]);',
' Say([1]);',
' Say([''c'',''foo'',nil,true,1.3,p,j,c]);',
'']);
ConvertProgram;
CheckSource('TestArrayOfConst_PassBaseTypes',
LinesToStr([ // statements
'this.Say = function (args) {',
' $mod.Say(args);',
'};',
'this.p = null;',
'this.j = undefined;',
'this.c = 0;',
'']),
LinesToStr([ // $mod.$main
'$mod.Say([]);',
'$mod.Say(pas.system.VarRecs(0, 1));',
'$mod.Say(pas.system.VarRecs(',
' 9,',
' "c",',
' 18,',
' "foo",',
' 5,',
' null,',
' 1,',
' true,',
' 3,',
' 1.3,',
' 5,',
' $mod.p,',
' 20,',
' $mod.j,',
' 12,',
' $mod.c',
' ));',
'']));
end;
procedure TTestModule.TestArrayOfConst_PassObj;
begin
StartProgram(true,[supTVarRec]);
Add([
'{$interfaces corba}',
'type',
' TObject = class',
' end;',
' TClass = class of TObject;',
' IUnknown = interface',
' end;',
'procedure Say(args: array of const);',
'begin',
'end;',
'var',
' o: TObject;',
' c: TClass;',
' i: IUnknown;',
'begin',
' Say([o,c,TObject]);',
' Say([nil,i]);',
'']);
ConvertProgram;
CheckSource('TestArrayOfConst_PassObj',
LinesToStr([ // statements
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
'});',
'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
'this.Say = function (args) {',
'};',
'this.o = null;',
'this.c = null;',
'this.i = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.Say(pas.system.VarRecs(',
' 7,',
' $mod.o,',
' 8,',
' $mod.c,',
' 8,',
' $mod.TObject',
'));',
'$mod.Say(pas.system.VarRecs(5, null, 14, $mod.i));',
'']));
end;
procedure TTestModule.TestRecord_Empty; procedure TTestModule.TestRecord_Empty;
begin begin
StartProgram(false); StartProgram(false);
Add(['type', Add([
'type',
' TRecA = record', ' TRecA = record',
' end;', ' end;',
'var a,b: TRecA;', 'var a,b: TRecA;',

View File

@ -25,7 +25,7 @@ interface
uses uses
Classes, SysUtils, testregistry, fppas2js, pastree, Classes, SysUtils, testregistry, fppas2js, pastree,
PScanner, PasUseAnalyzer, PasResolver, PasResolveEval, PScanner, Pas2jsUseAnalyzer, PasResolver, PasResolveEval,
tcmodules; tcmodules;
type type
@ -34,8 +34,8 @@ type
TCustomTestOptimizations = class(TCustomTestModule) TCustomTestOptimizations = class(TCustomTestModule)
private private
FAnalyzerModule: TPasAnalyzer; FAnalyzerModule: TPas2JSAnalyzer;
FAnalyzerProgram: TPasAnalyzer; FAnalyzerProgram: TPas2JSAnalyzer;
FWholeProgramOptimization: boolean; FWholeProgramOptimization: boolean;
function OnConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean; function OnConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean;
function OnConverterIsTypeInfoUsed(Sender: TObject; El: TPasElement): boolean; function OnConverterIsTypeInfoUsed(Sender: TObject; El: TPasElement): boolean;
@ -46,8 +46,8 @@ type
procedure ParseProgram; override; procedure ParseProgram; override;
function CreateConverter: TPasToJSConverter; override; function CreateConverter: TPasToJSConverter; override;
public public
property AnalyzerModule: TPasAnalyzer read FAnalyzerModule; property AnalyzerModule: TPas2JSAnalyzer read FAnalyzerModule;
property AnalyzerProgram: TPasAnalyzer read FAnalyzerProgram; property AnalyzerProgram: TPas2JSAnalyzer read FAnalyzerProgram;
property WholeProgramOptimization: boolean read FWholeProgramOptimization property WholeProgramOptimization: boolean read FWholeProgramOptimization
write FWholeProgramOptimization; write FWholeProgramOptimization;
end; end;
@ -78,6 +78,7 @@ type
procedure TestWPO_Class_OmitPropertySetter2; procedure TestWPO_Class_OmitPropertySetter2;
procedure TestWPO_CallInherited; procedure TestWPO_CallInherited;
procedure TestWPO_UseUnit; procedure TestWPO_UseUnit;
procedure TestWPO_ArrayOfConst;
procedure TestWPO_Class_PropertyInOtherUnit; procedure TestWPO_Class_PropertyInOtherUnit;
procedure TestWPO_ProgramPublicDeclaration; procedure TestWPO_ProgramPublicDeclaration;
procedure TestWPO_ConstructorDefaultValueConst; procedure TestWPO_ConstructorDefaultValueConst;
@ -92,7 +93,7 @@ implementation
function TCustomTestOptimizations.OnConverterIsElementUsed(Sender: TObject; function TCustomTestOptimizations.OnConverterIsElementUsed(Sender: TObject;
El: TPasElement): boolean; El: TPasElement): boolean;
var var
A: TPasAnalyzer; A: TPas2JSAnalyzer;
begin begin
if WholeProgramOptimization then if WholeProgramOptimization then
A:=AnalyzerProgram A:=AnalyzerProgram
@ -114,7 +115,7 @@ end;
function TCustomTestOptimizations.OnConverterIsTypeInfoUsed(Sender: TObject; function TCustomTestOptimizations.OnConverterIsTypeInfoUsed(Sender: TObject;
El: TPasElement): boolean; El: TPasElement): boolean;
var var
A: TPasAnalyzer; A: TPas2JSAnalyzer;
begin begin
if WholeProgramOptimization then if WholeProgramOptimization then
A:=AnalyzerProgram A:=AnalyzerProgram
@ -137,9 +138,9 @@ procedure TCustomTestOptimizations.SetUp;
begin begin
inherited SetUp; inherited SetUp;
FWholeProgramOptimization:=false; FWholeProgramOptimization:=false;
FAnalyzerModule:=TPasAnalyzer.Create; FAnalyzerModule:=TPas2JSAnalyzer.Create;
FAnalyzerModule.Resolver:=Engine; FAnalyzerModule.Resolver:=Engine;
FAnalyzerProgram:=TPasAnalyzer.Create; FAnalyzerProgram:=TPas2JSAnalyzer.Create;
FAnalyzerProgram.Resolver:=Engine; FAnalyzerProgram.Resolver:=Engine;
end; end;
@ -814,6 +815,42 @@ begin
CheckDiff('TestWPO_UseUnit',ExpectedSrc,ActualSrc); CheckDiff('TestWPO_UseUnit',ExpectedSrc,ActualSrc);
end; end;
procedure TTestOptimizations.TestWPO_ArrayOfConst;
begin
StartProgram(true,[supTVarRec]);
Add([
'procedure Say(arr: array of const);',
'begin end;',
'begin',
' Say([true]);']);
ConvertProgram;
CheckUnit('system.pp',
LinesToStr([
'rtl.module("system", [], function () {',
' var $mod = this;',
' rtl.recNewT($mod, "TVarRec", function () {',
' this.VType = 0;',
' this.VJSValue = undefined;',
' this.$eq = function (b) {',
' return (this.VType === b.VType) && (this.VJSValue === b.VJSValue);',
' };',
' this.$assign = function (s) {',
' this.VType = s.VType;',
' this.VJSValue = s.VJSValue;',
' return this;',
' };',
' });',
' this.VarRecs = function () {',
' var Result = [];',
' var v = null;',
' v.VType = 1;',
' v.VJSValue = 2;',
' return Result;',
' };',
'});',
'']));
end;
procedure TTestOptimizations.TestWPO_Class_PropertyInOtherUnit; procedure TTestOptimizations.TestWPO_Class_PropertyInOtherUnit;
begin begin
AddModuleWithIntfImplSrc('unit1.pp', AddModuleWithIntfImplSrc('unit1.pp',

View File

@ -32,7 +32,7 @@
<PackageName Value="FCL"/> <PackageName Value="FCL"/>
</Item2> </Item2>
</RequiredPackages> </RequiredPackages>
<Units Count="11"> <Units Count="12">
<Unit0> <Unit0>
<Filename Value="testpas2js.pp"/> <Filename Value="testpas2js.pp"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
@ -83,6 +83,11 @@
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="TCPrecompile"/> <UnitName Value="TCPrecompile"/>
</Unit10> </Unit10>
<Unit11>
<Filename Value="../src/pas2jsuseanalyzer.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Pas2jsUseAnalyzer"/>
</Unit11>
</Units> </Units>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <CompilerOptions>

View File

@ -21,7 +21,7 @@ uses
MemCheck, MemCheck,
{$ENDIF} {$ENDIF}
Classes, consoletestrunner, tcconverter, tcmodules, tcoptimizations, tcsrcmap, Classes, consoletestrunner, tcconverter, tcmodules, tcoptimizations, tcsrcmap,
tcfiler, Pas2JsFiler, tcunitsearch, tcprecompile; tcfiler, Pas2JsFiler, tcunitsearch, tcprecompile, pas2jsuseanalyzer;
type type