diff --git a/packages/fcl-passrc/src/pasuseanalyzer.pas b/packages/fcl-passrc/src/pasuseanalyzer.pas index 4e3e92ae6c..7cb066cb0d 100644 --- a/packages/fcl-passrc/src/pasuseanalyzer.pas +++ b/packages/fcl-passrc/src/pasuseanalyzer.pas @@ -262,8 +262,7 @@ type procedure UseProcedure(Proc: TPasProcedure); virtual; procedure UseProcedureType(ProcType: TPasProcedureType; Mark: boolean); virtual; procedure UseType(El: TPasType; Mode: TPAUseMode); virtual; - procedure UseRecordType(El: TPasRecordType; Mode: TPAUseMode); virtual; - procedure UseClassType(El: TPasClassType; Mode: TPAUseMode); virtual; + procedure UseClassOrRecType(El: TPasMembersType; Mode: TPAUseMode); virtual; procedure UseVariable(El: TPasVariable; Access: TResolvedRefAccess; UseFull: boolean); virtual; procedure UseResourcestring(El: TPasResString); virtual; @@ -1178,7 +1177,7 @@ begin UseInitFinal(aModule.FinalizationSection); ModScope:=aModule.CustomData as TPasModuleScope; if ModScope.RangeErrorClass<>nil then - UseClassType(ModScope.RangeErrorClass,paumElement); + UseClassOrRecType(ModScope.RangeErrorClass,paumElement); if ModScope.RangeErrorConstructor<>nil then UseProcedure(ModScope.RangeErrorConstructor); @@ -1815,10 +1814,8 @@ begin {$IFDEF VerbosePasAnalyzer} writeln('TPasAnalyzer.UseType searching exports in ',GetElModName(El),' ...'); {$ENDIF} - if C=TPasRecordType then - UseRecordType(TPasRecordType(El),Mode) - else if C=TPasClassType then - UseClassType(TPasClassType(El),Mode); + if (C=TPasRecordType) or (C=TPasClassType) then + UseClassOrRecType(TPasMembersType(El),Mode); end else begin @@ -1848,10 +1845,8 @@ begin UseExpr(TPasArrayType(El).Ranges[i]); UseElType(El,TPasArrayType(El).ElType,Mode); end - else if C=TPasRecordType then - UseRecordType(TPasRecordType(El),Mode) - else if C=TPasClassType then - UseClassType(TPasClassType(El),Mode) + else if (C=TPasRecordType) or (C=TPasClassType) then + UseClassOrRecType(TPasMembersType(El),Mode) else if C=TPasEnumType then begin if not MarkElementAsUsed(El) then exit; @@ -1883,22 +1878,7 @@ begin end; end; -procedure TPasAnalyzer.UseRecordType(El: TPasRecordType; Mode: TPAUseMode); -// called by UseType -var - i: Integer; -begin - if Mode=paumAllExports then exit; - MarkElementAsUsed(El); - if not ElementVisited(El,Mode) then - begin - if (Mode=paumAllPasUsable) or Resolver.IsTGUID(El) then - for i:=0 to El.Members.Count-1 do - UseVariable(TObject(El.Members[i]) as TPasVariable,rraNone,true); - end; -end; - -procedure TPasAnalyzer.UseClassType(El: TPasClassType; Mode: TPAUseMode); +procedure TPasAnalyzer.UseClassOrRecType(El: TPasMembersType; Mode: TPAUseMode); // called by UseType procedure UseDelegations; @@ -1936,7 +1916,7 @@ procedure TPasAnalyzer.UseClassType(El: TPasClassType; Mode: TPAUseMode); Map:=TPasClassIntfMap(o); repeat if Map.Intf<>nil then - UseClassType(TPasClassType(Map.Intf),paumElement); + UseClassOrRecType(TPasClassType(Map.Intf),paumElement); if Map.Procs<>nil then for j:=0 to Map.Procs.Count-1 do UseProcedure(TPasProcedure(Map.Procs[j])); @@ -1960,6 +1940,7 @@ var o: TObject; Map: TPasClassIntfMap; ImplProc, IntfProc: TPasProcedure; + aClass: TPasClassType; begin FirstTime:=true; case Mode of @@ -1982,35 +1963,54 @@ begin {$IFDEF VerbosePasAnalyzer} writeln('TPasAnalyzer.UseClassType ',GetElModName(El),' ',Mode,' First=',FirstTime); {$ENDIF} - if El.IsForward then - begin - Ref:=El.CustomData as TResolvedReference; - UseClassType(Ref.Declaration as TPasClassType,Mode); - exit; - end; - - ClassScope:=El.CustomData as TPasClassScope; - if ClassScope=nil then - exit; // ClassScope can be nil if msIgnoreInterfaces - + aClass:=nil; + ClassScope:=nil; IsCOMInterfaceRoot:=false; - if FirstTime then + + if El is TPasClassType then begin - UseElType(El,ClassScope.DirectAncestor,paumElement); - UseElType(El,El.HelperForType,paumElement); - UseExpr(El.GUIDExpr); - // El.Interfaces: using a class does not use automatically the interfaces - if El.ObjKind=okInterface then + aClass:=TPasClassType(El); + if aClass.IsForward then begin - UseDelegations; - if (El.InterfaceType=citCom) and (El.AncestorType=nil) then - IsCOMInterfaceRoot:=true; + Ref:=aClass.CustomData as TResolvedReference; + UseClassOrRecType(Ref.Declaration as TPasClassType,Mode); + exit; end; - if (El.ObjKind=okClass) and (ScopeModule<>nil) - and (ClassScope.Interfaces<>nil) then - // when checking a single unit, mark all method+properties implementing the interfaces - MarkAllInterfaceImplementations(ClassScope); - end; + + ClassScope:=aClass.CustomData as TPasClassScope; + if ClassScope=nil then + exit; // ClassScope can be nil if msIgnoreInterfaces + + if FirstTime then + begin + UseElType(El,ClassScope.DirectAncestor,paumElement); + UseElType(El,aClass.HelperForType,paumElement); + UseExpr(aClass.GUIDExpr); + // aClass.Interfaces: using a class does not use automatically the interfaces + if aClass.ObjKind=okInterface then + begin + UseDelegations; + if (aClass.InterfaceType=citCom) and (aClass.AncestorType=nil) then + IsCOMInterfaceRoot:=true; + end; + if (aClass.ObjKind=okClass) and (ScopeModule<>nil) + and (ClassScope.Interfaces<>nil) then + // when checking a single unit, mark all method+properties implementing the interfaces + MarkAllInterfaceImplementations(ClassScope); + end; + end + else if El is TPasRecordType then + begin + if (Mode<>paumAllPasUsable) and Resolver.IsTGUID(TPasRecordType(El)) then + for i:=0 to El.Members.Count-1 do + begin + Member:=TPasElement(El.Members[i]); + if Member is TPasVariable then + UseVariable(TPasVariable(Member),rraNone,true); + end; + end + else + RaiseNotSupported(20181229103139,El); // members AllPublished:=(Mode<>paumAllExports); @@ -2074,11 +2074,11 @@ begin UseTypeInfo(Member); end else - ; // else: class is in unit interface, mark all non private members + ; // else: class/record is in unit interface, mark all non private members UseElement(Member,rraNone,true); end; - if FirstTime then + if FirstTime and (ClassScope<>nil) then begin // method resolution List:=ClassScope.Interfaces; @@ -2090,7 +2090,7 @@ begin begin // interface delegation // Note: This class is used. When the intftype is used, this delegation is used. - AddOverride(TPasType(El.Interfaces[i]),TPasProperty(o)); + AddOverride(TPasType(aClass.Interfaces[i]),TPasProperty(o)); end else if o is TPasClassIntfMap then begin @@ -2111,7 +2111,7 @@ begin end; end else - RaiseNotSupported(20180328224632,El,GetObjName(o)); + RaiseNotSupported(20180328224632,aClass,GetObjName(o)); end; end; end; diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 31b85f0d3b..d167202b67 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -1206,6 +1206,7 @@ type procedure InternalAdd(Item: TPasIdentifier); procedure OnClearHashItem(Item, Dummy: pointer); protected + // overloads: fix name clashes in JS FOverloadScopes: TFPList; // list of TPasIdentifierScope function HasOverloadIndex(El: TPasElement; WithElevatedLocal: boolean = false): boolean; virtual; function GetOverloadIndex(Identifier: TPasIdentifier; @@ -1219,7 +1220,8 @@ type procedure RenameSubOverloads(Declarations: TFPList); procedure PushOverloadScope(Scope: TPasIdentifierScope); procedure PopOverloadScope; - procedure AddType(El: TPasType); override; + protected + procedure AddRecordType(El: TPasRecordType); override; procedure ResolveImplAsm(El: TPasImplAsmStatement); override; procedure ResolveNameExpr(El: TPasExpr; const aName: string; Access: TResolvedRefAccess); override; @@ -1245,6 +1247,7 @@ type function AddExternalName(const aName: string; El: TPasElement): TPasIdentifier; virtual; function FindExternalName(const aName: String): TPasIdentifier; virtual; procedure AddExternalPath(aName: string; El: TPasElement); + procedure AddElevatedLocal(El: TPasElement); virtual; procedure ClearElementData; virtual; function GenerateGUID(El: TPasClassType): string; virtual; protected @@ -1697,8 +1700,7 @@ type Function CreateRTTIClassField(V: TPasVariable; AContext: TConvertContext): TJSElement; virtual; Function CreateRTTIClassMethod(Proc: TPasProcedure; AContext: TConvertContext): TJSElement; virtual; Function CreateRTTIClassProperty(Prop: TPasProperty; AContext: TConvertContext): TJSElement; virtual; - Procedure CreateRTTIAnonymous(El: TPasType; AContext: TConvertContext; - var First, Last: TJSStatementList); virtual; + Procedure CreateRTTIAnonymous(El: TPasType; AContext: TConvertContext); virtual; // create elements for interfaces Procedure AddIntfDelegations(ClassEl: TPasElement; Prop: TPasProperty; FinishedGUIDs: TStringList; ObjLit: TJSObjectLiteral; aContext: TFunctionContext); @@ -2499,6 +2501,11 @@ begin if TPasClassType(El).IsForward then exit(false); end + else if C=TPasRecordType then + begin + if (not WithElevatedLocal) and (El.Parent is TProcedureBody) then + exit(false); // local record counted via TPas2JSSectionScope.FElevatedLocals + end else if C.InheritsFrom(TPasProcedure) then begin if TPasProcedure(El).IsOverride then @@ -2592,7 +2599,8 @@ begin Scope:=TPasIdentifierScope(FOverloadScopes[i]); if (Scope.ClassType=TPas2JSSectionScope) and (i=0) and not (Scopes[i] is TPas2JSSectionScope) do dec(i); - if i<0 then - RaiseNotYetImplemented(20180420131358,El); - SectionScope:=TPas2JSSectionScope(Scopes[i]); - SectionScope.AddElevatedLocal(El.Name,El); + AddElevatedLocal(El); end; end else if ParentC=TImplementationSection then @@ -3846,6 +3863,19 @@ begin AddExternalName(LeftStr(aName,p-1),El); end; +procedure TPas2JSResolver.AddElevatedLocal(El: TPasElement); +var + i: Integer; + SectionScope: TPas2JSSectionScope; +begin + i:=ScopeCount-1; + while (i>=0) and not (Scopes[i] is TPas2JSSectionScope) do dec(i); + if i<0 then + RaiseNotYetImplemented(20180420131358,El); + SectionScope:=TPas2JSSectionScope(Scopes[i]); + SectionScope.AddElevatedLocal(El.Name,El); +end; + procedure TPas2JSResolver.ClearElementData; var Data, Next: TPas2JsElementData; @@ -7086,7 +7116,7 @@ var begin if PosEl=nil then PosEl:=El; CurName:=TransformVariableName(El,Name,false,AContext); - if not (El.Parent is TProcedureBody) then + if AContext.IsGlobal then begin ParentName:=AContext.GetLocalName(El.Parent); if ParentName='' then @@ -15260,20 +15290,33 @@ begin end; procedure TPasToJSConverter.CreateRTTIAnonymous(El: TPasType; - AContext: TConvertContext; var First, Last: TJSStatementList); + AContext: TConvertContext); // if El has any anonymous types, create the RTTI var C: TClass; JS: TJSElement; + GlobalCtx: TFunctionContext; + Src: TJSSourceElements; begin if El.Name<>'' then RaiseNotSupported(El,AContext,20170905162324,'inconsistency'); + GlobalCtx:=AContext.GetGlobalFunc; + if GlobalCtx=nil then + RaiseNotSupported(El,AContext,20181229130835); + if not (GlobalCtx.JSElement is TJSSourceElements) then + begin + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.CreateRTTIAnonymous GlobalCtx=',GetObjName(GlobalCtx),' JSElement=',GetObjName(GlobalCtx.JSElement)); + {$ENDIF} + RaiseNotSupported(El,AContext,20181229130926); + end; + Src:=TJSSourceElements(GlobalCtx.JSElement); C:=El.ClassType; if C=TPasArrayType then begin JS:=ConvertArrayType(TPasArrayType(El),AContext); - AddToStatementList(First,Last,JS,El); + AddToSourceElements(Src,JS); end; end; @@ -19219,7 +19262,7 @@ Var AssignSt: TJSSimpleAssignStatement; Obj: TJSObjectLiteral; ObjLit: TJSObjectLiteralElement; - ConstContext: TFunctionContext; + GlobalCtx: TFunctionContext; C: TJSElement; V: TJSVariableStatement; Src: TJSSourceElements; @@ -19234,15 +19277,15 @@ begin if not AContext.IsGlobal then begin // local const are stored in interface/implementation - ConstContext:=AContext.GetGlobalFunc; - if not (ConstContext.JSElement is TJSSourceElements) then + GlobalCtx:=AContext.GetGlobalFunc; + if not (GlobalCtx.JSElement is TJSSourceElements) then begin {$IFDEF VerbosePas2JS} - writeln('TPasToJSConverter.CreateConstDecl ConstContext=',GetObjName(ConstContext),' JSElement=',GetObjName(ConstContext.JSElement)); + writeln('TPasToJSConverter.CreateConstDecl GlobalCtx=',GetObjName(GlobalCtx),' JSElement=',GetObjName(GlobalCtx.JSElement)); {$ENDIF} RaiseNotSupported(El,AContext,20170220153216); end; - Src:=TJSSourceElements(ConstContext.JSElement); + Src:=TJSSourceElements(GlobalCtx.JSElement); C:=ConvertVariable(El,AContext); if C=nil then RaiseInconsistency(20180501114422,El); @@ -19571,7 +19614,7 @@ const RetSt.Expr:=CreateLiteralBoolean(El,true); end; - procedure AddRTTIFields(Args: TJSArguments; var First, Last: TJSStatementList); + procedure AddRTTIFields(Args: TJSArguments); var i: Integer; PasVar: TPasVariable; @@ -19583,7 +19626,7 @@ const if not IsElementUsed(PasVar) then continue; VarType:=PasVar.VarType; if VarType.Name='' then - CreateRTTIAnonymous(VarType,AContext,First,Last); + CreateRTTIAnonymous(VarType,AContext); // add quoted "fieldname" Args.AddElement(CreateLiteralString(PasVar,TransformVariableName(PasVar,AContext))); // add typeinfo ref @@ -19595,40 +19638,54 @@ var AssignSt: TJSSimpleAssignStatement; FDS: TJSFunctionDeclarationStatement; FD: TJSFuncDef; - BodyFirst, BodyLast, ListFirst, ListLast: TJSStatementList; + BodyFirst, BodyLast, ListFirst: TJSStatementList; FuncContext: TFunctionContext; + GlobalCtx: TConvertContext; ObjLit: TJSObjectLiteral; IfSt: TJSIfStatement; Call, Call2: TJSCallExpression; ok: Boolean; + Src: TJSSourceElements; + Proc: TPasProcedure; + ProcScope: TPas2JSProcedureScope; begin + if El.Name='' then + RaiseNotSupported(El,AContext,20181229133138,'anonymous record'); Result:=nil; FuncContext:=nil; ListFirst:=nil; - ListLast:=nil; + Src:=nil; ok:=false; try FDS:=CreateFunctionSt(El); FD:=FDS.AFunction; + // records are stored in interface/implementation + GlobalCtx:=AContext; if El.Parent is TProcedureBody then begin - // ToDo: elevate to non local scope - // add 'function TypeName(){}' - Result:=FDS; - FD.Name:=TJSString(TransformVariableName(El,AContext)); - end - else - begin - // add 'this.TypeName = function(){}' - AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); - Result:=AssignSt; - AssignSt.LHS:=CreateSubDeclNameExpr(El,AContext); - AssignSt.Expr:=FDS; + GlobalCtx:=AContext.GetGlobalFunc; + if not (GlobalCtx.JSElement is TJSSourceElements) then + begin + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.ConvertRecordType GlobalCtx=',GetObjName(GlobalCtx),' JSElement=',GetObjName(GlobalCtx.JSElement)); + {$ENDIF} + RaiseNotSupported(El,AContext,20181229142440); + end; + Src:=TJSSourceElements(GlobalCtx.JSElement); end; + // add 'this.TypeName = function(){}' + AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); + AssignSt.LHS:=CreateSubDeclNameExpr(El,GlobalCtx); + AssignSt.Expr:=FDS; + if Src<>nil then + AddToSourceElements(Src,AssignSt) + else + Result:=AssignSt; + // add param s FD.Params.Add(SrcParamName); // create function body - FuncContext:=TFunctionContext.Create(El,FD.Body,AContext); + FuncContext:=TFunctionContext.Create(El,FD.Body,GlobalCtx); FuncContext.ThisPas:=El; FuncContext.IsGlobal:=true; BodyFirst:=nil; @@ -19650,16 +19707,14 @@ begin if FD.Body.A=nil then FD.Body.A:=BodyFirst; - if HasTypeInfo(El,AContext) then + if HasTypeInfo(El,GlobalCtx) then begin // add $rtti as second statement - if not (AContext is TFunctionContext) then - RaiseNotSupported(El,AContext,20170412120012); + if not (GlobalCtx is TFunctionContext) then + RaiseNotSupported(El,GlobalCtx,20170412120012); - AddToStatementList(ListFirst,ListLast,Result,El); - Result:=nil; // module.$rtti.$Record("typename",{}); - Call:=CreateRTTINewType(El,GetBIName(pbifnRTTINewRecord),false,AContext,ObjLit); + Call:=CreateRTTINewType(El,GetBIName(pbifnRTTINewRecord),false,GlobalCtx,ObjLit); if ObjLit=nil then RaiseInconsistency(20170412124804,El); if El.Members.Count>0 then @@ -19671,19 +19726,37 @@ begin Call2.Expr:=CreateDotExpression(El,Call, CreatePrimitiveDotExpr(GetBIName(pbifnRTTIAddFields),El)); Call:=Call2; - AddRTTIFields(Call.Args,ListFirst,ListLast); + AddRTTIFields(Call.Args); + end; + if Src<>nil then + // add Call to global statements + AddToSourceElements(Src,Call) + else + begin + // combine Result and Call into a statement list + ListFirst:=TJSStatementList(CreateElement(TJSStatementList,El)); + ListFirst.A:=Result; + ListFirst.B:=Call; + Result:=ListFirst; + ListFirst:=nil; + end; + + if (GlobalCtx<>AContext) and (coStoreImplJS in Options) + and (AContext.Resolver<>nil) then + begin + // store precompiled record type in proc + Proc:=AContext.Resolver.GetTopLvlProc(AContext.PasElement); + if Proc<>nil then + begin + ProcScope:=TPas2JSProcedureScope(Proc.CustomData); + ProcScope.AddGlobalJS(CreatePrecompiledJS(AssignSt)); + end; end; - AddToStatementList(ListFirst,ListLast,Call,El); - Result:=ListFirst; - ListFirst:=nil; - ListLast:=nil; end; ok:=true; finally FuncContext.Free; - if ListFirst<>nil then - FreeAndNil(ListFirst) - else if not ok then + if not ok then FreeAndNil(Result); end; end; diff --git a/packages/pastojs/tests/tcfiler.pas b/packages/pastojs/tests/tcfiler.pas index 14c91cac73..f5791685ee 100644 --- a/packages/pastojs/tests/tcfiler.pas +++ b/packages/pastojs/tests/tcfiler.pas @@ -90,6 +90,7 @@ type procedure CheckRestoredPrimitiveExpr(const Path: string; Orig, Rest: TPrimitiveExpr); virtual; procedure CheckRestoredBoolConstExpr(const Path: string; Orig, Rest: TBoolConstExpr); virtual; procedure CheckRestoredParamsExpr(const Path: string; Orig, Rest: TParamsExpr); virtual; + procedure CheckRestoredProcedureExpr(const Path: string; Orig, Rest: TProcedureExpr); virtual; procedure CheckRestoredRecordValues(const Path: string; Orig, Rest: TRecordValues); virtual; procedure CheckRestoredPasExprArray(const Path: string; Orig, Rest: TPasExprArray); virtual; procedure CheckRestoredArrayValues(const Path: string; Orig, Rest: TArrayValues); virtual; @@ -140,6 +141,7 @@ type procedure TestPC_Set; procedure TestPC_SetOfAnonymousEnumType; procedure TestPC_Record; + procedure TestPC_Record_Local; procedure TestPC_JSValue; procedure TestPC_Array; procedure TestPC_ArrayOfAnonymous; @@ -149,6 +151,7 @@ type procedure TestPC_Proc_UTF8; procedure TestPC_Proc_Arg; procedure TestPC_ProcType; + procedure TestPC_Proc_Anonymous; procedure TestPC_Class; procedure TestPC_ClassForward; procedure TestPC_ClassConstructor; @@ -1078,6 +1081,8 @@ begin CheckRestoredPasExpr(Path,TPasExpr(Orig),TPasExpr(Rest)) else if C=TParamsExpr then CheckRestoredParamsExpr(Path,TParamsExpr(Orig),TParamsExpr(Rest)) + else if C=TProcedureExpr then + CheckRestoredProcedureExpr(Path,TProcedureExpr(Orig),TProcedureExpr(Rest)) else if C=TRecordValues then CheckRestoredRecordValues(Path,TRecordValues(Orig),TRecordValues(Rest)) else if C=TArrayValues then @@ -1259,6 +1264,13 @@ begin CheckRestoredPasExpr(Path,Orig,Rest); end; +procedure TCustomTestPrecompile.CheckRestoredProcedureExpr(const Path: string; + Orig, Rest: TProcedureExpr); +begin + CheckRestoredProcedure(Path+'$Ano',Orig.Proc,Rest.Proc); + CheckRestoredPasExpr(Path,Orig,Rest); +end; + procedure TCustomTestPrecompile.CheckRestoredRecordValues(const Path: string; Orig, Rest: TRecordValues); var @@ -1691,6 +1703,28 @@ begin WriteReadUnit; end; +procedure TTestPrecompile.TestPC_Record_Local; +begin + StartUnit(false); + Add([ + 'interface', + 'procedure DoIt;', + 'implementation', + 'procedure DoIt;', + 'type', + ' TRec = record', + ' i: longint;', + ' s: string;', + ' end;', + ' P = ^TRec;', + ' TArrOfRec = array of TRec;', + 'var', + ' r: TRec;', + 'begin', + 'end;']); + WriteReadUnit; +end; + procedure TTestPrecompile.TestPC_JSValue; begin StartUnit(false); @@ -1866,6 +1900,32 @@ begin WriteReadUnit; end; +procedure TTestPrecompile.TestPC_Proc_Anonymous; +begin + StartUnit(false); + Add([ + 'interface', + 'type', + ' TFunc = reference to function(w: word): word;', + ' function GetIt(f: TFunc): longint;', + 'implementation', + 'var k: byte;', + 'function GetIt(f: TFunc): longint;', + 'begin', + ' f:=function(w: word): word', + ' var j: byte;', + ' function GetMul(a,b: longint): longint; ', + ' begin', + ' Result:=a*b;', + ' end;', + ' begin', + ' Result:=j*GetMul(1,2)*k;', + ' end;', + 'end;', + '']); + WriteReadUnit; +end; + procedure TTestPrecompile.TestPC_Class; begin StartUnit(false); diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index f020b39948..da313f3877 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -431,7 +431,7 @@ type Procedure TestRecord_Empty; Procedure TestRecord_Var; Procedure TestRecord_VarExternal; - Procedure TestWithRecordDo; + Procedure TestRecord_WithDo; Procedure TestRecord_Assign; Procedure TestRecord_PassAsArgClone; Procedure TestRecord_AsParams; @@ -445,6 +445,12 @@ type Procedure TestRecord_Const; Procedure TestRecord_TypecastFail; Procedure TestRecord_InFunction; + // Test name clash const and local record + // Test RTTI of local record + // Test pcu local record, name clash and rtti + + // advanced record + // ToDo: TestRecord_InFunction; // classes Procedure TestClass_TObjectDefaultConstructor; @@ -9127,7 +9133,7 @@ begin ])); end; -procedure TTestModule.TestWithRecordDo; +procedure TTestModule.TestRecord_WithDo; begin StartProgram(false); Add('type'); @@ -9760,6 +9766,7 @@ procedure TTestModule.TestRecord_InFunction; begin StartProgram(false); Add([ + 'var TPoint: longint = 3;', 'procedure DoIt;', 'type', ' TPoint = record x,y: longint; end;', @@ -9774,22 +9781,23 @@ begin ConvertProgram; CheckSource('TestRecord_InFunction', LinesToStr([ // statements - 'this.DoIt = function () {', - ' function TPoint(s) {', - ' if (s) {', - ' this.x = s.x;', - ' this.y = s.y;', - ' } else {', - ' this.x = 0;', - ' this.y = 0;', - ' };', - ' this.$equal = function (b) {', - ' return (this.x === b.x) && (this.y === b.y);', - ' };', + 'this.TPoint = 3;', + 'this.TPoint$1 = function (s) {', + ' if (s) {', + ' this.x = s.x;', + ' this.y = s.y;', + ' } else {', + ' this.x = 0;', + ' this.y = 0;', ' };', - ' var r = new TPoint();', + ' this.$equal = function (b) {', + ' return (this.x === b.x) && (this.y === b.y);', + ' };', + '};', + 'this.DoIt = function () {', + ' var r = new TPoint$1();', ' var p = [];', - ' p = rtl.arraySetLength(p, TPoint, 2);', + ' p = rtl.arraySetLength(p, TPoint$1, 2);', '};', '']), LinesToStr([ // $mod.$main @@ -21857,6 +21865,9 @@ begin ConvertProgram; CheckSource('TestRTTI_Record', LinesToStr([ // statements + '$mod.$rtti.$DynArray("TFloatRec.d$a", {', + ' eltype: rtl.char', + '});', 'this.TFloatRec = function (s) {', ' if (s) {', ' this.d = s.d;', @@ -21867,9 +21878,6 @@ begin ' return this.d === b.d;', ' };', '};', - '$mod.$rtti.$DynArray("TFloatRec.d$a", {', - ' eltype: rtl.char', - '});', '$mod.$rtti.$Record("TFloatRec", {}).addFields("d", $mod.$rtti["TFloatRec.d$a"]);', 'this.p = null;', 'this.r = new $mod.TFloatRec();', @@ -21898,19 +21906,19 @@ begin ConvertProgram; CheckSource('TestRTTI_LocalTypes', LinesToStr([ // statements - 'this.DoIt = function () {', - ' function TPoint(s) {', - ' if (s) {', - ' this.x = s.x;', - ' this.y = s.y;', - ' } else {', - ' this.x = 0;', - ' this.y = 0;', - ' };', - ' this.$equal = function (b) {', - ' return (this.x === b.x) && (this.y === b.y);', - ' };', + 'this.TPoint = function(s) {', + ' if (s) {', + ' this.x = s.x;', + ' this.y = s.y;', + ' } else {', + ' this.x = 0;', + ' this.y = 0;', ' };', + ' this.$equal = function (b) {', + ' return (this.x === b.x) && (this.y === b.y);', + ' };', + '};', + 'this.DoIt = function () {', '};', '']), LinesToStr([ // $mod.$main