fcl-passrc: specialize inlinespecializeexpr

git-svn-id: trunk@42702 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1584,6 +1584,7 @@ type
     procedure ResolveSetParamsExpr(Params: TParamsExpr); virtual;
     procedure ResolveArrayValues(El: TArrayValues); virtual;
     procedure ResolveRecordValues(El: TRecordValues); virtual;
+    procedure ResolveInlineSpecializeExpr(El: TInlineSpecializeExpr); virtual;
     function ResolveAccessor(Expr: TPasExpr): TPasElement;
     procedure SetResolvedRefAccess(Expr: TPasExpr; Ref: TResolvedReference;
       Access: TResolvedRefAccess); virtual;
@@ -6312,13 +6313,16 @@ var
   Params, GenericTemplateList: TFPList;
   P: TPasElement;
   DestType: TPasType;
-  i: Integer;
+  i, ScopeDepth: Integer;
 begin
   {$IFDEF VerbosePasResolver}
   //writeln('TPasResolver.FinishSpecializeType ');
   {$ENDIF}
   // resolve Params
+  ScopeDepth:=StashSubExprScopes;
   Params:=El.Params;
+  if Params.Count=0 then
+    RaiseMsg(20190724114416,nMissingParameterX,sMissingParameterX,['type'],El);
   for i:=0 to Params.Count-1 do
     begin
     P:=TPasElement(Params[i]);
@@ -6328,11 +6332,9 @@ begin
     else
       RaiseMsg(20190728113336,nXExpectedButYFound,sXExpectedButYFound,['type identifier',GetObjName(P)+' parameter '+IntToStr(i+1)],El);
     end;
-  if Params.Count=0 then
-    RaiseMsg(20190724114416,nMissingParameterX,sMissingParameterX,['type'],El);
+  RestoreStashedScopes(ScopeDepth);
 
   // check DestType
-  GenericTemplateList:=nil;
   DestType:=El.DestType;
   if DestType=nil then
     RaiseMsg(20190725184734,nIdentifierNotFound,sIdentifierNotFound,['specialize type'],El)
@@ -9428,6 +9430,8 @@ begin
     end
   else if ElClass=TProcedureExpr then
     // resolved by FinishScope(stProcedure)
+  else if ElClass=TInlineSpecializeExpr then
+    ResolveInlineSpecializeExpr(TInlineSpecializeExpr(El))
   else
     RaiseNotYetImplemented(20170222184329,El);
 
@@ -10640,6 +10644,33 @@ begin
     LogMsg(20180429121127,mtHint,nMissingFieldsX,sMissingFieldsX,[s],El);
 end;
 
+procedure TPasResolver.ResolveInlineSpecializeExpr(El: TInlineSpecializeExpr);
+var
+  aName: String;
+  SpecType: TPasSpecializeType;
+  Expr: TPasExpr;
+  GenType: TPasGenericType;
+begin
+  SpecType:=El.DestType;
+  if SpecType.DestType<>nil then
+    RaiseNotYetImplemented(20190815092327,El,GetObjName(SpecType.DestType));
+
+  // resolve DestType
+  Expr:=SpecType.Expr;
+  if Expr=nil then
+    RaiseNotYetImplemented(20190815091319,SpecType);
+  if Expr.Kind<>pekIdent then
+    RaiseNotYetImplemented(20190815083349,Expr);
+  aName:=TPrimitiveExpr(Expr).Value;
+  GenType:=FindGenericType(aName,SpecType.Params.Count,Expr);
+  if GenType=nil then
+    RaiseMsg(20190815083433,nIdentifierNotFound,sIdentifierNotFound,[aName],Expr);
+  SpecType.DestType:=GenType;
+  GenType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasAliasType.DestType'){$ENDIF};
+
+  FinishSpecializeType(SpecType);
+end;
+
 function TPasResolver.ResolveAccessor(Expr: TPasExpr): TPasElement;
 
   function SubResolvePrimitive(Prim: TPrimitiveExpr): TPasElement;
@@ -15879,11 +15910,19 @@ end;
 
 procedure TPasResolver.SpecializeInlineSpecializeExpr(GenEl,
   SpecEl: TInlineSpecializeExpr);
+var
+  GenSpec, SpecSpec: TPasSpecializeType;
 begin
   SpecializeExpr(GenEl,SpecEl);
