paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-18 14:29:13 +02:00
Code Issues Packages Projects Releases Wiki Activity

pastojs: attributes

Browse Source 
git-svn-id: trunk@41427 -
This commit is contained in:
Mattias Gaertner 2019-02-24 08:22:32 +00:00
parent cc22c70fa5
commit a532d1d8fb
4 changed files with 638 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

499
packages/pastojs/src/fppas2js.pp
View File

@ -681,6 +681,7 @@ type
pbivnRTTIInt_MinValue, pbivnRTTIInt_MinValue,
pbivnRTTIInt_OrdType, pbivnRTTIInt_OrdType,
pbivnRTTILocal, // $r pbivnRTTILocal, // $r
pbivnRTTIMemberAttributes,
pbivnRTTIMethodKind, // tTypeInfoMethodVar has methodkind pbivnRTTIMethodKind, // tTypeInfoMethodVar has methodkind
pbivnRTTIPointer_RefType, pbivnRTTIPointer_RefType,
pbivnRTTIProcFlags, pbivnRTTIProcFlags,
@ -689,6 +690,7 @@ type
pbivnRTTIPropIndex, pbivnRTTIPropIndex,
pbivnRTTIPropStored, pbivnRTTIPropStored,
pbivnRTTISet_CompType, pbivnRTTISet_CompType,
pbivnRTTITypeAttributes,
pbivnSelf, pbivnSelf,
pbivnTObjectDestroy, pbivnTObjectDestroy,
pbivnWith, pbivnWith,
@ -714,10 +716,10 @@ type
const const
Pas2JSBuiltInNames: array[TPas2JSBuiltInName] of string = ( Pas2JSBuiltInNames: array[TPas2JSBuiltInName] of string = (
'arrayConcat', // rtl.arrayConcat 'arrayConcat', // rtl.arrayConcat pbifnArray_Concat
'arrayConcatN', // rtl.arrayConcatN 'arrayConcatN', // rtl.arrayConcatN pbifnArray_ConcatN
'arrayCopy', // rtl.arrayCopy 'arrayCopy', // rtl.arrayCopy pbifnArray_Copy
'arrayEq', // rtl.arrayEq 'arrayEq', // rtl.arrayEq pbifnArray_Equal
'length', // rtl.length 'length', // rtl.length
'arraySetLength', // rtl.arraySetLength 'arraySetLength', // rtl.arraySetLength
'$clone', '$clone',
@ -836,37 +838,39 @@ const
'enumtype', 'enumtype',
'maxvalue', 'maxvalue',
'minvalue', 'minvalue',
'ordtype', 'ordtype', // pbivnRTTIInt_OrdType
'$r', '$r', // pbivnRTTILocal
'methodkind', 'attr', // pbivnRTTIMemberAttributes
'reftype', 'methodkind', // pbivnRTTIMethodKind
'flags', 'reftype', // pbivnRTTIPointer_RefType
'procsig', 'flags', // pbivnRTTIProcFlags
'Default', 'procsig', // pbivnRTTIProcVar_ProcSig
'index', 'Default', // pbivnRTTIPropDefault
'stored', 'index', // pbivnRTTIPropIndex
'comptype', 'stored', // pbivnRTTIPropStored
'$Self', 'comptype', // pbivnRTTISet_CompType
'tObjectDestroy', // rtl.tObjectDestroy 'attr', // pbivnRTTITypeAttributes
'$with', '$Self', // pbivnSelf
'$a', 'tObjectDestroy', // rtl.tObjectDestroy pbivnTObjectDestroy
'NativeInt', '$with', // pbivnWith
'tTypeInfo', // rtl. '$a', // pbitnAnonymousPostfix
'tTypeInfoClass', // rtl. 'NativeInt', // pbitnIntDouble
'tTypeInfoClassRef', // rtl. 'tTypeInfo', // pbitnTI
'tTypeInfoDynArray', // rtl. 'tTypeInfoClass', // pbitnTIClass
'tTypeInfoEnum', // rtl. 'tTypeInfoClassRef', // pbitnTIClassRef
'tTypeInfoHelper', // rtl. 'tTypeInfoDynArray', // pbitnTIDynArray
'tTypeInfoInteger', // rtl. 'tTypeInfoEnum', // pbitnTIEnum
'tTypeInfoInterface', // rtl. 'tTypeInfoHelper', // pbitnTIHelper
'tTypeInfoMethodVar', // rtl. 'tTypeInfoInteger', // pbitnTIInteger
'tTypeInfoPointer', // rtl. 'tTypeInfoInterface', // pbitnTIInterface
'tTypeInfoProcVar', // rtl. 'tTypeInfoMethodVar', // pbitnTIMethodVar
'tTypeInfoRecord', // rtl. 'tTypeInfoPointer', // pbitnTIPointer
'tTypeInfoRefToProcVar', // rtl. 'tTypeInfoProcVar', // pbitnTIProcVar
'tTypeInfoSet', // rtl. 'tTypeInfoRecord', // pbitnTIRecord
'tTypeInfoStaticArray', // rtl. 'tTypeInfoRefToProcVar', // pbitnTIRefToProcVar
'NativeUInt' 'tTypeInfoSet', // pbitnTISet
'tTypeInfoStaticArray', // pbitnTIStaticArray
'NativeUInt' // pbitnUIntDouble
); );
// reserved words, not usable as identifiers, not even as sub identifiers // reserved words, not usable as identifiers, not even as sub identifiers
@ -1161,7 +1165,7 @@ const
msExternalClass, msExternalClass,
msTypeHelpers, msTypeHelpers,
msArrayOperators, msArrayOperators,
msIgnoreAttributes, msPrefixedAttributes,
msOmitRTTI, msOmitRTTI,
msMultipleScopeHelpers]; msMultipleScopeHelpers];
@ -1824,10 +1828,16 @@ type
AContext: TConvertContext); virtual; AContext: TConvertContext); virtual;
Function CreateRTTINewType(El: TPasType; const CallFuncName: string; Function CreateRTTINewType(El: TPasType; const CallFuncName: string;
IsForward: boolean; AContext: TConvertContext; out ObjLit: TJSObjectLiteral): TJSCallExpression; virtual; IsForward: boolean; AContext: TConvertContext; out ObjLit: TJSObjectLiteral): TJSCallExpression; virtual;
Function CreateRTTIMemberField(V: TPasVariable; AContext: TConvertContext): TJSElement; virtual; Function CreateRTTIAttributes(const Attr: TPasExprArray; PosEl: TPasElement; aContext: TConvertContext): TJSElement; virtual;
Function CreateRTTIMemberMethod(Proc: TPasProcedure; AContext: TConvertContext): TJSElement; virtual; Function CreateRTTIMemberField(Members: TFPList; Index: integer;
Function CreateRTTIMemberProperty(Prop: TPasProperty; AContext: TConvertContext): TJSElement; virtual; 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; 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 // create elements for interfaces
Procedure AddIntfDelegations(ClassEl: TPasElement; Prop: TPasProperty; Procedure AddIntfDelegations(ClassEl: TPasElement; Prop: TPasProperty;
FinishedGUIDs: TStringList; ObjLit: TJSObjectLiteral; aContext: TFunctionContext); FinishedGUIDs: TStringList; ObjLit: TJSObjectLiteral; aContext: TFunctionContext);
@ -12621,6 +12631,8 @@ begin
AddResourceString(TPasResString(P)); AddResourceString(TPasResString(P));
continue; continue;
end end
else if C=TPasAttributes then
// ToDo
else else
RaiseNotSupported(P as TPasElement,AContext,20161024191434); RaiseNotSupported(P as TPasElement,AContext,20161024191434);
Add(E,P); Add(E,P);
@ -12886,6 +12898,9 @@ begin
continue continue
else if C=TPasMethodResolution then else if C=TPasMethodResolution then
continue continue
else if C=TPasAttributes then
// ToDo
continue
else else
RaiseNotSupported(P,FuncContext,20161221233338); RaiseNotSupported(P,FuncContext,20161221233338);
if NewEl<>nil then if NewEl<>nil then
@ -14969,65 +14984,24 @@ procedure TPasToJSConverter.CreateRecordRTTI(El: TPasRecordType;
var var
ObjLit: TJSObjectLiteral; ObjLit: TJSObjectLiteral;
Call: TJSCallExpression; Call: TJSCallExpression;
ok: Boolean; HasRTTIMembers: Boolean;
i: Integer;
P: TPasElement;
VarSt: TJSVariableStatement;
NewEl: TJSElement;
C: TClass;
begin begin
ok:=false;
Call:=nil; Call:=nil;
VarSt:=nil;
try try
// module.$rtti.$Record("typename",{}); // module.$rtti.$Record("typename",{});
Call:=CreateRTTINewType(El,GetBIName(pbifnRTTINewRecord),false,FuncContext,ObjLit); Call:=CreateRTTINewType(El,GetBIName(pbifnRTTINewRecord),false,FuncContext,ObjLit);
if ObjLit=nil then if ObjLit=nil then
RaiseInconsistency(20190105141430,El); RaiseInconsistency(20190105141430,El);
// add $r to local vars, to avoid name clashes and for nicer debugging HasRTTIMembers:=CreateRTTIMembers(El,Src,FuncContext,Call,false);
FuncContext.AddLocalVar(GetBIName(pbivnRTTILocal),nil); if not HasRTTIMembers then
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
begin begin
// no published members, add "module.$rtti.$Record..." // no published members, add "module.$rtti.$Record..."
AddToSourceElements(Src,Call); AddToSourceElements(Src,Call);
Call:=nil;
end; end;
ok:=true; Call:=nil;
finally finally
if not ok then
Call.Free; Call.Free;
end; end;
end; end;
@ -15620,61 +15594,37 @@ end;
procedure TPasToJSConverter.AddClassRTTI(El: TPasClassType; procedure TPasToJSConverter.AddClassRTTI(El: TPasClassType;
Src: TJSSourceElements; FuncContext: TFunctionContext); Src: TJSSourceElements; FuncContext: TFunctionContext);
function IsMemberNeeded(aMember: TPasElement): boolean;
begin
Result:=IsElementUsed(aMember);
end;
var var
HasRTTIMembers: Boolean; HasRTTIMembers, NeedLocalVar: Boolean;
i: Integer; RTTIExpr, AttrJS: TJSElement;
P: TPasElement; Attr: TPasExprArray;
NewEl: TJSElement; AssignSt: TJSAssignStatement;
VarSt: TJSVariableStatement;
C: TClass;
begin begin
// add $r to local vars, to avoid name clashes and for nicer debugging AttrJS:=nil;
FuncContext.AddLocalVar(GetBIName(pbivnRTTILocal),nil); // this.$rtti
RTTIExpr:=CreateMemberExpression(['this',GetBIName(pbivnRTTI)]);
try
Attr:=FuncContext.Resolver.GetAttributeCallsEl(El);
AttrJS:=CreateRTTIAttributes(Attr,El,FuncContext);
NeedLocalVar:=AttrJS<>nil;
HasRTTIMembers:=false; HasRTTIMembers:=CreateRTTIMembers(El,Src,FuncContext,RTTIExpr,NeedLocalVar);
For i:=0 to El.Members.Count-1 do if HasRTTIMembers then
begin RTTIExpr:=nil;
P:=TPasElement(El.Members[i]);
//writeln('TPasToJSConverter.ConvertClassType RTTI El[',i,']=',GetObjName(P)); if AttrJS<>nil then
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
begin begin
// add "var $r = this.$rtti" // $r.attr = [];
VarSt:=CreateVarStatement(GetBIName(pbivnRTTILocal), AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
CreateMemberExpression(['this',GetBIName(pbivnRTTI)]),El); AddToSourceElements(Src,AssignSt);
AddToSourceElements(Src,VarSt); AssignSt.LHS:=CreateMemberExpression([GetBIName(pbivnRTTILocal),GetBIName(pbivnRTTITypeAttributes)]);
AssignSt.Expr:=AttrJS;
HasRTTIMembers:=true; AttrJS:=nil;
end; end;
AddToSourceElements(Src,NewEl); finally
end; AttrJS.Free;
RTTIExpr.Free;
end;
end; end;
procedure TPasToJSConverter.AddClassConstructors(FuncContext: TFunctionContext; procedure TPasToJSConverter.AddClassConstructors(FuncContext: TFunctionContext;
@ -16402,9 +16352,15 @@ var
RttiPath, TypeName: String; RttiPath, TypeName: String;
Call: TJSCallExpression; Call: TJSCallExpression;
aModule: TPasModule; aModule: TPasModule;
aResolver: TPas2JSResolver;
Attr: TPasExprArray;
AttrJS: TJSElement;
ObjLitEl: TJSObjectLiteralElement;
begin begin
Result:=nil; Result:=nil;
ObjLit:=nil; ObjLit:=nil;
aResolver:=AContext.Resolver;
// get module path // get module path
aModule:=El.GetModule; aModule:=El.GetModule;
if aModule=nil then if aModule=nil then
@ -16430,7 +16386,18 @@ begin
// add {} // add {}
ObjLit:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El)); ObjLit:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El));
Call.AddArg(ObjLit); 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; end;
Result:=Call; Result:=Call;
finally finally
if Result=nil then if Result=nil then
@ -16438,36 +16405,164 @@ begin
end; end;
end; end;
function TPasToJSConverter.CreateRTTIMemberField(V: TPasVariable; function TPasToJSConverter.CreateRTTIAttributes(const Attr: TPasExprArray;
AContext: TConvertContext): TJSElement; PosEl: TPasElement; aContext: TConvertContext): TJSElement;
// create $r.addField("varname",typeinfo); // create [Attr1Class,'Attr1ProcName',[Attr1Params],...]
var 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; 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 var
JSTypeInfo: TJSElement; JSTypeInfo: TJSElement;
aName: String; aName: String;
aResolver: TPas2JSResolver;
Attr: TPasExprArray;
begin begin
Result:=nil; Result:=nil;
aResolver:=AContext.Resolver;
V:=TPasVariable(Members[Index]);
if (V.VarType<>nil) and (V.VarType.Name='') then if (V.VarType<>nil) and (V.VarType.Name='') then
CreateRTTIAnonymous(V.VarType,AContext); CreateRTTIAnonymous(V.VarType,AContext);
JSTypeInfo:=CreateTypeInfoRef(V.VarType,AContext,V); JSTypeInfo:=CreateTypeInfoRef(V.VarType,AContext,V);
OptionsEl:=nil;
// Note: create JSTypeInfo first, it may raise an exception // Note: create JSTypeInfo first, it may raise an exception
Call:=CreateCallExpression(V); Call:=CreateCallExpression(V);
// $r.addField try
Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTTILocal),GetBIName(pbifnRTTIAddField)]); // $r.addField
// param "varname" Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTTILocal),GetBIName(pbifnRTTIAddField)]);
aName:=TransformVariableName(V,AContext); // param "varname"
Call.AddArg(CreateLiteralString(V,aName)); aName:=TransformVariableName(V,AContext);
// param typeinfo Call.AddArg(CreateLiteralString(V,aName));
Call.AddArg(JSTypeInfo); // param typeinfo
Result:=Call; 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; end;
function TPasToJSConverter.CreateRTTIMemberMethod(Proc: TPasProcedure; function TPasToJSConverter.CreateRTTIMemberMethod(Members: TFPList;
AContext: TConvertContext): TJSElement; Index: integer; AContext: TConvertContext): TJSElement;
// create $r.addMethod("funcname",methodkind,params,resulttype,options) // create $r.addMethod("funcname",methodkind,params,resulttype,options)
var var
Proc: TPasProcedure;
OptionsEl: TJSObjectLiteral; OptionsEl: TJSObjectLiteral;
ResultTypeInfo: TJSElement; ResultTypeInfo: TJSElement;
Call: TJSCallExpression; Call: TJSCallExpression;
@ -16476,6 +16571,7 @@ var
var var
ObjLit: TJSObjectLiteralElement; ObjLit: TJSObjectLiteralElement;
begin begin
if JS=nil then exit;
if OptionsEl=nil then if OptionsEl=nil then
begin begin
OptionsEl:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,Proc)); OptionsEl:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,Proc));
@ -16495,8 +16591,12 @@ var
ResultEl: TPasResultElement; ResultEl: TPasResultElement;
ProcScope, OverriddenProcScope: TPasProcedureScope; ProcScope, OverriddenProcScope: TPasProcedureScope;
OverriddenClass: TPasClassType; OverriddenClass: TPasClassType;
aResolver: TPas2JSResolver;
Attr: TPasExprArray;
begin begin
Result:=nil; Result:=nil;
Proc:=TPasProcedure(Members[Index]);
aResolver:=AContext.Resolver;
if Proc.IsOverride then if Proc.IsOverride then
begin begin
ProcScope:=Proc.CustomData as TPasProcedureScope; ProcScope:=Proc.CustomData as TPasProcedureScope;
@ -16564,6 +16664,10 @@ begin
inc(Flags,pfExternal); inc(Flags,pfExternal);
if Flags>0 then if Flags>0 then
AddOption(GetBIName(pbivnRTTIProcFlags),CreateLiteralNumber(Proc,Flags)); 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; Result:=Call;
finally finally
@ -16572,10 +16676,11 @@ begin
end; end;
end; end;
function TPasToJSConverter.CreateRTTIMemberProperty(Prop: TPasProperty; function TPasToJSConverter.CreateRTTIMemberProperty(Members: TFPList;
AContext: TConvertContext): TJSElement; Index: integer; AContext: TConvertContext): TJSElement;
// create $r.addProperty("propname",flags,result,"getter","setter",{options}) // create $r.addProperty("propname",flags,result,"getter","setter",{options})
var var
Prop: TPasProperty;
Call: TJSCallExpression; Call: TJSCallExpression;
OptionsEl: TJSObjectLiteral; OptionsEl: TJSObjectLiteral;
@ -16588,6 +16693,7 @@ var
var var
ObjLit: TJSObjectLiteralElement; ObjLit: TJSObjectLiteralElement;
begin begin
if JS=nil then exit;
if OptionsEl=nil then if OptionsEl=nil then
begin begin
OptionsEl:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,Prop)); OptionsEl:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,Prop));
@ -16608,8 +16714,10 @@ var
StoredResolved, VarTypeResolved: TPasResolverResult; StoredResolved, VarTypeResolved: TPasResolverResult;
StoredValue, PasValue, IndexValue: TResEvalValue; StoredValue, PasValue, IndexValue: TResEvalValue;
aResolver: TPas2JSResolver; aResolver: TPas2JSResolver;
Attr: TPasExprArray;
begin begin
Result:=nil; Result:=nil;
Prop:=TPasProperty(Members[Index]);
aResolver:=AContext.Resolver; aResolver:=AContext.Resolver;
OptionsEl:=nil; OptionsEl:=nil;
try try
@ -16726,6 +16834,12 @@ begin
end; end;
end; end;
// add option "attr"
Attr:=aResolver.GetAttributeCalls(Members,Index);
if length(Attr)>0 then
AddOption(GetBIName(pbivnRTTIMemberAttributes),
CreateRTTIAttributes(Attr,Prop,AContext));
Result:=Call; Result:=Call;
finally finally
if Result=nil then if Result=nil then
@ -16764,6 +16878,89 @@ begin
end; end;
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; procedure TPasToJSConverter.AddIntfDelegations(ClassEl: TPasElement;
Prop: TPasProperty; FinishedGUIDs: TStringList; ObjLit: TJSObjectLiteral; Prop: TPasProperty; FinishedGUIDs: TStringList; ObjLit: TJSObjectLiteral;
aContext: TFunctionContext); aContext: TFunctionContext);
@ -17395,7 +17592,6 @@ var
List: TJSStatementList; List: TJSStatementList;
begin begin
RgCheck:=nil; RgCheck:=nil;
writeln('AAA1 CreateRefObj SetExpr=',GetObjName(SetExpr),' SetterArgName=',SetterArgName,' ',bsRangeChecks in AContext.ScannerBoolSwitches);
if (SetExpr is TJSSimpleAssignStatement) if (SetExpr is TJSSimpleAssignStatement)
and (SetterArgName<>'') and (SetterArgName<>'')
and (bsRangeChecks in AContext.ScannerBoolSwitches) then and (bsRangeChecks in AContext.ScannerBoolSwitches) then
@ -22044,8 +22240,9 @@ begin
and not aResolver.MethodIsStatic(TPasProcedure(P))) then and not aResolver.MethodIsStatic(TPasProcedure(P))) then
IsFull:=true; // needs $record IsFull:=true; // needs $record
end; end;
continue;
end end
else if C=TPasAttributes then
// ToDo
else else
RaiseNotSupported(P,FuncContext,20190105105436); RaiseNotSupported(P,FuncContext,20190105105436);
if NewEl<>nil then if NewEl<>nil then

