mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 12:49:33 +02:00
pastojs: attributes
git-svn-id: trunk@41427 -
This commit is contained in:
Mattias Gaertner
parent
cc22c70fa5
commit
a532d1d8fb
@ -681,6 +681,7 @@ type
|
||||
pbivnRTTIInt_MinValue,
|
||||
pbivnRTTIInt_OrdType,
|
||||
pbivnRTTILocal, // $r
|
||||
pbivnRTTIMemberAttributes,
|
||||
pbivnRTTIMethodKind, // tTypeInfoMethodVar has methodkind
|
||||
pbivnRTTIPointer_RefType,
|
||||
pbivnRTTIProcFlags,
|
||||
@ -689,6 +690,7 @@ type
|
||||
pbivnRTTIPropIndex,
|
||||
pbivnRTTIPropStored,
|
||||
pbivnRTTISet_CompType,
|
||||
pbivnRTTITypeAttributes,
|
||||
pbivnSelf,
|
||||
pbivnTObjectDestroy,
|
||||
pbivnWith,
|
||||
@ -714,10 +716,10 @@ type
|
||||
|
||||
const
|
||||
Pas2JSBuiltInNames: array[TPas2JSBuiltInName] of string = (
|
||||
'arrayConcat', // rtl.arrayConcat
|
||||
'arrayConcatN', // rtl.arrayConcatN
|
||||
'arrayCopy', // rtl.arrayCopy
|
||||
'arrayEq', // rtl.arrayEq
|
||||
'arrayConcat', // rtl.arrayConcat pbifnArray_Concat
|
||||
'arrayConcatN', // rtl.arrayConcatN pbifnArray_ConcatN
|
||||
'arrayCopy', // rtl.arrayCopy pbifnArray_Copy
|
||||
'arrayEq', // rtl.arrayEq pbifnArray_Equal
|
||||
'length', // rtl.length
|
||||
'arraySetLength', // rtl.arraySetLength
|
||||
'$clone',
|
||||
@ -836,37 +838,39 @@ const
|
||||
'enumtype',
|
||||
'maxvalue',
|
||||
'minvalue',
|
||||
'ordtype',
|
||||
'$r',
|
||||
'methodkind',
|
||||
'reftype',
|
||||
'flags',
|
||||
'procsig',
|
||||
'Default',
|
||||
'index',
|
||||
'stored',
|
||||
'comptype',
|
||||
'$Self',
|
||||
'tObjectDestroy', // rtl.tObjectDestroy
|
||||
'$with',
|
||||
'$a',
|
||||
'NativeInt',
|
||||
'tTypeInfo', // rtl.
|
||||
'tTypeInfoClass', // rtl.
|
||||
'tTypeInfoClassRef', // rtl.
|
||||
'tTypeInfoDynArray', // rtl.
|
||||
'tTypeInfoEnum', // rtl.
|
||||
'tTypeInfoHelper', // rtl.
|
||||
'tTypeInfoInteger', // rtl.
|
||||
'tTypeInfoInterface', // rtl.
|
||||
'tTypeInfoMethodVar', // rtl.
|
||||
'tTypeInfoPointer', // rtl.
|
||||
'tTypeInfoProcVar', // rtl.
|
||||
'tTypeInfoRecord', // rtl.
|
||||
'tTypeInfoRefToProcVar', // rtl.
|
||||
'tTypeInfoSet', // rtl.
|
||||
'tTypeInfoStaticArray', // rtl.
|
||||
'NativeUInt'
|
||||
'ordtype', // pbivnRTTIInt_OrdType
|
||||
'$r', // pbivnRTTILocal
|
||||
'attr', // pbivnRTTIMemberAttributes
|
||||
'methodkind', // pbivnRTTIMethodKind
|
||||
'reftype', // pbivnRTTIPointer_RefType
|
||||
'flags', // pbivnRTTIProcFlags
|
||||
'procsig', // pbivnRTTIProcVar_ProcSig
|
||||
'Default', // pbivnRTTIPropDefault
|
||||
'index', // pbivnRTTIPropIndex
|
||||
'stored', // pbivnRTTIPropStored
|
||||
'comptype', // pbivnRTTISet_CompType
|
||||
'attr', // pbivnRTTITypeAttributes
|
||||
'$Self', // pbivnSelf
|
||||
'tObjectDestroy', // rtl.tObjectDestroy pbivnTObjectDestroy
|
||||
'$with', // pbivnWith
|
||||
'$a', // pbitnAnonymousPostfix
|
||||
'NativeInt', // pbitnIntDouble
|
||||
'tTypeInfo', // pbitnTI
|
||||
'tTypeInfoClass', // pbitnTIClass
|
||||
'tTypeInfoClassRef', // pbitnTIClassRef
|
||||
'tTypeInfoDynArray', // pbitnTIDynArray
|
||||
'tTypeInfoEnum', // pbitnTIEnum
|
||||
'tTypeInfoHelper', // pbitnTIHelper
|
||||
'tTypeInfoInteger', // pbitnTIInteger
|
||||
'tTypeInfoInterface', // pbitnTIInterface
|
||||
'tTypeInfoMethodVar', // pbitnTIMethodVar
|
||||
'tTypeInfoPointer', // pbitnTIPointer
|
||||
'tTypeInfoProcVar', // pbitnTIProcVar
|
||||
'tTypeInfoRecord', // pbitnTIRecord
|
||||
'tTypeInfoRefToProcVar', // pbitnTIRefToProcVar
|
||||
'tTypeInfoSet', // pbitnTISet
|
||||
'tTypeInfoStaticArray', // pbitnTIStaticArray
|
||||
'NativeUInt' // pbitnUIntDouble
|
||||
);
|
||||
|
||||
// reserved words, not usable as identifiers, not even as sub identifiers
|
||||
@ -1161,7 +1165,7 @@ const
|
||||
msExternalClass,
|
||||
msTypeHelpers,
|
||||
msArrayOperators,
|
||||
msIgnoreAttributes,
|
||||
msPrefixedAttributes,
|
||||
msOmitRTTI,
|
||||
msMultipleScopeHelpers];
|
||||
|
||||
@ -1824,10 +1828,16 @@ type
|
||||
AContext: TConvertContext); virtual;
|
||||
Function CreateRTTINewType(El: TPasType; const CallFuncName: string;
|
||||
IsForward: boolean; AContext: TConvertContext; out ObjLit: TJSObjectLiteral): TJSCallExpression; virtual;
|
||||
Function CreateRTTIMemberField(V: TPasVariable; AContext: TConvertContext): TJSElement; virtual;
|
||||
Function CreateRTTIMemberMethod(Proc: TPasProcedure; AContext: TConvertContext): TJSElement; virtual;
|
||||
Function CreateRTTIMemberProperty(Prop: TPasProperty; AContext: TConvertContext): TJSElement; virtual;
|
||||
Function CreateRTTIAttributes(const Attr: TPasExprArray; PosEl: TPasElement; aContext: TConvertContext): TJSElement; virtual;
|
||||
Function CreateRTTIMemberField(Members: TFPList; Index: integer;
|
||||
AContext: TConvertContext): TJSElement; virtual;
|
||||
Function CreateRTTIMemberMethod(Members: TFPList; Index: integer;
|
||||
AContext: TConvertContext): TJSElement; virtual;
|
||||
Function CreateRTTIMemberProperty(Members: TFPList; Index: integer;
|
||||
AContext: TConvertContext): TJSElement; virtual;
|
||||
Procedure CreateRTTIAnonymous(El: TPasType; AContext: TConvertContext); virtual;
|
||||
Function CreateRTTIMembers(El: TPasMembersType; Src: TJSSourceElements;
|
||||
FuncContext: TFunctionContext; RTTIExpr: TJSElement; NeedLocalVar: boolean): boolean; virtual;
|
||||
// create elements for interfaces
|
||||
Procedure AddIntfDelegations(ClassEl: TPasElement; Prop: TPasProperty;
|
||||
FinishedGUIDs: TStringList; ObjLit: TJSObjectLiteral; aContext: TFunctionContext);
|
||||
@ -12621,6 +12631,8 @@ begin
|
||||
AddResourceString(TPasResString(P));
|
||||
continue;
|
||||
end
|
||||
else if C=TPasAttributes then
|
||||
// ToDo
|
||||
else
|
||||
RaiseNotSupported(P as TPasElement,AContext,20161024191434);
|
||||
Add(E,P);
|
||||
@ -12886,6 +12898,9 @@ begin
|
||||
continue
|
||||
else if C=TPasMethodResolution then
|
||||
continue
|
||||
else if C=TPasAttributes then
|
||||
// ToDo
|
||||
continue
|
||||
else
|
||||
RaiseNotSupported(P,FuncContext,20161221233338);
|
||||
if NewEl<>nil then
|
||||
@ -14969,65 +14984,24 @@ procedure TPasToJSConverter.CreateRecordRTTI(El: TPasRecordType;
|
||||
var
|
||||
ObjLit: TJSObjectLiteral;
|
||||
Call: TJSCallExpression;
|
||||
ok: Boolean;
|
||||
i: Integer;
|
||||
P: TPasElement;
|
||||
VarSt: TJSVariableStatement;
|
||||
NewEl: TJSElement;
|
||||
C: TClass;
|
||||
HasRTTIMembers: Boolean;
|
||||
begin
|
||||
ok:=false;
|
||||
Call:=nil;
|
||||
VarSt:=nil;
|
||||
try
|
||||
// module.$rtti.$Record("typename",{});
|
||||
Call:=CreateRTTINewType(El,GetBIName(pbifnRTTINewRecord),false,FuncContext,ObjLit);
|
||||
if ObjLit=nil then
|
||||
RaiseInconsistency(20190105141430,El);
|
||||
|
||||
// add $r to local vars, to avoid name clashes and for nicer debugging
|
||||
FuncContext.AddLocalVar(GetBIName(pbivnRTTILocal),nil);
|
||||
|
||||
For i:=0 to El.Members.Count-1 do
|
||||
begin
|
||||
P:=TPasElement(El.Members[i]);
|
||||
if P.Visibility in [visPrivate,visStrictPrivate] then
|
||||
continue;
|
||||
if not IsElementUsed(P) then continue;
|
||||
NewEl:=nil;
|
||||
C:=P.ClassType;
|
||||
if C=TPasVariable then
|
||||
NewEl:=CreateRTTIMemberField(TPasVariable(P),FuncContext)
|
||||
else if C.InheritsFrom(TPasProcedure) then
|
||||
NewEl:=CreateRTTIMemberMethod(TPasProcedure(P),FuncContext)
|
||||
else if C=TPasProperty then
|
||||
NewEl:=CreateRTTIMemberProperty(TPasProperty(P),FuncContext)
|
||||
else if C.InheritsFrom(TPasType) then
|
||||
continue
|
||||
else
|
||||
DoError(20190105142236,nSymbolCannotBePublished,sSymbolCannotBePublished,[],P);
|
||||
if NewEl=nil then
|
||||
continue; // e.g. abstract or external proc
|
||||
// add RTTI element
|
||||
if VarSt=nil then
|
||||
begin
|
||||
// add "var $r = module.$rtti.$Record..."
|
||||
VarSt:=CreateVarStatement(GetBIName(pbivnRTTILocal),Call,El);
|
||||
Call:=nil;
|
||||
AddToSourceElements(Src,VarSt);
|
||||
end;
|
||||
AddToSourceElements(Src,NewEl);
|
||||
end;
|
||||
if Call<>nil then
|
||||
HasRTTIMembers:=CreateRTTIMembers(El,Src,FuncContext,Call,false);
|
||||
if not HasRTTIMembers then
|
||||
begin
|
||||
// no published members, add "module.$rtti.$Record..."
|
||||
AddToSourceElements(Src,Call);
|
||||
Call:=nil;
|
||||
end;
|
||||
|
||||
ok:=true;
|
||||
Call:=nil;
|
||||
finally
|
||||
if not ok then
|
||||
Call.Free;
|
||||
end;
|
||||
end;
|
||||
@ -15620,61 +15594,37 @@ end;
|
||||
|
||||
procedure TPasToJSConverter.AddClassRTTI(El: TPasClassType;
|
||||
Src: TJSSourceElements; FuncContext: TFunctionContext);
|
||||
|
||||
function IsMemberNeeded(aMember: TPasElement): boolean;
|
||||
begin
|
||||
Result:=IsElementUsed(aMember);
|
||||
end;
|
||||
|
||||
var
|
||||
HasRTTIMembers: Boolean;
|
||||
i: Integer;
|
||||
P: TPasElement;
|
||||
NewEl: TJSElement;
|
||||
VarSt: TJSVariableStatement;
|
||||
C: TClass;
|
||||
HasRTTIMembers, NeedLocalVar: Boolean;
|
||||
RTTIExpr, AttrJS: TJSElement;
|
||||
Attr: TPasExprArray;
|
||||
AssignSt: TJSAssignStatement;
|
||||
begin
|
||||
// add $r to local vars, to avoid name clashes and for nicer debugging
|
||||
FuncContext.AddLocalVar(GetBIName(pbivnRTTILocal),nil);
|
||||
AttrJS:=nil;
|
||||
// this.$rtti
|
||||
RTTIExpr:=CreateMemberExpression(['this',GetBIName(pbivnRTTI)]);
|
||||
try
|
||||
Attr:=FuncContext.Resolver.GetAttributeCallsEl(El);
|
||||
AttrJS:=CreateRTTIAttributes(Attr,El,FuncContext);
|
||||
NeedLocalVar:=AttrJS<>nil;
|
||||
|
||||
HasRTTIMembers:=false;
|
||||
For i:=0 to El.Members.Count-1 do
|
||||
begin
|
||||
P:=TPasElement(El.Members[i]);
|
||||
//writeln('TPasToJSConverter.ConvertClassType RTTI El[',i,']=',GetObjName(P));
|
||||
if El.ObjKind=okInterface then
|
||||
// all interface methods are published
|
||||
else if P.Visibility<>visPublished then
|
||||
continue;
|
||||
if not IsMemberNeeded(P) then continue;
|
||||
NewEl:=nil;
|
||||
C:=P.ClassType;
|
||||
if C=TPasVariable then
|
||||
NewEl:=CreateRTTIMemberField(TPasVariable(P),FuncContext)
|
||||
else if C.InheritsFrom(TPasProcedure) then
|
||||
NewEl:=CreateRTTIMemberMethod(TPasProcedure(P),FuncContext)
|
||||
else if C=TPasProperty then
|
||||
NewEl:=CreateRTTIMemberProperty(TPasProperty(P),FuncContext)
|
||||
else if C.InheritsFrom(TPasType) then
|
||||
continue
|
||||
else if C=TPasMethodResolution then
|
||||
continue
|
||||
else
|
||||
DoError(20170409202315,nSymbolCannotBePublished,sSymbolCannotBePublished,[],P);
|
||||
if NewEl=nil then
|
||||
continue; // e.g. abstract or external proc
|
||||
// add RTTI element
|
||||
if not HasRTTIMembers then
|
||||
HasRTTIMembers:=CreateRTTIMembers(El,Src,FuncContext,RTTIExpr,NeedLocalVar);
|
||||
if HasRTTIMembers then
|
||||
RTTIExpr:=nil;
|
||||
|
||||
if AttrJS<>nil then
|
||||
begin
|
||||
// add "var $r = this.$rtti"
|
||||
VarSt:=CreateVarStatement(GetBIName(pbivnRTTILocal),
|
||||
CreateMemberExpression(['this',GetBIName(pbivnRTTI)]),El);
|
||||
AddToSourceElements(Src,VarSt);
|
||||
|
||||
HasRTTIMembers:=true;
|
||||
// $r.attr = [];
|
||||
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
|
||||
AddToSourceElements(Src,AssignSt);
|
||||
AssignSt.LHS:=CreateMemberExpression([GetBIName(pbivnRTTILocal),GetBIName(pbivnRTTITypeAttributes)]);
|
||||
AssignSt.Expr:=AttrJS;
|
||||
AttrJS:=nil;
|
||||
end;
|
||||
AddToSourceElements(Src,NewEl);
|
||||
end;
|
||||
finally
|
||||
AttrJS.Free;
|
||||
RTTIExpr.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPasToJSConverter.AddClassConstructors(FuncContext: TFunctionContext;
|
||||
@ -16402,9 +16352,15 @@ var
|
||||
RttiPath, TypeName: String;
|
||||
Call: TJSCallExpression;
|
||||
aModule: TPasModule;
|
||||
aResolver: TPas2JSResolver;
|
||||
Attr: TPasExprArray;
|
||||
AttrJS: TJSElement;
|
||||
ObjLitEl: TJSObjectLiteralElement;
|
||||
begin
|
||||
Result:=nil;
|
||||
ObjLit:=nil;
|
||||
|
||||
aResolver:=AContext.Resolver;
|
||||
// get module path
|
||||
aModule:=El.GetModule;
|
||||
if aModule=nil then
|
||||
@ -16430,7 +16386,18 @@ begin
|
||||
// add {}
|
||||
ObjLit:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El));
|
||||
Call.AddArg(ObjLit);
|
||||
|
||||
Attr:=aResolver.GetAttributeCallsEl(El);
|
||||
AttrJS:=CreateRTTIAttributes(Attr,El,AContext);
|
||||
if AttrJS<>nil then
|
||||
begin
|
||||
// attr: [...]
|
||||
ObjLitEl:=ObjLit.Elements.AddElement;
|
||||
ObjLitEl.Name:=TJSString(GetBIName(pbivnRTTITypeAttributes));
|
||||
ObjLitEl.Expr:=AttrJS;
|
||||
end;
|
||||
end;
|
||||
|
||||
Result:=Call;
|
||||
finally
|
||||
if Result=nil then
|
||||
@ -16438,36 +16405,164 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPasToJSConverter.CreateRTTIMemberField(V: TPasVariable;
|
||||
AContext: TConvertContext): TJSElement;
|
||||
// create $r.addField("varname",typeinfo);
|
||||
function TPasToJSConverter.CreateRTTIAttributes(const Attr: TPasExprArray;
|
||||
PosEl: TPasElement; aContext: TConvertContext): TJSElement;
|
||||
// create [Attr1Class,'Attr1ProcName',[Attr1Params],...]
|
||||
var
|
||||
AttrArrayLit, ParamsArrayLit: TJSArrayLiteral;
|
||||
i, j: Integer;
|
||||
Expr, ParamExpr: TPasExpr;
|
||||
aResolver: TPas2JSResolver;
|
||||
Ref: TResolvedReference;
|
||||
AttrClass, ConstrParent: TPasClassType;
|
||||
aConstructor: TPasConstructor;
|
||||
aName: String;
|
||||
Params: TPasExprArray;
|
||||
Value: TResEvalValue;
|
||||
JSExpr: TJSElement;
|
||||
begin
|
||||
Result:=nil;
|
||||
aResolver:=aContext.Resolver;
|
||||
AttrArrayLit:=nil;
|
||||
try
|
||||
for i:=0 to length(Attr)-1 do
|
||||
begin
|
||||
Expr:=Attr[i];
|
||||
if Expr is TParamsExpr then
|
||||
Expr:=TParamsExpr(Expr).Value;
|
||||
if (Expr is TBinaryExpr) and (TBinaryExpr(Expr).OpCode=eopSubIdent) then
|
||||
Expr:=TBinaryExpr(Expr).right;
|
||||
if not aResolver.IsNameExpr(Expr) then
|
||||
RaiseNotSupported(Expr,aContext,20190222182742,GetObjName(Expr));
|
||||
// attribute class
|
||||
Ref:=Expr.CustomData as TResolvedReference;
|
||||
if Ref=nil then
|
||||
// unknown attribute -> silently skip (delphi 10.3 compatible)
|
||||
continue;
|
||||
AttrClass:=Ref.Declaration as TPasClassType;
|
||||
if AttrClass.IsAbstract then
|
||||
continue; // silently skip abstract class (Delphi 10.3 compatible)
|
||||
// attribute constructor name as string
|
||||
if not (Ref.Context is TResolvedRefCtxAttrProc) then
|
||||
RaiseNotSupported(Expr,aContext,20190223085831,GetObjName(Expr));
|
||||
aConstructor:=TResolvedRefCtxAttrProc(Ref.Context).Proc;
|
||||
if aConstructor.IsAbstract then
|
||||
continue; // silently skip abstract method (Delphi 10.3 compatible)
|
||||
ConstrParent:=aConstructor.Parent as TPasClassType;
|
||||
if ConstrParent.HelperForType<>nil then
|
||||
aResolver.RaiseMsg(20190223220134,nXExpectedButYFound,sXExpectedButYFound,
|
||||
['class method','helper method'],Expr);
|
||||
aName:=TransformVariableName(aConstructor,aContext);
|
||||
|
||||
if AttrArrayLit=nil then
|
||||
AttrArrayLit:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,PosEl));
|
||||
|
||||
// add class reference pas.system.TCustomAttribute
|
||||
AttrArrayLit.AddElement(CreateReferencePathExpr(AttrClass,aContext));
|
||||
// add constructor name 'Create$1'
|
||||
AttrArrayLit.AddElement(CreateLiteralString(PosEl,aName));
|
||||
// add attribute params as [] if needed
|
||||
ParamsArrayLit:=nil;
|
||||
Expr:=Attr[i];
|
||||
if Expr is TParamsExpr then
|
||||
begin
|
||||
Params:=TParamsExpr(Expr).Params;
|
||||
for j:=0 to length(Params)-1 do
|
||||
begin
|
||||
ParamExpr:=Params[j];
|
||||
Value:=aResolver.Eval(ParamExpr,[]);
|
||||
if Value<>nil then
|
||||
try
|
||||
JSExpr:=ConvertConstValue(Value,aContext,PosEl);
|
||||
finally
|
||||
ReleaseEvalValue(Value);
|
||||
end
|
||||
else
|
||||
JSExpr:=ConvertExpression(ParamExpr,aContext);
|
||||
if ParamsArrayLit=nil then
|
||||
begin
|
||||
ParamsArrayLit:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,PosEl));
|
||||
AttrArrayLit.AddElement(ParamsArrayLit);
|
||||
end;
|
||||
ParamsArrayLit.AddElement(JSExpr);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
Result:=AttrArrayLit;
|
||||
finally
|
||||
if Result=nil then
|
||||
AttrArrayLit.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPasToJSConverter.CreateRTTIMemberField(Members: TFPList;
|
||||
Index: integer; AContext: TConvertContext): TJSElement;
|
||||
// create $r.addField("varname",typeinfo);
|
||||
// create $r.addField("varname",typeinfo,options);
|
||||
var
|
||||
V: TPasVariable;
|
||||
Call: TJSCallExpression;
|
||||
OptionsEl: TJSObjectLiteral;
|
||||
|
||||
procedure AddOption(const aName: String; JS: TJSElement);
|
||||
var
|
||||
ObjLit: TJSObjectLiteralElement;
|
||||
begin
|
||||
if JS=nil then exit;
|
||||
if OptionsEl=nil then
|
||||
begin
|
||||
OptionsEl:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,V));
|
||||
Call.AddArg(OptionsEl);
|
||||
end;
|
||||
ObjLit:=OptionsEl.Elements.AddElement;
|
||||
ObjLit.Name:=TJSString(aName);
|
||||
ObjLit.Expr:=JS;
|
||||
end;
|
||||
|
||||
var
|
||||
JSTypeInfo: TJSElement;
|
||||
aName: String;
|
||||
aResolver: TPas2JSResolver;
|
||||
Attr: TPasExprArray;
|
||||
begin
|
||||
Result:=nil;
|
||||
aResolver:=AContext.Resolver;
|
||||
V:=TPasVariable(Members[Index]);
|
||||
if (V.VarType<>nil) and (V.VarType.Name='') then
|
||||
CreateRTTIAnonymous(V.VarType,AContext);
|
||||
|
||||
JSTypeInfo:=CreateTypeInfoRef(V.VarType,AContext,V);
|
||||
OptionsEl:=nil;
|
||||
// Note: create JSTypeInfo first, it may raise an exception
|
||||
Call:=CreateCallExpression(V);
|
||||
// $r.addField
|
||||
Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTTILocal),GetBIName(pbifnRTTIAddField)]);
|
||||
// param "varname"
|
||||
aName:=TransformVariableName(V,AContext);
|
||||
Call.AddArg(CreateLiteralString(V,aName));
|
||||
// param typeinfo
|
||||
Call.AddArg(JSTypeInfo);
|
||||
Result:=Call;
|
||||
try
|
||||
// $r.addField
|
||||
Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTTILocal),GetBIName(pbifnRTTIAddField)]);
|
||||
// param "varname"
|
||||
aName:=TransformVariableName(V,AContext);
|
||||
Call.AddArg(CreateLiteralString(V,aName));
|
||||
// param typeinfo
|
||||
Call.AddArg(JSTypeInfo);
|
||||
|
||||
// param options if needed as {}
|
||||
// option: attributes
|
||||
Attr:=aResolver.GetAttributeCalls(Members,Index);
|
||||
if length(Attr)>0 then
|
||||
AddOption(GetBIName(pbivnRTTIMemberAttributes),
|
||||
CreateRTTIAttributes(Attr,V,AContext));
|
||||
|
||||
Result:=Call;
|
||||
Call:=nil;
|
||||
finally
|
||||
Call.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPasToJSConverter.CreateRTTIMemberMethod(Proc: TPasProcedure;
|
||||
AContext: TConvertContext): TJSElement;
|
||||
function TPasToJSConverter.CreateRTTIMemberMethod(Members: TFPList;
|
||||
Index: integer; AContext: TConvertContext): TJSElement;
|
||||
// create $r.addMethod("funcname",methodkind,params,resulttype,options)
|
||||
var
|
||||
Proc: TPasProcedure;
|
||||
OptionsEl: TJSObjectLiteral;
|
||||
ResultTypeInfo: TJSElement;
|
||||
Call: TJSCallExpression;
|
||||
@ -16476,6 +16571,7 @@ var
|
||||
var
|
||||
ObjLit: TJSObjectLiteralElement;
|
||||
begin
|
||||
if JS=nil then exit;
|
||||
if OptionsEl=nil then
|
||||
begin
|
||||
OptionsEl:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,Proc));
|
||||
@ -16495,8 +16591,12 @@ var
|
||||
ResultEl: TPasResultElement;
|
||||
ProcScope, OverriddenProcScope: TPasProcedureScope;
|
||||
OverriddenClass: TPasClassType;
|
||||
aResolver: TPas2JSResolver;
|
||||
Attr: TPasExprArray;
|
||||
begin
|
||||
Result:=nil;
|
||||
Proc:=TPasProcedure(Members[Index]);
|
||||
aResolver:=AContext.Resolver;
|
||||
if Proc.IsOverride then
|
||||
begin
|
||||
ProcScope:=Proc.CustomData as TPasProcedureScope;
|
||||
@ -16564,6 +16664,10 @@ begin
|
||||
inc(Flags,pfExternal);
|
||||
if Flags>0 then
|
||||
AddOption(GetBIName(pbivnRTTIProcFlags),CreateLiteralNumber(Proc,Flags));
|
||||
Attr:=aResolver.GetAttributeCalls(Members,Index);
|
||||
if length(Attr)>0 then
|
||||
AddOption(GetBIName(pbivnRTTIMemberAttributes),
|
||||
CreateRTTIAttributes(Attr,Proc,AContext));
|
||||
|
||||
Result:=Call;
|
||||
finally
|
||||
@ -16572,10 +16676,11 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPasToJSConverter.CreateRTTIMemberProperty(Prop: TPasProperty;
|
||||
AContext: TConvertContext): TJSElement;
|
||||
function TPasToJSConverter.CreateRTTIMemberProperty(Members: TFPList;
|
||||
Index: integer; AContext: TConvertContext): TJSElement;
|
||||
// create $r.addProperty("propname",flags,result,"getter","setter",{options})
|
||||
var
|
||||
Prop: TPasProperty;
|
||||
Call: TJSCallExpression;
|
||||
OptionsEl: TJSObjectLiteral;
|
||||
|
||||
@ -16588,6 +16693,7 @@ var
|
||||
var
|
||||
ObjLit: TJSObjectLiteralElement;
|
||||
begin
|
||||
if JS=nil then exit;
|
||||
if OptionsEl=nil then
|
||||
begin
|
||||
OptionsEl:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,Prop));
|
||||
@ -16608,8 +16714,10 @@ var
|
||||
StoredResolved, VarTypeResolved: TPasResolverResult;
|
||||
StoredValue, PasValue, IndexValue: TResEvalValue;
|
||||
aResolver: TPas2JSResolver;
|
||||
Attr: TPasExprArray;
|
||||
begin
|
||||
Result:=nil;
|
||||
Prop:=TPasProperty(Members[Index]);
|
||||
aResolver:=AContext.Resolver;
|
||||
OptionsEl:=nil;
|
||||
try
|
||||
@ -16726,6 +16834,12 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
// add option "attr"
|
||||
Attr:=aResolver.GetAttributeCalls(Members,Index);
|
||||
if length(Attr)>0 then
|
||||
AddOption(GetBIName(pbivnRTTIMemberAttributes),
|
||||
CreateRTTIAttributes(Attr,Prop,AContext));
|
||||
|
||||
Result:=Call;
|
||||
finally
|
||||
if Result=nil then
|
||||
@ -16764,6 +16878,89 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPasToJSConverter.CreateRTTIMembers(El: TPasMembersType;
|
||||
Src: TJSSourceElements; FuncContext: TFunctionContext; RTTIExpr: TJSElement;
|
||||
NeedLocalVar: boolean): boolean;
|
||||
type
|
||||
TMemberType = (
|
||||
mtClass,
|
||||
mtInterface,
|
||||
mtRecord
|
||||
);
|
||||
|
||||
procedure CreateLocalvar;
|
||||
var
|
||||
VarSt: TJSVariableStatement;
|
||||
begin
|
||||
if Result then exit;
|
||||
// add "var $r = module.$rtti.$Record..."
|
||||
Result:=true;
|
||||
VarSt:=CreateVarStatement(GetBIName(pbivnRTTILocal),RTTIExpr,El);
|
||||
AddToSourceElements(Src,VarSt);
|
||||
end;
|
||||
|
||||
var
|
||||
mt: TMemberType;
|
||||
i: integer;
|
||||
P: TPasElement;
|
||||
C: TClass;
|
||||
NewEl: TJSElement;
|
||||
Members: TFPList;
|
||||
begin
|
||||
Result:=false;
|
||||
if El.ClassType=TPasRecordType then
|
||||
mt:=mtRecord
|
||||
else if El.ClassType=TPasClassType then
|
||||
case TPasClassType(El).ObjKind of
|
||||
okInterface: mt:=mtInterface;
|
||||
else mt:=mtClass;
|
||||
end
|
||||
else
|
||||
RaiseNotSupported(El,FuncContext,20190223211808,GetObjName(El));
|
||||
|
||||
// add $r to local vars, to avoid name clashes and for nicer debugging
|
||||
FuncContext.AddLocalVar(GetBIName(pbivnRTTILocal),nil);
|
||||
|
||||
if NeedLocalVar then
|
||||
CreateLocalvar;
|
||||
|
||||
Members:=El.Members;
|
||||
For i:=0 to Members.Count-1 do
|
||||
begin
|
||||
P:=TPasElement(Members[i]);
|
||||
C:=P.ClassType;
|
||||
// check visibility
|
||||
case mt of
|
||||
mtClass:
|
||||
if P.Visibility<>visPublished then continue;
|
||||
mtInterface: ; // all members of an interface are published
|
||||
mtRecord:
|
||||
// a published record publishes all non private members
|
||||
if P.Visibility in [visPrivate,visStrictPrivate] then
|
||||
continue;
|
||||
end;
|
||||
if not IsElementUsed(P) then continue;
|
||||
|
||||
NewEl:=nil;
|
||||
if C=TPasVariable then
|
||||
NewEl:=CreateRTTIMemberField(Members,i,FuncContext)
|
||||
else if C.InheritsFrom(TPasProcedure) then
|
||||
NewEl:=CreateRTTIMemberMethod(Members,i,FuncContext)
|
||||
else if C=TPasProperty then
|
||||
NewEl:=CreateRTTIMemberProperty(Members,i,FuncContext)
|
||||
else if C.InheritsFrom(TPasType)
|
||||
or (C=TPasAttributes) then
|
||||
else
|
||||
DoError(20190105142236,nSymbolCannotBePublished,sSymbolCannotBePublished,[],P);
|
||||
if NewEl=nil then
|
||||
continue; // e.g. abstract or external proc
|
||||
// add RTTI element
|
||||
if not Result then
|
||||
CreateLocalvar;
|
||||
AddToSourceElements(Src,NewEl);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPasToJSConverter.AddIntfDelegations(ClassEl: TPasElement;
|
||||
Prop: TPasProperty; FinishedGUIDs: TStringList; ObjLit: TJSObjectLiteral;
|
||||
aContext: TFunctionContext);
|
||||
@ -17395,7 +17592,6 @@ var
|
||||
List: TJSStatementList;
|
||||
begin
|
||||
RgCheck:=nil;
|
||||
writeln('AAA1 CreateRefObj SetExpr=',GetObjName(SetExpr),' SetterArgName=',SetterArgName,' ',bsRangeChecks in AContext.ScannerBoolSwitches);
|
||||
if (SetExpr is TJSSimpleAssignStatement)
|
||||
and (SetterArgName<>'')
|
||||
and (bsRangeChecks in AContext.ScannerBoolSwitches) then
|
||||
@ -22044,8 +22240,9 @@ begin
|
||||
and not aResolver.MethodIsStatic(TPasProcedure(P))) then
|
||||
IsFull:=true; // needs $record
|
||||
end;
|
||||
continue;
|
||||
end
|
||||
else if C=TPasAttributes then
|
||||
// ToDo
|
||||
else
|
||||
RaiseNotSupported(P,FuncContext,20190105105436);
|
||||
if NewEl<>nil then
|
||||
|
||||
@ -71,7 +71,7 @@ uses
|
||||
|
||||
const
|
||||
PCUMagic = 'Pas2JSCache';
|
||||
PCUVersion = 4;
|
||||
PCUVersion = 5;
|
||||
{ Version Changes:
|
||||
1: initial version
|
||||
2: - TPasProperty.ImplementsFunc:String -> Implements:TPasExprArray
|
||||
@ -80,6 +80,7 @@ const
|
||||
3: changed records from function to objects (pas2js 1.3)
|
||||
4: precompiled JS of initialization section now only contains the statements,
|
||||
not the whole $init function (pas2js 1.5)
|
||||
5: removed modeswitch ignoreattributes
|
||||
}
|
||||
|
||||
BuiltInNodeName = 'BuiltIn';
|
||||
@ -170,10 +171,9 @@ const
|
||||
'ArrayOperators',
|
||||
'ExternalClass',
|
||||
'PrefixedAttributes',
|
||||
'IgnoreAttributes',
|
||||
'OmitRTTI',
|
||||
'MultipleScopeHelpers'
|
||||
);
|
||||
); // Dont forget to update ModeSwitchToInt !
|
||||
|
||||
PCUDefaultBoolSwitches: TBoolSwitches = [
|
||||
bsHints,
|
||||
@ -780,6 +780,7 @@ type
|
||||
procedure WriteProcedureScope(Obj: TJSONObject; Scope: TPas2JSProcedureScope; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteProcedure(Obj: TJSONObject; El: TPasProcedure; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteOperator(Obj: TJSONObject; El: TPasOperator; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteAttributes(Obj: TJSONObject; El: TPasAttributes; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteExtRefSignature(Ref: TPCUFilerElementRef; aContext: TPCUWriterContext); virtual;
|
||||
function WriteExternalReference(El: TPasElement; aContext: TPCUWriterContext): TPCUFilerElementRef; virtual;
|
||||
procedure WriteExternalReferences(aContext: TPCUWriterContext); virtual;
|
||||
@ -869,6 +870,8 @@ type
|
||||
procedure Set_ProcedureScope_ImplProc(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ProcedureScope_Overridden(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ResolvedReference_Declaration(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ResolvedReference_CtxConstructor(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ResolvedReference_CtxAttrProc(RefEl: TPasElement; Data: TObject);
|
||||
protected
|
||||
procedure RaiseMsg(Id: int64; const Msg: string = ''); overload; override;
|
||||
function CheckJSONArray(Data: TJSONData; El: TPasElement; const PropName: string): TJSONArray;
|
||||
@ -994,6 +997,7 @@ type
|
||||
procedure ReadProcedureBody(Obj: TJSONObject; El: TPasProcedure; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadProcedure(Obj: TJSONObject; El: TPasProcedure; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadOperator(Obj: TJSONObject; El: TPasOperator; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadAttributes(Obj: TJSONObject; El: TPasAttributes; aContext: TPCUReaderContext); virtual;
|
||||
procedure ResolvePending; virtual;
|
||||
procedure ReadBuiltInSymbols(Obj: TJSONObject; ErrorEl: TPasElement); virtual;
|
||||
public
|
||||
@ -1388,7 +1392,9 @@ begin
|
||||
msExternalClass: Result:=44;
|
||||
msPrefixedAttributes: Result:=45;
|
||||
// msIgnoreInterfaces: Result:=46;
|
||||
msIgnoreAttributes: Result:=47;
|
||||
// msIgnoreAttributes: Result:=47;
|
||||
msOmitRTTI: Result:=48;
|
||||
msMultipleScopeHelpers: Result:=49;
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -2790,6 +2796,8 @@ begin
|
||||
pekArrayParams: Obj.Add('Type','A[]');
|
||||
pekFuncParams: Obj.Add('Type','F()');
|
||||
pekSet: Obj.Add('Type','[]');
|
||||
else
|
||||
RaiseMsg(20190222012727,El,ExprKindNames[TParamsExpr(El).Kind]);
|
||||
end;
|
||||
WriteParamsExpr(Obj,TParamsExpr(El),aContext);
|
||||
end
|
||||
@ -2966,6 +2974,11 @@ begin
|
||||
RaiseMsg(20180210130202,El);
|
||||
WriteProcedure(Obj,TPasProcedure(El),aContext);
|
||||
end
|
||||
else if C=TPasAttributes then
|
||||
begin
|
||||
Obj.Add('Type','Attributes');
|
||||
WriteAttributes(Obj,TPasAttributes(El),aContext);
|
||||
end
|
||||
else
|
||||
begin
|
||||
{$IFDEF VerbosePCUFiler}
|
||||
@ -3019,6 +3032,8 @@ end;
|
||||
|
||||
procedure TPCUWriter.WriteResolvedReference(Obj: TJSONObject;
|
||||
Ref: TResolvedReference; ErrorEl: TPasElement);
|
||||
var
|
||||
Ctx: TResolvedRefContext;
|
||||
begin
|
||||
WriteResolvedRefFlags(Obj,'RefFlags',Ref.Flags,[]);
|
||||
if Ref.Access<>rraRead then
|
||||
@ -3026,7 +3041,23 @@ begin
|
||||
if Ref.WithExprScope<>nil then
|
||||
RaiseMsg(20180215132828,ErrorEl);
|
||||
if Ref.Context<>nil then
|
||||
RaiseMsg(20180215132849,ErrorEl,GetObjName(Ref.Context));
|
||||
begin
|
||||
Ctx:=Ref.Context;
|
||||
if Ctx.ClassType=TResolvedRefCtxConstructor then
|
||||
begin
|
||||
if TResolvedRefCtxConstructor(Ctx).Typ=nil then
|
||||
RaiseMsg(20190222011342,ErrorEl);
|
||||
AddReferenceToObj(Obj,'RefConstructorType',TResolvedRefCtxConstructor(Ctx).Typ);
|
||||
end
|
||||
else if Ctx.ClassType=TResolvedRefCtxAttrProc then
|
||||
begin
|
||||
if TResolvedRefCtxAttrProc(Ctx).Proc=nil then
|
||||
RaiseMsg(20190222011427,ErrorEl);
|
||||
AddReferenceToObj(Obj,'RefAttrProc',TResolvedRefCtxAttrProc(Ctx).Proc);
|
||||
end
|
||||
else
|
||||
RaiseMsg(20180215132849,ErrorEl,GetObjName(Ref.Context));
|
||||
end;
|
||||
AddReferenceToObj(Obj,'RefDecl',Ref.Declaration);
|
||||
end;
|
||||
|
||||
@ -3806,6 +3837,13 @@ begin
|
||||
Obj.Add('TokenBased',El.TokenBased);
|
||||
end;
|
||||
|
||||
procedure TPCUWriter.WriteAttributes(Obj: TJSONObject; El: TPasAttributes;
|
||||
aContext: TPCUWriterContext);
|
||||
begin
|
||||
WritePasElement(Obj,El,aContext);
|
||||
WritePasExprArray(Obj,El,'Calls',El.Calls,aContext);
|
||||
end;
|
||||
|
||||
procedure TPCUWriter.WriteExtRefSignature(Ref: TPCUFilerElementRef;
|
||||
aContext: TPCUWriterContext);
|
||||
|
||||
@ -4485,6 +4523,28 @@ begin
|
||||
Ref.Declaration:=RefEl;
|
||||
end;
|
||||
|
||||
procedure TPCUReader.Set_ResolvedReference_CtxConstructor(RefEl: TPasElement;
|
||||
Data: TObject);
|
||||
var
|
||||
Ref: TResolvedReference absolute Data;
|
||||
begin
|
||||
if RefEl is TPasType then
|
||||
TResolvedRefCtxConstructor(Ref.Context).Typ:=TPasType(RefEl) // no AddRef
|
||||
else
|
||||
RaiseMsg(20190222010314,Ref.Element,GetObjName(RefEl));
|
||||
end;
|
||||
|
||||
procedure TPCUReader.Set_ResolvedReference_CtxAttrProc(RefEl: TPasElement;
|
||||
Data: TObject);
|
||||
var
|
||||
Ref: TResolvedReference absolute Data;
|
||||
begin
|
||||
if RefEl is TPasConstructor then
|
||||
TResolvedRefCtxAttrProc(Ref.Context).Proc:=TPasConstructor(RefEl) // no AddRef
|
||||
else
|
||||
RaiseMsg(20190222010821,Ref.Element,GetObjName(RefEl));
|
||||
end;
|
||||
|
||||
procedure TPCUReader.RaiseMsg(Id: int64; const Msg: string);
|
||||
var
|
||||
E: EPas2JsReadError;
|
||||
@ -4906,7 +4966,7 @@ begin
|
||||
end;
|
||||
if not Found then
|
||||
begin
|
||||
if (FileVersion<2) and (SameText(s,'ignoreinterfaces')) then
|
||||
if (FileVersion<5) and (SameText(s,'ignoreinterfaces')) then
|
||||
// ignore old switch
|
||||
else
|
||||
RaiseMsg(20180202144054,El,'unknown ModeSwitch "'+s+'"');
|
||||
@ -5786,6 +5846,11 @@ begin
|
||||
'ClassDestructor': ReadProc(TPasClassDestructor,Name);
|
||||
'Operator': ReadOper(TPasConstructor,Name);
|
||||
'ClassOperator': ReadOper(TPasClassConstructor,Name);
|
||||
'Attributes':
|
||||
begin
|
||||
Result:=CreateElement(TPasAttributes,Name,Parent);
|
||||
ReadAttributes(Obj,TPasAttributes(Result),aContext);
|
||||
end;
|
||||
else
|
||||
RaiseMsg(20180210143758,Parent,'unknown type "'+LeftStr(aType,100)+'"');
|
||||
end;
|
||||
@ -5969,6 +6034,16 @@ begin
|
||||
if not Found then
|
||||
RaiseMsg(20180215134804,ErrorEl,s);
|
||||
end;
|
||||
if Obj.Find('RefConstructorType')<>nil then
|
||||
begin
|
||||
Ref.Context:=TResolvedRefCtxConstructor.Create;
|
||||
ReadElementReference(Obj,Ref,'RefConstructorType',@Set_ResolvedReference_CtxConstructor);
|
||||
end
|
||||
else if Obj.Find('RefAttrProc')<>nil then
|
||||
begin
|
||||
Ref.Context:=TResolvedRefCtxAttrProc.Create;
|
||||
ReadElementReference(Obj,Ref,'RefAttrProc',@Set_ResolvedReference_CtxAttrProc);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadPasExpr(Obj: TJSONObject; Expr: TPasExpr;
|
||||
@ -7548,6 +7623,13 @@ begin
|
||||
El.TokenBased:=b;
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadAttributes(Obj: TJSONObject; El: TPasAttributes;
|
||||
aContext: TPCUReaderContext);
|
||||
begin
|
||||
ReadPasElement(Obj,El,aContext);
|
||||
ReadPasExprArray(Obj,El,'Calls',El.Calls,aContext);
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ResolvePending;
|
||||
var
|
||||
i: Integer;
|
||||
|
||||
@ -121,6 +121,7 @@ type
|
||||
procedure CheckRestoredMethodResolution(const Path: string; Orig, Rest: TPasMethodResolution); virtual;
|
||||
procedure CheckRestoredProcedure(const Path: string; Orig, Rest: TPasProcedure); virtual;
|
||||
procedure CheckRestoredOperator(const Path: string; Orig, Rest: TPasOperator); virtual;
|
||||
procedure CheckRestoredAttributes(const Path: string; Orig, Rest: TPasAttributes); virtual;
|
||||
public
|
||||
property Analyzer: TPas2JSAnalyzer read FAnalyzer;
|
||||
property RestAnalyzer: TPas2JSAnalyzer read FRestAnalyzer;
|
||||
@ -163,7 +164,7 @@ type
|
||||
procedure TestPC_Initialization;
|
||||
procedure TestPC_BoolSwitches;
|
||||
procedure TestPC_ClassInterface;
|
||||
procedure TestPC_IgnoreAttributes;
|
||||
procedure TestPC_Attributes;
|
||||
|
||||
procedure TestPC_UseUnit;
|
||||
procedure TestPC_UseUnit_Class;
|
||||
@ -1181,6 +1182,8 @@ begin
|
||||
CheckRestoredModule(Path,TPasModule(Orig),TPasModule(Rest))
|
||||
else if C.InheritsFrom(TPasSection) then
|
||||
CheckRestoredSection(Path,TPasSection(Orig),TPasSection(Rest))
|
||||
else if C=TPasAttributes then
|
||||
CheckRestoredAttributes(Path,TPasAttributes(Orig),TPasAttributes(Rest))
|
||||
else
|
||||
Fail(Path+': unknown class '+C.ClassName);
|
||||
|
||||
@ -1570,6 +1573,12 @@ begin
|
||||
CheckRestoredProcedure(Path,Orig,Rest);
|
||||
end;
|
||||
|
||||
procedure TCustomTestPrecompile.CheckRestoredAttributes(const Path: string;
|
||||
Orig, Rest: TPasAttributes);
|
||||
begin
|
||||
CheckRestoredPasExprArray(Path+'.Calls',Orig.Calls,Rest.Calls);
|
||||
end;
|
||||
|
||||
{ TTestPrecompile }
|
||||
|
||||
procedure TTestPrecompile.Test_Base256VLQ;
|
||||
@ -2213,22 +2222,35 @@ begin
|
||||
WriteReadUnit;
|
||||
end;
|
||||
|
||||
procedure TTestPrecompile.TestPC_IgnoreAttributes;
|
||||
procedure TTestPrecompile.TestPC_Attributes;
|
||||
begin
|
||||
StartUnit(false);
|
||||
Add([
|
||||
'interface',
|
||||
'{$modeswitch ignoreattributes}',
|
||||
'{$modeswitch PrefixedAttributes}',
|
||||
'type',
|
||||
' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
|
||||
' TObject = class',
|
||||
' [custom5()] FS: string;',
|
||||
' [customProp] property S: string read FS;',
|
||||
' constructor Create;',
|
||||
' end;',
|
||||
' TCustomAttribute = class',
|
||||
' constructor Create(Id: word);',
|
||||
' end;',
|
||||
' [Missing]',
|
||||
' TBird = class',
|
||||
' [TCustom]',
|
||||
' FField: word;',
|
||||
' end;',
|
||||
' TRec = record',
|
||||
' [TCustom]',
|
||||
' Size: word;',
|
||||
' end;',
|
||||
'var',
|
||||
' [custom6]',
|
||||
' [TCustom, TCustom(3)]',
|
||||
' o: TObject;',
|
||||
'implementation',
|
||||
'[TCustom]',
|
||||
'constructor TObject.Create; begin end;',
|
||||
'constructor TCustomAttribute.Create(Id: word); begin end;',
|
||||
'end.',
|
||||
'']);
|
||||
WriteReadUnit;
|
||||
|
||||
@ -800,7 +800,9 @@ type
|
||||
Procedure TestResourcestringImplementation;
|
||||
|
||||
// Attributes
|
||||
Procedure TestAtributes_Ignore;
|
||||
Procedure TestAttributes_Members;
|
||||
Procedure TestAttributes_Types;
|
||||
Procedure TestAttributes_HelperConstructor_Fail;
|
||||
|
||||
// Assertions, checks
|
||||
procedure TestAssert;
|
||||
@ -28494,38 +28496,197 @@ begin
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestAtributes_Ignore;
|
||||
procedure TTestModule.TestAttributes_Members;
|
||||
begin
|
||||
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch ignoreattributes}',
|
||||
'{$modeswitch PrefixedAttributes}',
|
||||
'type',
|
||||
' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
|
||||
' TObject = class',
|
||||
' [custom5()] FS: string;',
|
||||
' [customProp] property S: string read FS;',
|
||||
' constructor Create;',
|
||||
' end;',
|
||||
'var',
|
||||
' [custom6]',
|
||||
' o: TObject;',
|
||||
' TCustomAttribute = class',
|
||||
' constructor Create(Id: word);',
|
||||
' end;',
|
||||
' [Missing]',
|
||||
' TBird = class',
|
||||
' published',
|
||||
' [Tcustom]',
|
||||
' FField: word;',
|
||||
' [tcustom(14)]',
|
||||
' property Size: word read FField;',
|
||||
' [Tcustom(15)]',
|
||||
' procedure Fly; virtual; abstract;',
|
||||
' end;',
|
||||
' TRec = record',
|
||||
' [Tcustom,tcustom(14)]',
|
||||
' Size: word;',
|
||||
' end;',
|
||||
'constructor TObject.Create; begin end;',
|
||||
'constructor TCustomAttribute.Create(Id: word); begin end;',
|
||||
'begin',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestAtributes_Ignore',
|
||||
CheckSource('TestAttributes_Members',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' this.FS = "";',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
' this.Create = function () {',
|
||||
' return this;',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TCustomAttribute", $mod.TObject, function () {',
|
||||
' this.Create$1 = function (Id) {',
|
||||
' return this;',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.$init = function () {',
|
||||
' $mod.TObject.$init.call(this);',
|
||||
' this.FField = 0;',
|
||||
' };',
|
||||
' var $r = this.$rtti;',
|
||||
' $r.addField("FField", rtl.word, {',
|
||||
' attr: [$mod.TCustomAttribute, "Create"]',
|
||||
' });',
|
||||
' $r.addProperty(',
|
||||
' "Size",',
|
||||
' 0,',
|
||||
' rtl.word,',
|
||||
' "FField",',
|
||||
' "",',
|
||||
' {',
|
||||
' attr: [$mod.TCustomAttribute, "Create$1", [14]]',
|
||||
' }',
|
||||
' );',
|
||||
' $r.addMethod("Fly", 0, null, null, {',
|
||||
' attr: [$mod.TCustomAttribute, "Create$1", [15]]',
|
||||
' });',
|
||||
'});',
|
||||
'rtl.recNewT($mod, "TRec", function () {',
|
||||
' this.Size = 0;',
|
||||
' this.$eq = function (b) {',
|
||||
' return this.Size === b.Size;',
|
||||
' };',
|
||||
' this.$assign = function (s) {',
|
||||
' this.Size = s.Size;',
|
||||
' return this;',
|
||||
' };',
|
||||
' var $r = $mod.$rtti.$Record("TRec", {});',
|
||||
' $r.addField("Size", rtl.word, {',
|
||||
' attr: [',
|
||||
' $mod.TCustomAttribute,',
|
||||
' "Create",',
|
||||
' $mod.TCustomAttribute,',
|
||||
' "Create$1",',
|
||||
' [14]',
|
||||
' ]',
|
||||
' });',
|
||||
'});',
|
||||
'this.o = null;',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestAttributes_Types;
|
||||
begin
|
||||
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch PrefixedAttributes}',
|
||||
'type',
|
||||
' TObject = class',
|
||||
' constructor Create(Id: word);',
|
||||
' end;',
|
||||
' TCustomAttribute = class',
|
||||
' end;',
|
||||
' [TCustom(1)]',
|
||||
' TMyClass = class',
|
||||
' end;',
|
||||
' [TCustom(2)]',
|
||||
' TRec = record',
|
||||
' end;',
|
||||
' [TCustom(3)]',
|
||||
' TInt = type word;',
|
||||
'constructor TObject.Create(Id: word);',
|
||||
'begin',
|
||||
'end;',
|
||||
'var p: pointer;',
|
||||
'begin',
|
||||
' p:=typeinfo(TMyClass);',
|
||||
' p:=typeinfo(TRec);',
|
||||
' p:=typeinfo(TInt);',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestAttributes_Types',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
' this.Create = function (Id) {',
|
||||
' return this;',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TCustomAttribute", $mod.TObject, function () {',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TMyClass", $mod.TObject, function () {',
|
||||
' var $r = this.$rtti;',
|
||||
' $r.attr = [$mod.TCustomAttribute, "Create", [1]];',
|
||||
'});',
|
||||
'rtl.recNewT($mod, "TRec", function () {',
|
||||
' this.$eq = function (b) {',
|
||||
' return true;',
|
||||
' };',
|
||||
' this.$assign = function (s) {',
|
||||
' return this;',
|
||||
' };',
|
||||
' $mod.$rtti.$Record("TRec", {',
|
||||
' attr: [$mod.TCustomAttribute, "Create", [2]]',
|
||||
' });',
|
||||
'});',
|
||||
'$mod.$rtti.$inherited("TInt", rtl.word, {',
|
||||
' attr: [$mod.TCustomAttribute, "Create", [3]]',
|
||||
'});',
|
||||
'this.p = null;',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'$mod.p = $mod.$rtti["TMyClass"];',
|
||||
'$mod.p = $mod.$rtti["TRec"];',
|
||||
'$mod.p = $mod.$rtti["TInt"];',
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestAttributes_HelperConstructor_Fail;
|
||||
begin
|
||||
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch PrefixedAttributes}',
|
||||
'type',
|
||||
' TObject = class',
|
||||
' constructor Create;',
|
||||
' end;',
|
||||
' TCustomAttribute = class',
|
||||
' end;',
|
||||
' THelper = class helper for TCustomAttribute',
|
||||
' constructor Create(Id: word);',
|
||||
' end;',
|
||||
' [TCustom(3)]',
|
||||
' TMyInt = word;',
|
||||
'constructor TObject.Create; begin end;',
|
||||
'constructor THelper.Create(Id: word); begin end;',
|
||||
'begin',
|
||||
' if typeinfo(TMyInt)=nil then ;']);
|
||||
//SetExpectedConverterError('aaa',123);
|
||||
ConvertProgram;
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestAssert;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user