-  SpecializeElExpr(GenEl,SpecEl,GenEl.NameExpr,SpecEl.NameExpr);
-  SpecializeElList(GenEl,SpecEl,GenEl.Params,SpecEl.Params,true
-    {$IFDEF CheckPasTreeRefCount},'TInlineSpecializeExpr.Params'{$ENDIF});
+  GenSpec:=GenEl.DestType;
+  SpecSpec:=TPasSpecializeType.Create('',SpecEl);
+  SpecEl.DestType:=SpecSpec;
+
+  SpecializeElExpr(GenSpec,SpecSpec,GenSpec.Expr,SpecSpec.Expr);
+  SpecializeElList(GenSpec,SpecSpec,GenSpec.Params,SpecSpec.Params,true
+             {$IFDEF CheckPasTreeRefCount},'TPasSpecializeType.Params'{$ENDIF});
+
+  // SpecSpec.DestType is done in ResolveInlineSpecializeExpr
 end;
 
 procedure TPasResolver.SpecializeProcedureExpr(GenEl, SpecEl: TProcedureExpr);
@@ -24227,6 +24266,22 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
     Include(ResolvedEl.Flags,rrfCanBeStatement);
   end;
 
+  procedure ComputeSpecializeType(SpecType: TPasSpecializeType);
+  var
+    TypeEl: TPasType;
+  begin
+    if SpecType.CustomData is TPasSpecializeTypeData then
+      begin
+      TypeEl:=TPasSpecializeTypeData(SpecType.CustomData).SpecializedType;
+      SetResolverIdentifier(ResolvedEl,btContext,TypeEl,TypeEl,TypeEl,[]);
+      end
+    else
+      begin
+      TypeEl:=SpecType.DestType;
+      SetResolverIdentifier(ResolvedEl,btContext,SpecType,TypeEl,SpecType,[]);
+      end;
+  end;
+
 var
   DeclEl: TPasElement;
   ElClass: TClass;
@@ -24608,18 +24663,9 @@ begin
     SetResolverIdentifier(ResolvedEl,btContext,El,TPasGenericTemplateType(El),
       TPasGenericTemplateType(El),[])
   else if ElClass=TPasSpecializeType then
-    begin
-    if El.CustomData is TPasSpecializeTypeData then
-      begin
-      TypeEl:=TPasSpecializeTypeData(El.CustomData).SpecializedType;
-      SetResolverIdentifier(ResolvedEl,btContext,TypeEl,TypeEl,TypeEl,[]);
-      end
-    else
-      begin
-      TypeEl:=TPasSpecializeType(El).DestType;
-      SetResolverIdentifier(ResolvedEl,btContext,El,TypeEl,TPasType(El),[]);
-      end;
-    end
+    ComputeSpecializeType(TPasSpecializeType(El))
+  else if ElClass=TInlineSpecializeExpr then
+    ComputeSpecializeType(TInlineSpecializeExpr(El).DestType)
   else
     RaiseNotYetImplemented(20160922163705,El);
   {$IF defined(nodejs) and defined(VerbosePasResolver)}

packages/fcl-passrc/src/pastree.pp

@@ -604,10 +604,8 @@ type
     function GetDeclaration(full : Boolean): string; override;
     procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
       const Arg: Pointer); override;
-    procedure AddParam(El: TPasElement);
   public
-    NameExpr: TPasExpr; // TPrimitiveExpr
-    Params: TFPList; // list of TPasType or TPasExpr
+    DestType: TPasSpecializeType;
   end;
 
   { TPasClassOfType }