94
packages/pastojs/src/pas2jsfiler.pp
View File

@ -71,7 +71,7 @@ uses
const const
PCUMagic = 'Pas2JSCache'; PCUMagic = 'Pas2JSCache';
PCUVersion = 4; PCUVersion = 5;
{ Version Changes: { Version Changes:
1: initial version 1: initial version
2: - TPasProperty.ImplementsFunc:String -> Implements:TPasExprArray 2: - TPasProperty.ImplementsFunc:String -> Implements:TPasExprArray
@ -80,6 +80,7 @@ const
3: changed records from function to objects (pas2js 1.3) 3: changed records from function to objects (pas2js 1.3)
4: precompiled JS of initialization section now only contains the statements, 4: precompiled JS of initialization section now only contains the statements,
not the whole $init function (pas2js 1.5) not the whole $init function (pas2js 1.5)
5: removed modeswitch ignoreattributes
} }
BuiltInNodeName = 'BuiltIn'; BuiltInNodeName = 'BuiltIn';
@ -170,10 +171,9 @@ const
'ArrayOperators', 'ArrayOperators',
'ExternalClass', 'ExternalClass',
'PrefixedAttributes', 'PrefixedAttributes',
'IgnoreAttributes',
'OmitRTTI', 'OmitRTTI',
'MultipleScopeHelpers' 'MultipleScopeHelpers'
); ); // Dont forget to update ModeSwitchToInt !
PCUDefaultBoolSwitches: TBoolSwitches = [ PCUDefaultBoolSwitches: TBoolSwitches = [
bsHints, bsHints,
@ -780,6 +780,7 @@ type
procedure WriteProcedureScope(Obj: TJSONObject; Scope: TPas2JSProcedureScope; aContext: TPCUWriterContext); virtual; procedure WriteProcedureScope(Obj: TJSONObject; Scope: TPas2JSProcedureScope; aContext: TPCUWriterContext); virtual;
procedure WriteProcedure(Obj: TJSONObject; El: TPasProcedure; aContext: TPCUWriterContext); virtual; procedure WriteProcedure(Obj: TJSONObject; El: TPasProcedure; aContext: TPCUWriterContext); virtual;
procedure WriteOperator(Obj: TJSONObject; El: TPasOperator; 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; procedure WriteExtRefSignature(Ref: TPCUFilerElementRef; aContext: TPCUWriterContext); virtual;
function WriteExternalReference(El: TPasElement; aContext: TPCUWriterContext): TPCUFilerElementRef; virtual; function WriteExternalReference(El: TPasElement; aContext: TPCUWriterContext): TPCUFilerElementRef; virtual;
procedure WriteExternalReferences(aContext: TPCUWriterContext); virtual; procedure WriteExternalReferences(aContext: TPCUWriterContext); virtual;
@ -869,6 +870,8 @@ type
procedure Set_ProcedureScope_ImplProc(RefEl: TPasElement; Data: TObject); procedure Set_ProcedureScope_ImplProc(RefEl: TPasElement; Data: TObject);
procedure Set_ProcedureScope_Overridden(RefEl: TPasElement; Data: TObject); procedure Set_ProcedureScope_Overridden(RefEl: TPasElement; Data: TObject);
procedure Set_ResolvedReference_Declaration(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 protected
procedure RaiseMsg(Id: int64; const Msg: string = ''); overload; override; procedure RaiseMsg(Id: int64; const Msg: string = ''); overload; override;
function CheckJSONArray(Data: TJSONData; El: TPasElement; const PropName: string): TJSONArray; 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 ReadProcedureBody(Obj: TJSONObject; El: TPasProcedure; aContext: TPCUReaderContext); virtual;
procedure ReadProcedure(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 ReadOperator(Obj: TJSONObject; El: TPasOperator; aContext: TPCUReaderContext); virtual;
procedure ReadAttributes(Obj: TJSONObject; El: TPasAttributes; aContext: TPCUReaderContext); virtual;
procedure ResolvePending; virtual; procedure ResolvePending; virtual;
procedure ReadBuiltInSymbols(Obj: TJSONObject; ErrorEl: TPasElement); virtual; procedure ReadBuiltInSymbols(Obj: TJSONObject; ErrorEl: TPasElement); virtual;
public public
@ -1388,7 +1392,9 @@ begin
msExternalClass: Result:=44; msExternalClass: Result:=44;
msPrefixedAttributes: Result:=45; msPrefixedAttributes: Result:=45;
// msIgnoreInterfaces: Result:=46; // msIgnoreInterfaces: Result:=46;
msIgnoreAttributes: Result:=47; // msIgnoreAttributes: Result:=47;
msOmitRTTI: Result:=48;
msMultipleScopeHelpers: Result:=49;
end; end;
end; end;
@ -2790,6 +2796,8 @@ begin
pekArrayParams: Obj.Add('Type','A[]'); pekArrayParams: Obj.Add('Type','A[]');
pekFuncParams: Obj.Add('Type','F()'); pekFuncParams: Obj.Add('Type','F()');
pekSet: Obj.Add('Type','[]'); pekSet: Obj.Add('Type','[]');
else
RaiseMsg(20190222012727,El,ExprKindNames[TParamsExpr(El).Kind]);
end; end;
WriteParamsExpr(Obj,TParamsExpr(El),aContext); WriteParamsExpr(Obj,TParamsExpr(El),aContext);
end end
@ -2966,6 +2974,11 @@ begin
RaiseMsg(20180210130202,El); RaiseMsg(20180210130202,El);
WriteProcedure(Obj,TPasProcedure(El),aContext); WriteProcedure(Obj,TPasProcedure(El),aContext);
end end
else if C=TPasAttributes then
begin
Obj.Add('Type','Attributes');
WriteAttributes(Obj,TPasAttributes(El),aContext);
end
else else
begin begin
{$IFDEF VerbosePCUFiler} {$IFDEF VerbosePCUFiler}
@ -3019,6 +3032,8 @@ end;
procedure TPCUWriter.WriteResolvedReference(Obj: TJSONObject; procedure TPCUWriter.WriteResolvedReference(Obj: TJSONObject;
Ref: TResolvedReference; ErrorEl: TPasElement); Ref: TResolvedReference; ErrorEl: TPasElement);
var
Ctx: TResolvedRefContext;
begin begin
WriteResolvedRefFlags(Obj,'RefFlags',Ref.Flags,[]); WriteResolvedRefFlags(Obj,'RefFlags',Ref.Flags,[]);
if Ref.Access<>rraRead then if Ref.Access<>rraRead then
@ -3026,7 +3041,23 @@ begin
if Ref.WithExprScope<>nil then if Ref.WithExprScope<>nil then
RaiseMsg(20180215132828,ErrorEl); RaiseMsg(20180215132828,ErrorEl);
if Ref.Context<>nil then 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); AddReferenceToObj(Obj,'RefDecl',Ref.Declaration);
end; end;
@ -3806,6 +3837,13 @@ begin
Obj.Add('TokenBased',El.TokenBased); Obj.Add('TokenBased',El.TokenBased);
end; 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; procedure TPCUWriter.WriteExtRefSignature(Ref: TPCUFilerElementRef;
aContext: TPCUWriterContext); aContext: TPCUWriterContext);
@ -4485,6 +4523,28 @@ begin
Ref.Declaration:=RefEl; Ref.Declaration:=RefEl;
end; 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); procedure TPCUReader.RaiseMsg(Id: int64; const Msg: string);
var var
E: EPas2JsReadError; E: EPas2JsReadError;
@ -4906,7 +4966,7 @@ begin
end; end;
if not Found then if not Found then
begin begin
if (FileVersion<2) and (SameText(s,'ignoreinterfaces')) then if (FileVersion<5) and (SameText(s,'ignoreinterfaces')) then
// ignore old switch // ignore old switch
else else
RaiseMsg(20180202144054,El,'unknown ModeSwitch "'+s+'"'); RaiseMsg(20180202144054,El,'unknown ModeSwitch "'+s+'"');
@ -5786,6 +5846,11 @@ begin
'ClassDestructor': ReadProc(TPasClassDestructor,Name); 'ClassDestructor': ReadProc(TPasClassDestructor,Name);
'Operator': ReadOper(TPasConstructor,Name); 'Operator': ReadOper(TPasConstructor,Name);
'ClassOperator': ReadOper(TPasClassConstructor,Name); 'ClassOperator': ReadOper(TPasClassConstructor,Name);
'Attributes':
begin
Result:=CreateElement(TPasAttributes,Name,Parent);
ReadAttributes(Obj,TPasAttributes(Result),aContext);
end;
else else
RaiseMsg(20180210143758,Parent,'unknown type "'+LeftStr(aType,100)+'"'); RaiseMsg(20180210143758,Parent,'unknown type "'+LeftStr(aType,100)+'"');
end; end;
@ -5969,6 +6034,16 @@ begin
if not Found then if not Found then
RaiseMsg(20180215134804,ErrorEl,s); RaiseMsg(20180215134804,ErrorEl,s);
end; 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; end;
procedure TPCUReader.ReadPasExpr(Obj: TJSONObject; Expr: TPasExpr; procedure TPCUReader.ReadPasExpr(Obj: TJSONObject; Expr: TPasExpr;
@ -7548,6 +7623,13 @@ begin
El.TokenBased:=b; El.TokenBased:=b;
end; 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; procedure TPCUReader.ResolvePending;
var var
i: Integer; i: Integer;

36
packages/pastojs/tests/tcfiler.pas
View File

@ -121,6 +121,7 @@ type
procedure CheckRestoredMethodResolution(const Path: string; Orig, Rest: TPasMethodResolution); virtual; procedure CheckRestoredMethodResolution(const Path: string; Orig, Rest: TPasMethodResolution); virtual;
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;
procedure CheckRestoredAttributes(const Path: string; Orig, Rest: TPasAttributes); virtual;
public public
property Analyzer: TPas2JSAnalyzer read FAnalyzer; property Analyzer: TPas2JSAnalyzer read FAnalyzer;
property RestAnalyzer: TPas2JSAnalyzer read FRestAnalyzer; property RestAnalyzer: TPas2JSAnalyzer read FRestAnalyzer;
@ -163,7 +164,7 @@ type
procedure TestPC_Initialization; procedure TestPC_Initialization;
procedure TestPC_BoolSwitches; procedure TestPC_BoolSwitches;
procedure TestPC_ClassInterface; procedure TestPC_ClassInterface;
procedure TestPC_IgnoreAttributes; procedure TestPC_Attributes;
procedure TestPC_UseUnit; procedure TestPC_UseUnit;
procedure TestPC_UseUnit_Class; procedure TestPC_UseUnit_Class;
@ -1181,6 +1182,8 @@ begin
CheckRestoredModule(Path,TPasModule(Orig),TPasModule(Rest)) CheckRestoredModule(Path,TPasModule(Orig),TPasModule(Rest))
else if C.InheritsFrom(TPasSection) then else if C.InheritsFrom(TPasSection) then
CheckRestoredSection(Path,TPasSection(Orig),TPasSection(Rest)) CheckRestoredSection(Path,TPasSection(Orig),TPasSection(Rest))
else if C=TPasAttributes then
CheckRestoredAttributes(Path,TPasAttributes(Orig),TPasAttributes(Rest))
else else
Fail(Path+': unknown class '+C.ClassName); Fail(Path+': unknown class '+C.ClassName);
@ -1570,6 +1573,12 @@ begin
CheckRestoredProcedure(Path,Orig,Rest); CheckRestoredProcedure(Path,Orig,Rest);
end; end;
procedure TCustomTestPrecompile.CheckRestoredAttributes(const Path: string;
Orig, Rest: TPasAttributes);
begin
CheckRestoredPasExprArray(Path+'.Calls',Orig.Calls,Rest.Calls);
end;
{ TTestPrecompile } { TTestPrecompile }
procedure TTestPrecompile.Test_Base256VLQ; procedure TTestPrecompile.Test_Base256VLQ;
@ -2213,22 +2222,35 @@ begin
WriteReadUnit; WriteReadUnit;
end; end;
procedure TTestPrecompile.TestPC_IgnoreAttributes; procedure TTestPrecompile.TestPC_Attributes;
begin begin
StartUnit(false); StartUnit(false);
Add([ Add([
'interface', 'interface',
'{$modeswitch ignoreattributes}', '{$modeswitch PrefixedAttributes}',
'type', 'type',
' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
' TObject = class', ' TObject = class',
' [custom5()] FS: string;', ' constructor Create;',
' [customProp] property S: string read FS;', ' end;',
' TCustomAttribute = class',
' constructor Create(Id: word);',
' end;',
' [Missing]',
' TBird = class',
' [TCustom]',
' FField: word;',
' end;',
' TRec = record',
' [TCustom]',
' Size: word;',
' end;', ' end;',
'var', 'var',
' [custom6]', ' [TCustom, TCustom(3)]',
' o: TObject;', ' o: TObject;',
'implementation', 'implementation',
'[TCustom]',
'constructor TObject.Create; begin end;',
'constructor TCustomAttribute.Create(Id: word); begin end;',
'end.', 'end.',
'']); '']);
WriteReadUnit; WriteReadUnit;

185
packages/pastojs/tests/tcmodules.pas
View File

@ -800,7 +800,9 @@ type
Procedure TestResourcestringImplementation; Procedure TestResourcestringImplementation;
// Attributes // Attributes
Procedure TestAtributes_Ignore; Procedure TestAttributes_Members;
Procedure TestAttributes_Types;
Procedure TestAttributes_HelperConstructor_Fail;
// Assertions, checks // Assertions, checks
procedure TestAssert; procedure TestAssert;
@ -28494,38 +28496,197 @@ begin
''])); '']));
end; end;
procedure TTestModule.TestAtributes_Ignore; procedure TTestModule.TestAttributes_Members;
begin begin
Converter.Options:=Converter.Options-[coNoTypeInfo];
StartProgram(false); StartProgram(false);
Add([ Add([
'{$modeswitch ignoreattributes}', '{$modeswitch PrefixedAttributes}',
'type', 'type',
' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
' TObject = class', ' TObject = class',
' [custom5()] FS: string;', ' constructor Create;',
' [customProp] property S: string read FS;',
' end;', ' end;',
'var', ' TCustomAttribute = class',
' [custom6]', ' constructor Create(Id: word);',
' o: TObject;', ' 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', 'begin',
'']); '']);
ConvertProgram; ConvertProgram;
CheckSource('TestAtributes_Ignore', CheckSource('TestAttributes_Members',
LinesToStr([ // statements LinesToStr([ // statements
'rtl.createClass($mod, "TObject", null, function () {', 'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {', ' this.$init = function () {',
' this.FS = "";',
' };', ' };',
' this.$final = function () {', ' 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 LinesToStr([ // $mod.$main
''])); '']));
end; 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; procedure TTestModule.TestAssert;
begin begin
StartProgram(false); StartProgram(false);