pastojs: filer: local specialize type

git-svn-id: trunk@47134 -

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -1009,6 +1009,8 @@ procedure TPasAnalyzer.MarkImplScopeRef(El, RefEl: TPasElement;
 
     if (RefEl.Name='') and not (RefEl is TInterfaceSection) then
       exit; // reference to anonymous type -> not needed
+    if RefEl=ElImplScope.Element then
+      exit;
     if ElImplScope is TPasProcedureScope then
       TPasProcedureScope(ElImplScope).AddReference(RefEl,Access)
     else if ElImplScope is TPasInitialFinalizationScope then

packages/pastojs/src/pas2jsfiler.pp

@@ -942,6 +942,14 @@ type
     AddRef: TPCUAddRef;
   end;
 
+  { TPCUReaderPendingElScopeRef }
+
+  TPCUReaderPendingElScopeRef = class(TPCUFilerPendingElRef)
+  public
+    References: TPasScopeReferences;
+    Access: TPSRefAccess;
+  end;
+
   { TPCUReaderPendingIdentifierScope }
 
   TPCUReaderPendingIdentifierScope = class
@@ -970,7 +978,7 @@ type
     GenericEl: TPasGenericType;
     Id: integer;
     Params: TFPList; // list of PCUReaderPendingSpecializedParams
-    RefEl: TPasElement; // a TInlineSpecializeExpr or TPasSpecializeType
+    RefEl: TPasElement; // a TInlineSpecializeExpr, TPasSpecializeType, TPasProcedure or TInitializationSection
     SpecName: string;
     Prev, Next: TPCUReaderPendingSpecialized;
     destructor Destroy; override;
@@ -1024,7 +1032,7 @@ type
     function CreateSpecializedElement(PendSpec: TPCUReaderPendingSpecialized): boolean; // false=param missing
     procedure DeletePendingSpecialize(PendSpec: TPCUReaderPendingSpecialized);
     procedure PromiseSpecialize(SpecId: integer; El: TPasElement; const SpecName: string); virtual;
-    procedure ResolveSpecializedElements;
+    procedure ResolveSpecializedElements(Complete: boolean);
   protected
     // json
     procedure RaiseMsg(Id: int64; const Msg: string = ''); overload; override;
@@ -1047,8 +1055,11 @@ type
       AddRef: TPCUAddRef; ErrorEl: TPasElement); virtual;
     procedure PromiseSetElArrReference(Id: integer; Arr: TPasElementArray; Index: integer;
       AddRef: TPCUAddRef; ErrorEl: TPasElement); virtual;
+    procedure PromiseSetScopeReference(Id: integer; References: TPasScopeReferences;
+      Access: TPSRefAccess; ErrorEl: TPasElement); virtual;
     procedure ResolvePendingIdentifierScopes; virtual;
-    procedure ResolvePending; virtual;
+    procedure ResolvePending(Complete: boolean); virtual;
+    function GetReferrerEl(PendingElRef: TPCUFilerPendingElRef): TPasElement;
     procedure ReadBuiltInSymbols(Obj: TJSONObject; ErrorEl: TPasElement); virtual;
     // module
     procedure ReadHeaderMagic(Obj: TJSONObject); virtual;