@@ -2034,17 +2032,11 @@ constructor TInlineSpecializeExpr.Create(const AName: string;
 begin
   if AName='' then ;
   inherited Create(AParent, pekSpecialize, eopNone);
-  Params:=TFPList.Create;
 end;
 
 destructor TInlineSpecializeExpr.Destroy;
-var
-  i: Integer;
 begin
-  ReleaseAndNil(TPasElement(NameExpr){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
-  for i:=0 to Params.Count-1 do
-    TPasElement(Params[i]).Release{$IFDEF CheckPasTreeRefCount}('TInlineSpecializeExpr.Params'){$ENDIF};
-  FreeAndNil(Params);
+  ReleaseAndNil(TPasElement(DestType){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
   inherited Destroy;
 end;
 
@@ -2054,34 +2046,15 @@ begin
 end;
 
 function TInlineSpecializeExpr.GetDeclaration(full: Boolean): string;
-var
-  i: Integer;
 begin
-  Result:='specialize ';
-  Result:=Result+NameExpr.GetDeclaration(full);
-  Result:=Result+'<';
-  for i:=0 to Params.Count-1 do
-    begin
-    if i>0 then
-      Result:=Result+',';
-    Result:=Result+TPasElement(Params[i]).GetDeclaration(false);
-    end;
+  Result:=DestType.GetDeclaration(full);
 end;
 
 procedure TInlineSpecializeExpr.ForEachCall(
   const aMethodCall: TOnForEachPasElement; const Arg: Pointer);
-var
-  i: Integer;
 begin
   inherited ForEachCall(aMethodCall, Arg);
-  ForEachChildCall(aMethodCall,Arg,NameExpr,false);
-  for i:=0 to Params.Count-1 do
-    ForEachChildCall(aMethodCall,Arg,TPasElement(Params[i]),true);
-end;
-
-procedure TInlineSpecializeExpr.AddParam(El: TPasElement);
-begin
-  Params.Add(El);
+  ForEachChildCall(aMethodCall,Arg,DestType,false);
 end;
 
 { TPasSpecializeType }
@@ -2119,7 +2092,7 @@ begin
       Result:=Result+',';
     Result:=Result+TPasElement(Params[i]).GetDeclaration(false);
     end;
-  If Full then
+  If Full and (Name<>'') then
     begin
     Result:=Name+' = '+Result;
     ProcessHints(False,Result);

packages/fcl-passrc/src/pparser.pp

@@ -321,7 +321,7 @@ type
     procedure ParseClassMembers(AType: TPasClassType);
     procedure ProcessMethod(AType: TPasClassType; IsClass : Boolean; AVisibility : TPasMemberVisibility);
     procedure ReadGenericArguments(List : TFPList;Parent : TPasElement);
-    procedure ReadSpecializeArguments(Spec: TPasElement);
+    procedure ReadSpecializeArguments(Spec: TPasSpecializeType);
     function ReadDottedIdentifier(Parent: TPasElement; out Expr: TPasExpr; NeedAsString: boolean): String;
     function CheckProcedureArgs(Parent: TPasElement;
       Args: TFPList; // list of TPasArgument
@@ -2304,6 +2304,7 @@ var
   SrcPos, ScrPos: TPasSourcePos;
   ProcType: TProcType;
   ProcExpr: TProcedureExpr;
+  SpecType: TPasSpecializeType;
 
 begin
   Result:=nil;
@@ -2389,7 +2390,8 @@ begin
         UngetToken;
         ParseExcExpectedIdentifier;
         end;
-      Last:=CreatePrimitiveExpr(AParent,pekString, '^'+CurTokenText);
+      Result:=CreatePrimitiveExpr(AParent,pekString, '^'+CurTokenText);
+      exit;
       end;
     tkBraceOpen:
       begin
@@ -2469,11 +2471,37 @@ begin
           break
         else
           begin
-          // an inline specialization (e.g. A<B,C>)
+          // an inline specialization (e.g. A<B,C>  or  something.A<B>)
+          // check expression in front is an identifier
+          Expr:=Result;
+          while Expr.Kind=pekBinary do
+            begin
+            if Expr.OpCode<>eopSubIdent then
+              ParseExcSyntaxError;
+            Expr:=TBinaryExpr(Expr).right;
+            end;
+          if Expr.Kind<>pekIdent then
+            ParseExcSyntaxError;
+
+          // read specialized type
           ISE:=TInlineSpecializeExpr(CreateElement(TInlineSpecializeExpr,'',AParent,SrcPos));
-          ReadSpecializeArguments(ISE);
-          ISE.NameExpr:=Result;
-          Result:=ISE;
+          SpecType:=TPasSpecializeType(CreateElement(TPasSpecializeType,'',ISE,SrcPos));
+          ISE.DestType:=SpecType;
+          ReadSpecializeArguments(SpecType);
+          // can't resolve SpecType.DestType here
+
+          // A<B>  or  something.A<B>
+          if Expr.Parent is TBinaryExpr then
+            begin
+            if TBinaryExpr(Expr.Parent).right<>Expr then
+              ParseExcSyntaxError;
+            TBinaryExpr(Expr.Parent).right:=ISE;
+            ISE.Parent:=Expr.Parent;
+            end;
+          SpecType.Expr:=Expr;
+          Expr.Parent:=SpecType;
+          if Expr=Result then
+            Result:=ISE;
           ISE:=nil;
           CanSpecialize:=aCannot;
           NextToken;
@@ -4079,19 +4107,8 @@ begin
 end;
 {$warn 5043 on}
 
-procedure TPasParser.ReadSpecializeArguments(Spec: TPasElement);
+procedure TPasParser.ReadSpecializeArguments(Spec: TPasSpecializeType);
 // after parsing CurToken is on tkGreaterThan
-
-  procedure AddParam(El: TPasElement);
-  begin
-    if Spec is TPasSpecializeType then
-      TPasSpecializeType(Spec).AddParam(El)
-    else if Spec is TInlineSpecializeExpr then
-      TInlineSpecializeExpr(Spec).AddParam(El)
-    else
-      ParseExcTokenError('[20190619112611] '+Spec.ClassName);
-  end;
-
 Var
   TypeEl: TPasType;
 begin
@@ -4100,7 +4117,7 @@ begin
   repeat
     //writeln('ARG TPasParser.ReadSpecializeArguments ',CurTokenText,' ',CurTokenString);
     TypeEl:=ParseType(Spec,CurTokenPos,'');
-    AddParam(TypeEl);
+    Spec.AddParam(TypeEl);
     NextToken;
     if CurToken=tkComma then
       continue

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -40,6 +40,7 @@ type
     procedure TestGen_Record_SpecializeSelfInsideFail;
     procedure TestGen_RecordAnoArray;
     // ToDo: unitname.specialize TBird<word>.specialize
+    procedure TestGen_RecordNestedSpecialize;
 
     // generic class
     procedure TestGen_Class;
@@ -57,10 +58,11 @@ type
     // ToDo: ancestor cycle: TBird<T> = class(TBird<word>) fail
     // ToDo: class-of
     // ToDo: UnitA.impl uses UnitB.intf uses UnitA.intf, UnitB has specialize of UnitA
-    procedure TestGen_NestedType;
+    procedure TestGen_Class_NestedType;
     // ToDo: procedure TestGen_NestedDottedType;
     procedure TestGen_Class_Enums_NotPropagating;
     procedure TestGen_Class_List;
+    // ToDo: procedure TestGen_Class_SubClassType;
 
     // generic external class
     procedure TestGen_ExtClass_Array;
@@ -84,6 +86,7 @@ type
     // generic statements
     procedure TestGen_LocalVar;
     procedure TestGen_Statements;
+    procedure TestGen_InlineSpecializeExpr;
     // ToDo: for-in
     procedure TestGen_TryExcept;
     // ToDo: call
@@ -359,6 +362,21 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGen_RecordNestedSpecialize;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  generic TBird<T> = record v: T; end;',
+  'var',
+  '  a: specialize TBird<specialize TBird<word>>;',
+  'begin',
+  '  a.v.v:=3;',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolveGenerics.TestGen_Class;
 begin
   StartProgram(false);
@@ -589,7 +607,7 @@ begin
   CheckResolverException('type "TBird" is not yet completely defined',nTypeXIsNotYetCompletelyDefined);
 end;
 
-procedure TTestResolveGenerics.TestGen_NestedType;
+procedure TTestResolveGenerics.TestGen_Class_NestedType;
 begin
   StartProgram(false);
   Add([
@@ -849,6 +867,44 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGen_InlineSpecializeExpr;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  generic TBird<T> = class',
+  '    constructor Create;',
+  '  end;',
+  '  generic TAnt<U> = class',
+  '    constructor Create;',
+  '  end;',
+  'constructor TBird.Create;',
+  'var',
+  '  a: TAnt<T>;',
+  '  b: TAnt<word>;',
+  'begin',
+  '  a:=TAnt<T>.create;',
+  '  b:=TAnt<word>.create;',
+  'end;',
+  'constructor TAnt.Create;',
+  'var',
+  '  i: TBird<U>;',
+  '  j: TBird<word>;',
+  '  k: TAnt<U>;',
+  'begin',
+  '  i:=TBird<U>.create;',
+  '  j:=TBird<word>.create;',
+  '  k:=TAnt<U>.create;',
+  'end;',
+  'var a: TAnt<word>;',
+  'begin',
+  '  a:=TAnt<word>.create;',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolveGenerics.TestGen_TryExcept;
 begin
   StartProgram(false);

packages/pastojs/src/pas2jsfiler.pp

@@ -844,6 +844,7 @@ type
     procedure Set_Variable_VarType(RefEl: TPasElement; Data: TObject);
     procedure Set_AliasType_DestType(RefEl: TPasElement; Data: TObject);
     procedure Set_PointerType_DestType(RefEl: TPasElement; Data: TObject);
+    procedure Set_InlineSpecializeExpr_DestType(RefEl: TPasElement; Data: TObject);
     procedure Set_ArrayType_ElType(RefEl: TPasElement; Data: TObject);
     procedure Set_FileType_ElType(RefEl: TPasElement; Data: TObject);
     procedure Set_SetType_EnumType(RefEl: TPasElement; Data: TObject);
@@ -3327,8 +3328,7 @@ procedure TPCUWriter.WriteInlineSpecializeExpr(Obj: TJSONObject;
   Expr: TInlineSpecializeExpr; aContext: TPCUWriterContext);
 begin
   WritePasExpr(Obj,Expr,pekSpecialize,eopNone,aContext);
-  WriteExpr(Obj,Expr,'Name',Expr.NameExpr,aContext);
-  WriteElementList(Obj,Expr,'Params',Expr.Params,aContext);
+  WriteElType(Obj,Expr,'Dest',Expr.DestType,aContext);
 end;
 
 procedure TPCUWriter.WriteRangeType(Obj: TJSONObject; El: TPasRangeType;
@@ -4249,6 +4249,21 @@ begin
     RaiseMsg(20180211121757,El,GetObjName(RefEl));
 end;
 
+procedure TPCUReader.Set_InlineSpecializeExpr_DestType(RefEl: TPasElement;
+  Data: TObject);
+var
+  El: TInlineSpecializeExpr absolute Data;
+begin
+  if RefEl is TPasSpecializeType then
+    begin
+    El.DestType:=TPasSpecializeType(RefEl);
+    if RefEl.Parent<>El then
+      RefEl.AddRef{$IFDEF CheckPasTreeRefCount}('TInlineSpecializeExpr.DestType'){$ENDIF};
+    end
+  else
+    RaiseMsg(20190815192420,El,GetObjName(RefEl));
+end;
+
 procedure TPCUReader.Set_ArrayType_ElType(RefEl: TPasElement; Data: TObject);
 var
   El: TPasArrayType absolute Data;
@@ -6708,10 +6723,7 @@ procedure TPCUReader.ReadInlineSpecializeExpr(Obj: TJSONObject;
   Expr: TInlineSpecializeExpr; aContext: TPCUReaderContext);
 begin
   Expr.Kind:=pekSpecialize;
-  Expr.NameExpr:=ReadExpr(Obj,Expr,'Name',aContext);
-  ReadElementList(Obj,Expr,'Params',Expr.Params,
-    {$IFDEF CheckPasTreeRefCount}'TPasSpecializeType.Params'{$ELSE}true{$ENDIF},
-    aContext);
+  ReadElType(Obj,'Dest',Expr,@Set_InlineSpecializeExpr_DestType,aContext);
 end;
 
 procedure TPCUReader.ReadRangeType(Obj: TJSONObject; El: TPasRangeType;

packages/pastojs/tests/tcfiler.pas

@@ -1360,8 +1360,7 @@ end;
 procedure TCustomTestPrecompile.CheckRestoredInlineSpecializedExpr(
   const Path: string; Orig, Rest: TInlineSpecializeExpr);
 begin
-  CheckRestoredElement(Path+'.NameExpr',Orig.NameExpr,Rest.NameExpr);
-  CheckRestoredElementList(Path+'.Params',Orig.Params,Rest.Params);
+  CheckRestoredElement(Path+'.DestType',Orig.DestType,Rest.DestType);
 end;
 
 procedure TCustomTestPrecompile.CheckRestoredRangeType(const Path: string;