From fc4c48a11c21a159bd45397d01feead8a8bcdbb2 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Fri, 4 Sep 2020 17:17:46 +0000 Subject: [PATCH] pastojs: override scope class array and proctype git-svn-id: trunk@46768 - --- packages/pastojs/src/fppas2js.pp | 92 ++++++++++++++++++- packages/pastojs/tests/tcgenerics.pas | 122 ++++++++++++++++++++++++++ 2 files changed, 210 insertions(+), 4 deletions(-) diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index b2ceb5b773..c34a4be79e 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -1166,6 +1166,7 @@ type TPas2JSClassScope = class(TPasClassScope) public + LongName: string; NewInstanceFunction: TPasClassFunction; GUID: string; ElevatedLocals: TPas2jsElevatedLocals; @@ -1183,6 +1184,7 @@ type TPas2JSRecordScope = class(TPasRecordScope) public + LongName: string; MemberOverloadsRenamed: boolean; end; @@ -1191,6 +1193,7 @@ type TPas2JSProcedureScope = class(TPasProcedureScope) public OverloadName: string; + LongName: string; ResultVarName: string; // valid in implementation ProcScope, empty means use ResolverResultVar BodyOverloadsRenamed: boolean; BodyJS: string; // Option coStoreProcJS: stored in ImplScope @@ -1200,6 +1203,20 @@ type destructor Destroy; override; end; + { TPas2JSArrayScope } + + TPas2JSArrayScope = Class(TPasArrayScope) + public + LongName: string; + end; + + { TPas2JSProcTypeScope } + + TPas2JSProcTypeScope = Class(TPasProcTypeScope) + public + LongName: string; + end; + { TPas2JSWithExprScope } TPas2JSWithExprScope = class(TPasWithExprScope) @@ -1495,9 +1512,12 @@ type function GenerateGUID(El: TPasClassType): string; virtual; protected // generic/specialize + procedure SpecializeGenericIntf(SpecializedItem: TPRSpecializedItem); + override; procedure SpecializeGenericImpl(SpecializedItem: TPRSpecializedItem); override; function SpecializeNeedsDelay(SpecializedItem: TPRSpecializedItem): TPasElement; virtual; + function CreateLongName(SpecializedItem: TPRSpecializedItem): string; virtual; protected const cJSValueConversion = 2*cTypeConversion; @@ -4955,6 +4975,49 @@ begin Result:=Result+'}'; end; +procedure TPas2JSResolver.SpecializeGenericIntf( + SpecializedItem: TPRSpecializedItem); +{$IFDEF EnableLongNames} +var + El: TPasElement; + C: TClass; + RecScope: TPas2JSRecordScope; + ClassScope: TPas2JSClassScope; + ArrayScope: TPas2JSArrayScope; + ProcTypeScope: TPas2JSProcTypeScope; + LongName: String; +{$ENDIF} +begin + {$IFDEF EnableLongNames} + El:=SpecializedItem.SpecializedEl; + C:=El.ClassType; + LongName:=CreateLongName(SpecializedItem); + if C=TPasRecordType then + begin + RecScope:=TPas2JSRecordScope(El.CustomData); + RecScope.LongName:=LongName; + end + else if C=TPasClassType then + begin + ClassScope:=TPas2JSClassScope(El.CustomData); + ClassScope.LongName:=LongName; + end + else if C=TPasArrayType then + begin + ArrayScope:=TPas2JSArrayScope(El.CustomData); + ArrayScope.LongName:=LongName; + end + else if (C=TPasProcedureType) or (C=TPasFunctionType) then + begin + ProcTypeScope:=TPas2JSProcTypeScope(El.CustomData); + ProcTypeScope.LongName:=LongName; + end + else + RaiseNotYetImplemented(20200904132908,El); + {$ENDIF} + inherited SpecializeGenericIntf(SpecializedItem); +end; + procedure TPas2JSResolver.SpecializeGenericImpl( SpecializedItem: TPRSpecializedItem); var @@ -5037,6 +5100,24 @@ begin end; end; +function TPas2JSResolver.CreateLongName(SpecializedItem: TPRSpecializedItem + ): string; +var + GenEl: TPasElement; + i: Integer; + Param: TPasType; +begin + GenEl:=SpecializedItem.GenericEl; + Result:=GenEl.Name+'<'; + for i:=0 to length(SpecializedItem.Params)-1 do + begin + Param:=ResolveAliasType(SpecializedItem.Params[i],false); + // ToDo move to resolver + if Param=nil then ; + end; + Result:=Result+'>'; +end; + function TPas2JSResolver.AddJSBaseType(const aName: string; Typ: TPas2jsBaseType ): TResElDataPas2JSBaseType; var @@ -5827,6 +5908,8 @@ begin ScopeClass_Module:=TPas2JSModuleScope; ScopeClass_Procedure:=TPas2JSProcedureScope; ScopeClass_Record:=TPas2JSRecordScope; + ScopeClass_Array:=TPas2JSArrayScope; + ScopeClass_ProcType:=TPas2JSProcTypeScope; ScopeClass_Section:=TPas2JSSectionScope; ScopeClass_WithExpr:=TPas2JSWithExprScope; for bt in [pbtJSValue] do @@ -15400,7 +15483,7 @@ var Obj: TJSObjectLiteral; Prop: TJSObjectLiteralElement; aResolver: TPas2JSResolver; - Scope: TPasProcTypeScope; + Scope: TPas2JSProcTypeScope; SpecializeNeedsDelay: Boolean; FuncSt: TJSFunctionDeclarationStatement; AssignSt: TJSSimpleAssignStatement; @@ -15420,7 +15503,7 @@ begin if El.Parent is TProcedureBody then RaiseNotSupported(El,AContext,20181231112029); - Scope:=El.CustomData as TPasProcTypeScope; + Scope:=El.CustomData as TPas2JSProcTypeScope; SpecializeNeedsDelay:=(Scope<>nil) and (aResolver.SpecializeNeedsDelay(Scope.SpecializedFromItem)<>nil); @@ -15532,7 +15615,7 @@ var var aResolver: TPas2JSResolver; - Scope: TPasArrayScope; + Scope: TPas2JSArrayScope; SpecializeNeedsDelay: Boolean; AssignSt: TJSSimpleAssignStatement; CallName, ArrName: String; @@ -15566,7 +15649,7 @@ begin writeln('TPasToJSConverter.ConvertArrayType ',GetObjName(El)); {$ENDIF} - Scope:=El.CustomData as TPasArrayScope; + Scope:=El.CustomData as TPas2JSArrayScope; SpecializeNeedsDelay:=(Scope<>nil) and (aResolver.SpecializeNeedsDelay(Scope.SpecializedFromItem)<>nil); @@ -16750,6 +16833,7 @@ begin if (C=TPasRecordType) or (C=TPasClassType) then begin + if (C=TPasClassType) and TPasClassType(El).IsExternal then exit; // pas.unitname.recordtype.$initSpec(); Path:=CreateReferencePath(El,AContext,rpkPathAndName)+'.'+GetBIName(pbifnClassInitSpecialize); Call:=CreateCallExpression(El); diff --git a/packages/pastojs/tests/tcgenerics.pas b/packages/pastojs/tests/tcgenerics.pas index b6a08e81e3..6186b5ecba 100644 --- a/packages/pastojs/tests/tcgenerics.pas +++ b/packages/pastojs/tests/tcgenerics.pas @@ -47,6 +47,7 @@ type procedure TestGen_ExtClass_GenJSValueAssign; procedure TestGen_ExtClass_AliasMemberType; Procedure TestGen_ExtClass_RTTI; + procedure TestGen_ExtClass_UnitImplRec; // class interfaces procedure TestGen_ClassInterface_Corba; @@ -79,6 +80,8 @@ type procedure TestGen_ArrayOfUnitImplRec; // generic procedure type + procedure TestGen_ProcType_ProcLocal; + procedure TestGen_ProcType_ProcLocal_RTTI; procedure TestGen_ProcType_ParamUnitImpl; end; @@ -1324,6 +1327,70 @@ begin ''])); end; +procedure TTestGenerics.TestGen_ExtClass_UnitImplRec; +begin + WithTypeInfo:=true; + StartProgram(true,[supTObject]); + AddModuleWithIntfImplSrc('UnitA.pas', + LinesToStr([ + '{$mode objfpc}', + '{$modeswitch externalclass}', + 'type', + ' generic TAnt = class external name ''SET''', + ' x: T;', + ' end;', + '']), + LinesToStr([ + 'type', + ' TBird = record', + ' b: word;', + ' end;', + 'var', + ' f: specialize TAnt;', + 'begin', + ' f.x.b:=f.x.b+10;', + ''])); + Add([ + 'uses UnitA;', + 'begin', + 'end.']); + ConvertProgram; + CheckUnit('UnitA.pas', + LinesToStr([ // statements + 'rtl.module("UnitA", ["system"], function () {', + ' var $mod = this;', + ' var $impl = $mod.$impl;', + ' $mod.$rtti.$ExtClass("TAnt$G1", {', + ' jsclass: "SET"', + ' });', + ' $mod.$init = function () {', + ' $impl.f.x.b = $impl.f.x.b + 10;', + ' };', + '}, null, function () {', + ' var $mod = this;', + ' var $impl = $mod.$impl;', + ' rtl.recNewT($impl, "TBird", function () {', + ' this.b = 0;', + ' this.$eq = function (b) {', + ' return this.b === b.b;', + ' };', + ' this.$assign = function (s) {', + ' this.b = s.b;', + ' return this;', + ' };', + ' var $r = $mod.$rtti.$Record("TBird", {});', + ' $r.addField("b", rtl.word);', + ' });', + ' $impl.f = null;', + '});'])); + CheckSource('TestGen_Class_ClassVarRecord_UnitImpl', + LinesToStr([ // statements + //'pas.UnitA.TAnt$G1.$initSpec();', + '']), + LinesToStr([ // $mod.$main + ''])); +end; + procedure TTestGenerics.TestGen_ClassInterface_Corba; begin StartProgram(false); @@ -2044,6 +2111,61 @@ begin ''])); end; +procedure TTestGenerics.TestGen_ProcType_ProcLocal; +begin + StartProgram(false); + Add([ + 'procedure Fly(w: word);', + 'begin', + 'end;', + 'procedure Run(w: word);', + 'type generic TProc = procedure(a: T);', + 'var p: specialize TProc;', + 'begin', + ' p:=@Fly;', + ' p(w);', + 'end;', + 'begin', + 'end.']); + ConvertProgram; + CheckSource('TestGen_ProcType_ProcLocal', + LinesToStr([ // statements + 'this.Fly = function (w) {', + '};', + 'this.Run = function (w) {', + ' var p = null;', + ' p = $mod.Fly;', + ' p(w);', + '};', + '']), + LinesToStr([ // $mod.$main + ''])); +end; + +procedure TTestGenerics.TestGen_ProcType_ProcLocal_RTTI; +begin + WithTypeInfo:=true; + StartProgram(false); + Add([ + 'procedure Fly(w: word);', + 'begin', + 'end;', + 'procedure Run(w: word);', + 'type generic TProc = procedure(a: T);', + 'var', + ' p: specialize TProc;', + ' t: Pointer;', + 'begin', + ' p:=@Fly;', + ' p(w);', + ' t:=typeinfo(p);', + 'end;', + 'begin', + 'end.']); + SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished); + ConvertProgram; +end; + procedure TTestGenerics.TestGen_ProcType_ParamUnitImpl; begin WithTypeInfo:=true;