@@ -3309,7 +3320,8 @@ procedure TPCUWriter.WriteExtRefSignature(Ref: TPCUFilerElementRef;
         end;
       if Index<0 then
         RaiseMsg(20180309184111,Member);
-      Obj.Add('MId',Index);
+      if Index>0 then
+        Obj.Add('MId',Index);
       end;
   end;
 
@@ -5424,11 +5436,12 @@ function TPCUReader.CreateSpecializedElement(
   PendSpec: TPCUReaderPendingSpecialized): boolean;
 var
   RefParams, ElParams: TFPList;
-  i: Integer;
+  i, Id: Integer;
   SpecEl: TPasElement;
   Param: TPCUReaderPendingSpecializedParam;
   Ref: TPCUFilerElementRef;
   Obj: TJSONObject;
+  GenericEl: TPasGenericType;
 begin
   Result:=false;
   if PendSpec.RefEl=nil then
@@ -5452,7 +5465,10 @@ begin
     if Param.Element<>nil then continue;
     Ref:=GetElReference(Param.Id,PendSpec.RefEl);
     if Ref=nil then
+      begin
+      //writeln('TPCUReader.CreateSpecializedElement SpecName=',PendSpec.SpecName,' Id=',PendSpec.Id,' WAITING for param ',i,': ',Param.Id);
       exit(false);
+      end;
     Param.Element:=Ref.Element;
     end;
   // all RefParams resolved -> specialize
@@ -5460,8 +5476,11 @@ begin
   try
     for i:=0 to RefParams.Count-1 do
       ElParams.Add(TPCUReaderPendingSpecializedParam(RefParams[i]).Element);
-    SpecEl:=Resolver.GetSpecializedEl(Resolver.RootElement,PendSpec.GenericEl,ElParams);
+    Id:=PendSpec.Id;
+    GenericEl:=PendSpec.GenericEl;
+    SpecEl:=Resolver.GetSpecializedEl(Resolver.RootElement,GenericEl,ElParams);
     DeletePendingSpecialize(PendSpec);
+    Ref:=AddElReference(Id,PendSpec.RefEl,SpecEl);
   finally
     ElParams.Free;
   end;
@@ -5503,10 +5522,11 @@ begin
     PendSpec.RefEl:=El;
 end;
 
-procedure TPCUReader.ResolveSpecializedElements;
+procedure TPCUReader.ResolveSpecializedElements(Complete: boolean);
 var
   PendSpec, NextPendSpec, UnresolvedSpec: TPCUReaderPendingSpecialized;
   Changed: Boolean;
+  Ref: TPCUFilerElementRef;
 begin
   repeat
     UnresolvedSpec:=nil;
@@ -5515,6 +5535,12 @@ begin
     while PendSpec<>nil do
       begin
       NextPendSpec:=PendSpec.Next;
+      if PendSpec.RefEl=nil then
+        begin
+        Ref:=GetElReference(PendSpec.Id,PendSpec.GenericEl);
+        if Ref<>nil then
+          PendSpec.RefEl:=GetReferrerEl(Ref.Pending);
+        end;
       if PendSpec.RefEl<>nil then
         begin
         if CreateSpecializedElement(PendSpec) then
@@ -5525,6 +5551,8 @@ begin
       PendSpec:=NextPendSpec;
       end;
   until not Changed;
+  if Complete then
+    UnresolvedSpec:=FPendingSpecialize;
   if UnresolvedSpec<>nil then
     // a pending specialize cannot resolve its params
     RaiseMsg(20200531101924,UnresolvedSpec.GenericEl,UnresolvedSpec.SpecName+' Id='+IntToStr(UnresolvedSpec.Id)+' RefEl='+GetObjPath(UnresolvedSpec.RefEl));
@@ -5717,6 +5745,7 @@ var
   PendingElArrRef: TPCUReaderPendingElArrRef;
   {$IF defined(VerbosePCUFiler) or defined(memcheck)}
   Node: TAVLTreeNode;
+  PendingElScopeRef: TPCUReaderPendingElScopeRef;
   {$ENDIF}
 begin
   if Id<=0 then
@@ -5791,6 +5820,11 @@ begin
           if PendingElArrRef.AddRef{$IFDEF CheckPasTreeRefCount}<>''{$ENDIF} then
             Ref.Element.AddRef{$IFDEF CheckPasTreeRefCount}(PendingElArrRef.AddRef){$ENDIF};
           end
+        else if RefItem is TPCUReaderPendingElScopeRef then
+          begin
+          PendingElScopeRef:=TPCUReaderPendingElScopeRef(RefItem);
+          PendingElScopeRef.References.Add(Ref.Element,PendingElScopeRef.Access);
+          end
         else
           RaiseMsg(20180207153056,ErrorEl,RefItem.ClassName);
         Ref.Pending:=RefItem.Next;
@@ -5879,6 +5913,29 @@ begin
     end;
 end;
 
+procedure TPCUReader.PromiseSetScopeReference(Id: integer;
+  References: TPasScopeReferences; Access: TPSRefAccess; ErrorEl: TPasElement);
+var
+  Ref: TPCUFilerElementRef;
+  PendingItem: TPCUReaderPendingElScopeRef;
+begin
+  Ref:=AddElReference(Id,ErrorEl,nil);
+  if Ref.Element<>nil then
+    begin
+    // element was already created -> add reference immediately
+    References.Add(Ref.Element,Access);
+    end
+  else
+    begin
+    // element was not yet created -> store
+    PendingItem:=TPCUReaderPendingElScopeRef.Create;
+    PendingItem.References:=References;
+    PendingItem.Access:=Access;
+    PendingItem.ErrorEl:=ErrorEl;
+    Ref.AddPending(PendingItem);
+    end;
+end;
+
 procedure TPCUReader.ResolvePendingIdentifierScopes;
 var
   i: Integer;
@@ -5892,14 +5949,13 @@ begin
   FPendingIdentifierScopes.Clear;
 end;
 
-procedure TPCUReader.ResolvePending;
+procedure TPCUReader.ResolvePending(Complete: boolean);
 var
   Node: TAVLTreeNode;
   Ref: TPCUFilerElementRef;
 begin
   ResolvePendingIdentifierScopes;
-
-  ResolveSpecializedElements;
+  ResolveSpecializedElements(Complete);
 
   // check dangling references
   Node:=FElementRefs.FindLowest;
@@ -5920,6 +5976,18 @@ begin
     end;
 end;
 
+function TPCUReader.GetReferrerEl(PendingElRef: TPCUFilerPendingElRef
+  ): TPasElement;
+begin
+  while PendingElRef<>nil do
+    begin
+    Result:=PendingElRef.ErrorEl;
+    if Result<>nil then exit;
+    PendingElRef:=PendingElRef.Next;
+    end;
+  Result:=nil;
+end;
+
 procedure TPCUReader.ReadBuiltInSymbols(Obj: TJSONObject; ErrorEl: TPasElement);
 var
   Arr: TJSONArray;
@@ -6432,7 +6500,12 @@ begin
     if not ReadString(SubObj,'Name',Name,El) then
       RaiseMsg(20180309180233,El,IntToStr(i));
     if not ReadInteger(SubObj,'MId',Index,El) then
-      RaiseMsg(20180309184629,El,IntToStr(i));
+      begin
+      if SubObj.Find('MId')=nil then
+        Index:=0
+      else
+        RaiseMsg(20180309184629,El,IntToStr(i));
+      end;
     if (Index<0) or (Index>=Members.Count) then
       RaiseMsg(20180309184718,El,IntToStr(Index)+' out of bounds 0-'+IntToStr(Members.Count));
     ChildEl:=nil;
@@ -6492,6 +6565,7 @@ var
   PendSpec: TPCUReaderPendingSpecialized;
   PendParam: TPCUReaderPendingSpecializedParam;
   SpecName: string;
+  Ref: TPCUFilerElementRef;
 begin
   ErrorEl:=GenEl;
   if ParamIDs.Count=0 then
@@ -6505,6 +6579,9 @@ begin
   PendSpec.Obj:=Obj;
   PendSpec.GenericEl:=GenEl;
 
+  Ref:=AddElReference(Id,GenEl,nil);
+  Ref.Obj:=Obj;
+
   PendSpec.Params:=TFPList.Create;
   for i:=0 to ParamIDs.Count-1 do
     begin
@@ -6743,7 +6820,7 @@ begin
   Scope.Finished:=true;
   if Section is TInterfaceSection then
     begin
-    ResolvePending;
+    ResolvePending(false);
     Resolver.NotifyPendingUsedInterfaces;
     end;
 end;
@@ -7219,7 +7296,6 @@ var
   i, Id: Integer;
   Data: TJSONData;
   SubObj: TJSONObject;
-  Ref: TPCUFilerElementRef;
   s: string;
   Found: Boolean;
   Access: TPSRefAccess;
@@ -7239,12 +7315,6 @@ begin
     Data:=SubObj.Find('Id');
     if not (Data is TJSONIntegerNumber) then
       RaiseMsg(20180221171546,El,GetObjName(Data));
-    Id:=Data.AsInteger;
-    Ref:=GetElReference(Id,El);
-    if Ref=nil then
-      RaiseMsg(20180221171940,El,IntToStr(Id));
-    if Ref.Element=nil then
-      RaiseMsg(20180221171940,El,IntToStr(Id));
     if ReadString(SubObj,'Access',s,El) then
       begin
       Found:=false;
@@ -7259,7 +7329,8 @@ begin
       end
     else
       Access:=PCUDefaultPSRefAccess;
-    References.Add(Ref.Element,Access);
+    Id:=Data.AsInteger;
+    PromiseSetScopeReference(Id,References,Access,El);
     end;
 end;
 
@@ -7904,7 +7975,7 @@ begin
     aContext.ModeSwitches:=OldModeSwitches;
   end;
 
-  ResolvePending;
+  ResolvePending(true);
   Result:=true;
 end;
 

packages/pastojs/tests/tcfiler.pas

@@ -218,11 +218,9 @@ type
     procedure TestPC_GenericFunction_AnonymousProc;
     procedure TestPC_GenericClass;
     procedure TestPC_GenericMethod;
-    procedure TestPC_SpecializeClassSameUnit; // ToDo
-    // ToDo: specialize local generic type in unit interface
-    // ToDo: specialize local generic type in unit implementation
-    // ToDo: specialize local generic type in proc decl
-    // ToDo: specialize local generic type in proc body
+    procedure TestPC_SpecializeClassSameUnit;
+    procedure TestPC_Specialize_LocalTypeInUnit;
+    // ToDo: specialize local generic type via class forward
     // ToDo: inline specialize local generic type in unit interface
     // ToDo: inline specialize local generic type in unit implementation
     // ToDo: inline specialize local generic type in proc decl
@@ -691,21 +689,21 @@ begin
       SubPath:=SubPath+'?noname?';
     // search specialization with same name
     RestIndex:=0;
-    while RestIndex<Rest.Declarations.Count do
-      begin
+    repeat
+      if RestIndex=Rest.Declarations.Count then
+        Fail(SubPath+' missing in restored Declarations');
       RestDecl:=TPasElement(Rest.Declarations[RestIndex]);
       if IsSpecialization(RestDecl) and (OrigDecl.Name=RestDecl.Name) then
         break;
       inc(RestIndex);
-      end;
-    if RestIndex=Rest.Declarations.Count then
-      Fail(SubPath+' missing in restored Declarations');
-    // check
-    CheckRestoredElement(SubPath,OrigDecl,RestDecl,Flags);
+    until false;
 
-    // move restored element to original place to generate the same JS
-    if OrigIndex<Rest.Declarations.Count then
+    if (OrigIndex<Rest.Declarations.Count) and (OrigIndex<>RestIndex) then
+      // move restored element to original place to generate the same JS
       Rest.Declarations.Move(RestIndex,OrigIndex);
+
+    // check
+    CheckRestoredElement(SubPath,OrigDecl,RestDecl,Flags);
     end;
 
   AssertEquals(Path+'.Declarations.Count',Orig.Declarations.Count,Rest.Declarations.Count);
@@ -1026,12 +1024,14 @@ var
   OrigList, RestList: TFPList;
   i: Integer;
   OrigRef, RestRef: TPasScopeReference;
+  ok: Boolean;
 begin
   if Flags=[] then ;
   CheckRestoredObject(Path,Orig,Rest);
   if Orig=nil then exit;
   OrigList:=nil;
   RestList:=nil;
+  ok:=false;
   try
     OrigList:=Orig.GetList;
     RestList:=Rest.GetList;
@@ -1054,7 +1054,21 @@ begin
       RestRef:=TPasScopeReference(RestList[i]);
       Fail(Path+'['+IntToStr(i)+'] Too many in Rest: "'+RestRef.Element.Name+'"');
       end;
+    ok:=true;
   finally
+    if not ok then
+      begin
+      for i:=0 to OrigList.Count-1 do
+        begin
+        OrigRef:=TPasScopeReference(OrigList[i]);
+        writeln('TCustomTestPrecompile.CheckRestoredScopeRefs Orig[',i,']=',GetObjPath(OrigRef.Element));
+        end;
+      for i:=0 to RestList.Count-1 do
+        begin
+        RestRef:=TPasScopeReference(RestList[i]);
+        writeln('TCustomTestPrecompile.CheckRestoredScopeRefs Rest[',i,']=',GetObjPath(RestRef.Element));
+        end;
+      end;
     OrigList.Free;
     RestList.Free;
   end;
@@ -1264,7 +1278,14 @@ begin
     if RestUsed=nil then
       Fail(Path+': used in OrigAnalyzer, but not used in RestAnalyzer');
     if OrigUsed.Access<>RestUsed.Access then
-      AssertEquals(Path+'->Analyzer.Access',dbgs(OrigUsed.Access),dbgs(RestUsed.Access));
+      begin
+      if (OrigUsed.Access in [paiaReadWrite,paiaWriteRead])
+          and (RestUsed.Access in [paiaReadWrite,paiaWriteRead])
+          and not (Orig.Parent is TProcedureBody) then
+        // readwrite or writeread is irrelevant for globals
+      else
+        AssertEquals(Path+'->Analyzer.Access',dbgs(OrigUsed.Access),dbgs(RestUsed.Access));
+      end;
     end
   else if RestAnalyzer.IsUsed(Rest) then
     begin
@@ -3204,7 +3225,46 @@ begin
   'implementation',
   'begin',
   '  b.a:=1.3;',
-  'end.',
+  '']);
+  WriteReadUnit;
+end;
+
+procedure TTestPrecompile.TestPC_Specialize_LocalTypeInUnit;
+begin
+  StartUnit(false);
+  Add([
+  '{$mode delphi}',
+  'interface',
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TBird<T> = class',
+  '    a: T;',
+  '  end;',
+  //'  TDoubleBird = TBIrd<double>;',
+  //'var',
+  //'  db: TDoubleBird;',
+  'procedure Fly;',
+  'implementation',
+  'type',
+  '  TWordBird = TBird<word>;',
+  'procedure Run;',
+  //'type TShortIntBird = TBird<shortint>;',
+  'var',
+  //'  shb: TShortIntBird;',
+  '  wb: TWordBird;',
+  'begin',
+  //'  shb.a:=3;',
+  '  wb.a:=4;',
+  'end;',
+  'procedure Fly;',
+  //'type TByteBird = TBird<byte>;',
+  //'var bb: TByteBird;',
+  'begin',
+  //'  bb.a:=5;',
+  '  Run;',
+  'end;',
+  'begin',
   '']);
   WriteReadUnit;
 end;