* synchronized with trunk

git-svn-id: branches/wasm@46798 -

.gitattributes

@@ -13562,6 +13562,13 @@ tests/test/cg/obj/freebsd/x86_64/tcext3.o -text
 tests/test/cg/obj/freebsd/x86_64/tcext4.o -text
 tests/test/cg/obj/freebsd/x86_64/tcext5.o -text
 tests/test/cg/obj/freebsd/x86_64/tcext6.o -text
+tests/test/cg/obj/freertos/xtensa-call0/cpptcl1.o -text
+tests/test/cg/obj/freertos/xtensa-call0/cpptcl2.o -text
+tests/test/cg/obj/freertos/xtensa-call0/ctest.o -text
+tests/test/cg/obj/freertos/xtensa-call0/tcext3.o -text
+tests/test/cg/obj/freertos/xtensa-call0/tcext4.o -text
+tests/test/cg/obj/freertos/xtensa-call0/tcext5.o -text
+tests/test/cg/obj/freertos/xtensa-call0/tcext6.o -text
 tests/test/cg/obj/freertos/xtensa-windowed/cpptcl1.o -text
 tests/test/cg/obj/freertos/xtensa-windowed/cpptcl2.o -text
 tests/test/cg/obj/freertos/xtensa-windowed/ctest.o -text

compiler/ncgutil.pas

@@ -594,26 +594,59 @@ implementation
           paraloc: PCGParalocation;
           loc: tlocation;
           regtype: tregistertype;
-          reg: tregister;
-          size: tcgint;
+          reg,reg2: tregister;
+          size,regsize: tcgint;
         begin
           tparavarsym(sym).paraloc[calleeside].get_location(loc);
           size:=tparavarsym(sym).paraloc[calleeside].IntSize;
           paraloc:=tparavarsym(sym).paraloc[calleeside].Location;
-          reg:=sym.initialloc.register;
+{$if defined(cpu64bitalu)}
+          if sym.initialloc.size in [OS_128,OS_S128] then
+{$else}
+          if sym.initialloc.size in [OS_64,OS_S64] then
+{$endif defined(cpu64bitalu)}
+            begin
+              if target_info.endian=endian_little then
+                begin
+                  reg:=sym.initialloc.register;
+                  reg2:=sym.initialloc.registerhi;
+                end
+              else
+                begin
+                  reg:=sym.initialloc.registerhi;
+                  reg2:=sym.initialloc.register;
+                end;
+            end
+          else
+            begin
+              reg:=sym.initialloc.register;
+              reg2:=NR_NO;
+            end;
           regtype:=getregtype(reg);
-          repeat
-            loc.reference.offset:=paraloc^.reference.offset;
-            cg.rg[regtype].set_reg_initial_location(reg,loc.reference);
-            dec(size,tcgsize2size[paraloc^.Size]);
+          while true do
+            begin
+              cg.rg[regtype].set_reg_initial_location(reg,loc.reference);
+              regsize:=tcgsize2size[reg_cgsize(reg)];
+              dec(size,regsize);
+              if size<=0 then
+                break;
+              if paraloc<>nil then
+                paraloc:=paraloc^.Next;
+              if paraloc<>nil then
+                loc.reference.offset:=paraloc^.reference.offset
+              else
+                inc(loc.reference.offset,regsize);
 {$if defined(cpu8bitalu) or defined(cpu16bitalu)}
-            if cg.has_next_reg[getsupreg(reg)] then
-              reg:=cg.GetNextReg(reg)
-            else
+              if cg.has_next_reg[getsupreg(reg)] then
+                reg:=cg.GetNextReg(reg)
+              else
 {$endif}
-              reg:=sym.initialloc.registerhi;
-            paraloc:=paraloc^.Next;
-          until size=0;
+                begin
+                  if reg=reg2 then
+                    internalerror(2020090502);
+                  reg:=reg2;
+                end;
+            end;
         end;
 
       var
@@ -705,7 +738,7 @@ implementation
         { Notify the register allocator about memory location of
           the register which holds a value of a stack parameter }
         if (sym.typ=paravarsym) and
-          (tparavarsym(sym).paraloc[calleeside].Location^.Loc=LOC_REFERENCE) then
+           paramanager.param_use_paraloc(tparavarsym(sym).paraloc[calleeside]) then
           set_para_regvar_initial_location;
       end;
 

compiler/psub.pas

@@ -1173,7 +1173,7 @@ implementation
           with an internal error, so this switch is not enabled by default yet. To overcome this,
           multipass compilation of subroutines must be supported
         }
-        if (target_info.abi=abi_xtensa_windowed) and (procdef.stack_tainting_parameter(calleeside)) then
+        if procdef.stack_tainting_parameter(calleeside) then
           begin
             include(flags,pi_estimatestacksize);
             set_first_temp_offset;

compiler/rgobj.pas

@@ -2136,7 +2136,7 @@ unit rgobj;
         supreg: TSuperRegister;
       begin
         supreg:=getsupreg(reg);
-        if supreg>=maxreg then
+        if (supreg<first_imaginary) or (supreg>=maxreg) then
           internalerror(2020090501);
         alloc_spillinfo(supreg+1);
         spillinfo[supreg].spilllocation:=ref;

compiler/xtensa/cpupara.pas

@@ -158,6 +158,8 @@ unit cpupara;
             begin
               curintreg:=RS_A2;
               maxintreg:=RS_A7;
+              if (side=calleeside) and (current_procinfo.framepointer=NR_STACK_POINTER_REG) then
+                cur_stack_offset:=(p as tcpuprocdef).total_stackframe_size;
             end;
           else
             Internalerror(2020031404);

compiler/xtensa/cpupi.pas

@@ -84,7 +84,8 @@ unit cpupi;
             callins:=A_CALL0;
             callxins:=A_CALLX0;
             maxcall:=0;
-            framepointer:=NR_FRAME_POINTER_REG;
+            { we do not use a frame pointer }
+            framepointer:=NR_STACK_POINTER_REG;
           end;
       end;
 

packages/fcl-passrc/src/pasresolver.pp

@@ -1791,7 +1791,7 @@ type
     function GetTVarRec(El: TPasArrayType): TPasRecordType; virtual;
     function FindDefaultConstructor(aClass: TPasClassType): TPasConstructor; virtual;
     function GetTypeInfoParamType(Param: TPasExpr;
-      out ParamResolved: TPasResolverResult; LoType: boolean): TPasType; virtual;
+      out ParamResolved: TPasResolverResult; LoType: boolean): TPasType; virtual; // returns type of param in typeinfo(param)
   protected
     // constant evaluation
     fExprEvaluator: TResExprEvaluator;
@@ -1840,8 +1840,7 @@ type
       GenTempl: TPasGenericTemplateType; ErrorPos: TPasElement);
     function CreateSpecializedItem(El: TPasElement; GenericEl: TPasElement;
       const ParamsResolved: TPasTypeArray): TPRSpecializedItem; virtual;
-    function CreateSpecializedTypeName(SpecializedItems: TObjectList;
-      Item: TPRSpecializedItem): string; virtual;
+    function CreateSpecializedTypeName(Item: TPRSpecializedItem): string; virtual;
     procedure InitSpecializeScopes(El: TPasElement; out State: TScopeStashState); virtual;
     procedure RestoreSpecializeScopes(const State: TScopeStashState); virtual;
     procedure SpecializeGenericIntf(SpecializedItem: TPRSpecializedItem); virtual;
@@ -2473,8 +2472,11 @@ function ProcNeedsBody(Proc: TPasProcedure): boolean;
 function ProcHasGroupOverload(Proc: TPasProcedure): boolean;
 procedure ClearHelperList(var List: TPRHelperEntryArray);
 function ChompDottedIdentifier(const Identifier: string): string;
-function FirstDottedIdentifier(const Identifier: string): string;
+function FirstDottedIdentifier(const Identifier: string): string; // without <>
+function LastDottedIdentifier(const Identifier: string): string; // without <>
 function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean;
+function GetFirstDotPos(const Identifier: string): integer;
+function GetLastDotPos(const Identifier: string): integer;
 {$IF FPC_FULLVERSION<30101}
 function IsValidIdent(const Ident: string; AllowDots: Boolean = False; StrictDots: Boolean = False): Boolean;
 {$ENDIF}
@@ -2943,14 +2945,18 @@ end;
 
 function ChompDottedIdentifier(const Identifier: string): string;
 var
-  p: Integer;
+  p, Lvl: Integer;
 begin
   Result:=Identifier;
   p:=length(Identifier);
+  Lvl:=0;
   while (p>0) do
     begin
-    if Identifier[p]='.' then
-      break;
+    case Identifier[p] of
+    '.': if Lvl=0 then break;
+    '>': inc(Lvl);
+    '<': dec(Lvl);
+    end;
     dec(p);
     end;
   Result:=LeftStr(Identifier,p-1);
@@ -2958,13 +2964,41 @@ end;
 
 function FirstDottedIdentifier(const Identifier: string): string;
 var
-  p: SizeInt;
+  p, l: SizeInt;
 begin
-  p:=Pos('.',Identifier);
-  if p<1 then
-    Result:=Identifier
-  else
-    Result:=LeftStr(Identifier,p-1);
+  p:=1;
+  l:=length(Identifier);
+  repeat
+    if p>l then
+      exit(Identifier)
+    else if Identifier[p] in ['<','.'] then
+      exit(LeftStr(Identifier,p-1))
+    else
+      inc(p);
+  until false;
+end;
+
+function LastDottedIdentifier(const Identifier: string): string;
+var
+  p, Lvl, EndP: Integer;
+begin
+  p:=length(Identifier);
+  EndP:=p;
+  Lvl:=0;
+  while (p>0) do
+    begin
+    case Identifier[p] of
+    '.': if Lvl=0 then break;
+    '>': inc(Lvl);
+    '<':
+      begin
+      dec(Lvl);
+      EndP:=p-1;
+      end;
+    end;
+    dec(p);
+    end;
+  Result:=copy(Identifier,p+1,EndP-p);
 end;
 
 function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean;
@@ -2978,6 +3012,43 @@ begin
   Result:=(length(Identifier)=l) or (Identifier[l+1]='.');
 end;
 
+function GetFirstDotPos(const Identifier: string): integer;
+var
+  l: SizeInt;
+  Lvl: Integer;
+begin
+  Result:=1;
+  l:=length(Identifier);
+  Lvl:=0;
+  repeat
+    if Result>l then
+      exit(-1);
+    case Identifier[Result] of
+    '.': if Lvl=0 then exit;
+    '<': inc(Lvl);
+    '>': dec(Lvl);
+    end;
+    inc(Result);
+  until false;
+end;
+
+function GetLastDotPos(const Identifier: string): integer;
+var
+  Lvl: Integer;
+begin
+  Result:=length(Identifier);
+  Lvl:=0;
+  while (Result>0) do
+    begin
+    case Identifier[Result] of
+    '.': if Lvl=0 then exit;
+    '>': inc(Lvl);
+    '<': dec(Lvl);
+    end;
+    dec(Result);
+    end;
+end;
+
 function DotExprToName(Expr: TPasExpr): string;
 var
   C: TClass;
@@ -6931,7 +7002,7 @@ begin
         RaiseMsg(20181231150404,nXCannotHaveParameters,sXCannotHaveParameters,[GetElementTypeName(Proc)],Proc);
       end;
 
-    HasDots:=Pos('.',ProcName)>1;
+    HasDots:=GetFirstDotPos(ProcName)>0;
 
     if Proc.Parent is TPasClassType then
       begin
@@ -7309,7 +7380,6 @@ var
   DeclProc: TPasProcedure;
   ClassOrRecScope: TPasClassOrRecordScope;
   SelfArg: TPasArgument;
-  p: Integer;
   SelfType, LoSelfType: TPasType;
   LastNamePart: TProcedureNamePart;
 begin
@@ -7336,11 +7406,7 @@ begin
   else
     begin
     // remove path from ProcName
-    repeat
-      p:=Pos('.',ProcName);
-      if p<1 then break;
-      Delete(ProcName,1,p);
-    until false;
+    ProcName:=LastDottedIdentifier(ProcName);
     end;
 
   if ImplProcScope.DeclarationProc=nil then
@@ -11920,7 +11986,7 @@ begin
       AddGenericTemplateIdentifiers(TypeParams,Scope);
       end;
   end else if TypeParams<>nil then
-    RaiseNotYetImplemented(20190812215851,El);
+    RaiseNotYetImplemented(20190812215851,El); // anonymous generic array type
 end;
 
 procedure TPasResolver.AddRecordType(El: TPasRecordType; TypeParams: TFPList);
@@ -12412,7 +12478,7 @@ begin
 
   // Note: El.ProcType is nil !  It is parsed later.
 
-  HasDot:=Pos('.',ProcName)>1;
+  HasDot:=GetFirstDotPos(ProcName)>1;
   if (TypeParams<>nil) then
     if HasDot<>(TypeParams.Count>1) then
       RaiseNotYetImplemented(20190818093923,El);
@@ -12485,14 +12551,14 @@ begin
       Level:=0;
       repeat
         inc(Level);
-        p:=Pos('.',ProcName);
+        p:=GetFirstDotPos(ProcName);
         if p<1 then
           begin
           if ClassOrRecType=nil then
             RaiseInternalError(20161013170829);
           break;
           end;
-        aClassName:=LeftStr(ProcName,p-1);
+        aClassName:=FirstDottedIdentifier(ProcName);
         Delete(ProcName,1,p);
         TypeParamCount:=0;
         if TypeParams<>nil then
@@ -16503,7 +16569,7 @@ var
   begin
     // insert in front of currently parsed elements
     // beware: specializing an element can create other specialized elements
-    // add behind last specialized element of this GenericEl
+    // add behind last finished specialized element of this GenericEl
     // for example: A = class(B<C<D>>)
     // =>
     //  D
@@ -16548,15 +16614,6 @@ var
       else
         break;
       end;
-
-    //if i<0 then
-    //  begin
-    //  {$IF defined(VerbosePasResolver) or defined(VerbosePas2JS)}
-    //  writeln('InsertBehind Generic=',GetObjName(GenericEl),' Last=',GetObjName(Last));
-    //  //for i:=0 to List.Count-1 do writeln('  ',GetObjName(TObject(List[i])));
-    //  {$ENDIF}
-    //  i:=List.Count-1;
-    //  end;
     List.Insert(i+1,NewEl);
   end;
 
@@ -16571,8 +16628,6 @@ var
   ProcItem: TPRSpecializedProcItem;
 begin
   Result:=nil;
-  if Pos('$G',GenericEl.Name)>0 then
-    RaiseNotYetImplemented(20190813003729,El);
 
   SrcModule:=GenericEl.GetModule;
   SrcModuleScope:=SrcModule.CustomData as TPasModuleScope;
@@ -16602,7 +16657,7 @@ begin
   Result.Params:=ParamsResolved;
   Result.Index:=SpecializedItems.Count;
   SpecializedItems.Add(Result);
-  NewName:=CreateSpecializedTypeName(SpecializedItems,Result);
+  NewName:=CreateSpecializedTypeName(Result);
   NewClass:=TPTreeElement(GenericEl.ClassType);
   NewParent:=GenericEl.Parent;
   NewEl:=TPasElement(NewClass.Create(NewName,NewParent));
@@ -16631,10 +16686,66 @@ begin
     SpecializeGenericImpl(Result);
 end;
 
-function TPasResolver.CreateSpecializedTypeName(SpecializedItems: TObjectList;
-  Item: TPRSpecializedItem): string;
+function TPasResolver.CreateSpecializedTypeName(Item: TPRSpecializedItem): string;
+
+  function GetTypeName(aType: TPasType): string; forward;
+
+  function GetSpecParams(Item: TPRSpecializedItem): string;
+  var
+    i: Integer;
+  begin
+    Result:='<';
+    for i:=0 to length(Item.Params)-1 do
+      begin
+      if i>0 then Result:=Result+',';
+      Result:=Result+GetTypeName(Item.Params[i]);
+      end;
+    Result:=Result+'>';
+  end;
+
+  function GetTypeName(aType: TPasType): string;
+  var
+    Arr: TPasArrayType;
+    ElType: TPasType;
+    ChildItem: TPRSpecializedItem;
+  begin
+    if aType.Name='' then
+      begin
+      if aType is TPasArrayType then
+        begin
+        // e.g. TBird<array of word>
+        Result:='array of ';
+        Arr:=TPasArrayType(aType);
+        if length(Arr.Ranges)>0 then
+          RaiseNotYetImplemented(20200905173026,Item.FirstSpecialize);
+        ElType:=ResolveAliasType(Arr.ElType,false);
+        if ElType is TPasArrayType then
+          RaiseNotYetImplemented(20200905173159,Arr,'multidimensional anonymous array as generic param');
+        Result:=Result+GetTypeName(ElType);
+        end
+      else
+        RaiseNotYetImplemented(20200905173241,aType);
+      end
+    else
+      begin
+      if aType.Parent is TPasType then
+        Result:=GetTypeName(TPasType(aType.Parent))
+      else if aType is TPasUnresolvedSymbolRef then
+        Result:='System'
+      else
+        Result:=aType.GetModule.Name;
+      Result:=Result+'.'+aType.Name;
+      if aType.CustomData is TPasGenericScope then
+        begin
+        ChildItem:=TPasGenericScope(aType.CustomData).SpecializedFromItem;
+        if ChildItem<>nil then
+          Result:=Result+GetSpecParams(ChildItem);
+        end;
+      end;
+  end;
+
 begin
-  Result:=Item.GenericEl.Name+'$G'+IntToStr(SpecializedItems.Count);
+  Result:=Item.GenericEl.Name+GetSpecParams(Item);
 end;
 
 procedure TPasResolver.InitSpecializeScopes(El: TPasElement; out
@@ -17063,12 +17174,11 @@ begin
     if SpecClassOrRecScope=nil then
       RaiseNotYetImplemented(20190921221839,SpecDeclProc);
     NewImplProcName:=GenImplProc.Name;
-    p:=length(NewImplProcName);
-    while (p>0) and (NewImplProcName[p]<>'.') do dec(p);
-    if p=0 then
+    LastDotP:=GetLastDotPos(NewImplProcName);
+    if LastDotP<1 then
       RaiseNotYetImplemented(20190921221730,GenImplProc);
     // has classname -> replace generic classname with specialized classname
-    LastDotP:=p;
+    p:=LastDotP;
     while (p>1) and (NewImplProcName[p-1]<>'.') do dec(p);
     OldClassname:=copy(NewImplProcName,p,LastDotP-p);
     GenClassOrRec:=GenDeclProc.Parent as TPasMembersType;
@@ -17080,8 +17190,7 @@ begin
     begin
     // use classname of GenImplProc and name of SpecDeclProc
     OldClassname:=GenImplProc.Name;
-    p:=length(OldClassname);
-    while (p>0) and (OldClassname[p]<>'.') do dec(p);
+    p:=GetLastDotPos(OldClassname);
     if p>0 then
       NewImplProcName:=LeftStr(OldClassname,p)+SpecDeclProc.Name
     else
@@ -17666,17 +17775,17 @@ var
   GenResultEl, NewResultEl: TPasResultElement;
   NewClass: TPTreeElement;
   i: Integer;
-  GenScope: TPasGenericScope;
+  SpecScope: TPasGenericScope;
 begin
   if GenEl.GenericTemplateTypes<>nil then
     begin
-    GenScope:=TPasGenericScope(PushScope(SpecEl,ScopeClass_ProcType));
+    SpecScope:=TPasGenericScope(PushScope(SpecEl,ScopeClass_ProcType));
     if SpecializedItem<>nil then
       begin
       // specialized procedure type
-      GenScope.SpecializedFromItem:=SpecializedItem;
+      SpecScope.SpecializedFromItem:=SpecializedItem;
       AddSpecializedTemplateIdentifiers(GenEl.GenericTemplateTypes,
-        SpecializedItem,GenScope,true);
+        SpecializedItem,SpecScope,true);
       end
     else
       begin
@@ -18148,19 +18257,19 @@ end;
 procedure TPasResolver.SpecializeArrayType(GenEl, SpecEl: TPasArrayType;
   SpecializedItem: TPRSpecializedTypeItem);
 var
-  GenScope: TPasGenericScope;
+  SpecScope: TPasGenericScope;
 begin
   SpecEl.IndexRange:=GenEl.IndexRange;
   SpecEl.PackMode:=GenEl.PackMode;
   if GenEl.GenericTemplateTypes<>nil then
     begin
-    GenScope:=TPasGenericScope(PushScope(SpecEl,ScopeClass_Array));
+    SpecScope:=TPasGenericScope(PushScope(SpecEl,ScopeClass_Array));
     if SpecializedItem<>nil then
       begin
       // specialized generic array
-      GenScope.SpecializedFromItem:=SpecializedItem;
+      SpecScope.SpecializedFromItem:=SpecializedItem;
       AddSpecializedTemplateIdentifiers(GenEl.GenericTemplateTypes,
-                                        SpecializedItem,GenScope,true);
+                                        SpecializedItem,SpecScope,true);
       end
     else
       begin
@@ -25384,12 +25493,14 @@ function TPasResolver.GetTypeDescription(aType: TPasType; AddPath: boolean): str
       begin
       i:=GetTypeParameterCount(TPasGenericType(aType));
       if i>0 then
+        // generic, not specialized
         Result:=Result+GetGenericParamCommas(GetTypeParameterCount(TPasGenericType(aType)))
       else if aType.CustomData is TPasGenericScope then
         begin
         GenScope:=TPasGenericScope(aType.CustomData);
-        if GenScope.SpecializedFromItem<>nil then
+        if (GenScope.SpecializedFromItem<>nil) and IsValidIdent(aType.Name) then
           begin
+          // specialized without params in name -> append params
           Params:=GenScope.SpecializedFromItem.Params;
           Result:=Result+'<';
           for i:=0 to length(Params)-1 do
@@ -29527,6 +29638,7 @@ function TPasResolver.CheckClassIsClass(SrcType, DestType: TPasType): integer;
 // check if Src is equal or descends from Dest
 // Generics: TBird<T> is both directions a TBird<word>
 //       and TBird<TMap<T>> is both directions a TBird<TMap<word>>
+//       but a TBird<word> is not a TBird<char>
 
   function CheckSpecialized(SrcScope, DestScope: TPasGenericScope): boolean;
   var

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -5,7 +5,8 @@ unit tcresolvegenerics;
 interface
 
 uses
-  Classes, SysUtils, testregistry, tcresolver, PasResolveEval, PParser;
+  Classes, SysUtils, testregistry, tcresolver, PasResolveEval, PParser,
+  PScanner;
 
 type
 
@@ -91,7 +92,8 @@ type
     procedure TestGen_Class_MemberTypeConstructor;
     procedure TestGen_Class_AliasMemberType;
     procedure TestGen_Class_AccessGenericMemberTypeFail;
-    procedure TestGen_Class_ReferenceTo; // ToDo
+    procedure TestGen_Class_ReferenceTo;
+    procedure TestGen_Class_TwoSpecsAreNotRelatedWarn;
     procedure TestGen_Class_List;
     // ToDo: different modeswitches at parse time and specialize time
 
@@ -1568,6 +1570,26 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGen_Class_TwoSpecsAreNotRelatedWarn;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TObject = class end;',
+  '  TBird<T> = class F: T; end;',
+  '  TBirdWord = TBird<Word>;',
+  '  TBirdChar = TBird<Char>;',
+  'var',
+  '  w: TBirdWord;',
+  '  c: TBirdChar;',
+  'begin',
+  '  w:=TBirdWord(c);',
+  '']);
+  ParseProgram;
+  CheckResolverHint(mtWarning,nClassTypesAreNotRelatedXY,'Class types "TBird<System.Char>" and "TBird<System.Word>" are not related');
+end;
+
 procedure TTestResolveGenerics.TestGen_Class_List;
 begin
   StartProgram(false);

packages/pastojs/tests/tcgenerics.pas

@@ -81,7 +81,7 @@ type
 
     // generic procedure type
     procedure TestGen_ProcType_ProcLocal;
-    procedure TestGen_ProcType_ProcLocal_RTTI;
+    procedure TestGen_ProcType_Local_RTTI_Fail;
     procedure TestGen_ProcType_ParamUnitImpl;
   end;
 
@@ -309,9 +309,9 @@ begin
     LinesToStr([ // statements
     'var $impl = $mod.$impl;',
     'rtl.recNewT($mod, "TAnt$G1", function () {',
+    '  var $r = $mod.$rtti.$Record("TAnt<Test1.TBird>", {});',
     '  this.$initSpec = function () {',
     '    this.x = $impl.TBird.$new();',
-    '    var $r = $mod.$rtti.$Record("TAnt$G1", {});',
     '    $r.addField("x", $mod.$rtti["TBird"]);',
     '  };',
     '  this.$eq = function (b) {',
@@ -323,7 +323,7 @@ begin
     '}, true);',
     '']),
     LinesToStr([ // $mod.$init
-    '$impl.p = $mod.$rtti["TAnt$G1"];',
+    '$impl.p = $mod.$rtti["TAnt<Test1.TBird>"];',
     '']),
     LinesToStr([ // statements
     'rtl.recNewT($impl, "TBird", function () {',
@@ -598,7 +598,7 @@ begin
   ConvertProgram;
   CheckSource('TestGen_Class_TypeInfo',
     LinesToStr([ // statements
-    '$mod.$rtti.$Class("TBird$G1");',
+    '$mod.$rtti.$Class("TBird<System.Word>");',
     'rtl.createClass($mod, "TObject", null, function () {',
     '  this.$init = function () {',
     '  };',
@@ -612,12 +612,12 @@ begin
     '  };',
     '  var $r = this.$rtti;',
     '  $r.addField("m", rtl.word);',
-    '});',
+    '}, "TBird<System.Word>");',
     'this.b = null;',
     'this.p = null;',
     '']),
     LinesToStr([ // $mod.$main
-    '$mod.p = $mod.$rtti["TBird$G1"];',
+    '$mod.p = $mod.$rtti["TBird<System.Word>"];',
     '$mod.p = $mod.b.$rtti;',
     '']));
 end;
@@ -870,7 +870,7 @@ begin
     LinesToStr([ // $mod.$main
     '$mod.w = $mod.c;',
     '']));
-  CheckHint(mtWarning,nClassTypesAreNotRelatedXY,'Class types "TBird$G2<Char>" and "TBird$G1<Word>" are not related');
+  CheckHint(mtWarning,nClassTypesAreNotRelatedXY,'Class types "TBird<System.Char>" and "TBird<System.Word>" are not related');
   CheckResolverUnexpectedHints();
 end;
 
@@ -1071,8 +1071,8 @@ begin
   ConvertProgram;
   CheckSource('TestGen_ClassForward_CircleRTTI',
     LinesToStr([ // statements
-    '$mod.$rtti.$Class("TAnt$G2");',
-    '$mod.$rtti.$Class("TFish$G2");',
+    '$mod.$rtti.$Class("TAnt<System.Word>");',
+    '$mod.$rtti.$Class("TFish<System.Word>");',
     'rtl.createClass($mod, "TObject", null, function () {',
     '  this.$init = function () {',
     '  };',
@@ -1091,8 +1091,8 @@ begin
     '    $mod.TPersistent.$final.call(this);',
     '  };',
     '  var $r = this.$rtti;',
-    '  $r.addField("f", $mod.$rtti["TFish$G2"]);',
-    '});',
+    '  $r.addField("f", $mod.$rtti["TFish<System.Word>"]);',
+    '}, "TAnt<System.Word>");',
     'rtl.createClass($mod, "TFish$G2", $mod.TPersistent, function () {',
     '  this.$init = function () {',
     '    $mod.TPersistent.$init.call(this);',
@@ -1103,14 +1103,14 @@ begin
     '    $mod.TPersistent.$final.call(this);',
     '  };',
     '  var $r = this.$rtti;',
-    '  $r.addField("a", $mod.$rtti["TAnt$G2"]);',
-    '});',
+    '  $r.addField("a", $mod.$rtti["TAnt<System.Word>"]);',
+    '}, "TFish<System.Word>");',
     'this.WordFish = null;',
     'this.p = null;',
     '']),
     LinesToStr([ // $mod.$main
-    '$mod.p = $mod.$rtti["TAnt$G2"];',
-    '$mod.p = $mod.$rtti["TFish$G2"];',
+    '$mod.p = $mod.$rtti["TAnt<System.Word>"];',
+    '$mod.p = $mod.$rtti["TFish<System.Word>"];',
     '']));
 end;
 
@@ -1314,11 +1314,11 @@ begin
   ConvertProgram;
   CheckSource('TestGen_ExtClass_RTTI',
     LinesToStr([ // statements
-    '$mod.$rtti.$ExtClass("TGJSSET$G1", {',
+    '$mod.$rtti.$ExtClass("TGJSSET<System.JSValue>", {',
     '  jsclass: "SET"',
     '});',
     '$mod.$rtti.$RefToProcVar("TJSSetEventProc", {',
-    '  procsig: rtl.newTIProcSig([["value", rtl.jsvalue], ["key", rtl.nativeint], ["set_", $mod.$rtti["TGJSSET$G1"]]])',
+    '  procsig: rtl.newTIProcSig([["value", rtl.jsvalue], ["key", rtl.nativeint], ["set_", $mod.$rtti["TGJSSET<System.JSValue>"]]])',
     '});',
     'this.p = null;',
     '']),
@@ -1360,7 +1360,7 @@ begin
     'rtl.module("UnitA", ["system"], function () {',
     '  var $mod = this;',
     '  var $impl = $mod.$impl;',
-    '  $mod.$rtti.$ExtClass("TAnt$G1", {',
+    '  $mod.$rtti.$ExtClass("TAnt<UnitA.TBird>", {',
     '    jsclass: "SET"',
     '  });',
     '  $mod.$init = function () {',
@@ -1432,7 +1432,7 @@ begin
     '  this.$final = function () {',
     '  };',
     '});',
-    'rtl.createInterface($mod, "IBird$G2", "{7D9907A1-5178-37B5-9D32-7BC020005905}", ["GetSize", "SetSize", "DoIt"], $mod.IUnknown);',
+    'rtl.createInterface($mod, "IBird$G2", "{33AB51C6-6240-3BDF-B4B0-D48A593EAB0A}", ["GetSize", "SetSize", "DoIt"], $mod.IUnknown);',
     'rtl.createClass($mod, "TBird$G1", $mod.TObject, function () {',
     '  rtl.addIntf(this, $mod.IBird$G2);',
     '});',
@@ -2061,28 +2061,30 @@ begin
   '  s: specialize TStatic<TBird>;',
   'begin',
   '  d[0].b:=s[1].b;',
+  '  s:=s;',
   '']));
   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.$DynArray("TDyn$G1", {});',
+    '  $mod.$rtti.$DynArray("TDyn<UnitA.TBird>", {});',
     '  this.TStatic$G1$clone = function (a) {',
     '    var r = [];',
     '    for (var i = 0; i < 2; i++) r.push($impl.TBird.$clone(a[i]));',
     '    return r;',
     '  };',
-    '  $mod.$rtti.$StaticArray("TStatic$G1", {',
+    '  $mod.$rtti.$StaticArray("TStatic<UnitA.TBird>", {',
     '    dims: [2]',
     '  });',
     '  $mod.$init = function () {',
     '    $impl.d[0].b = $impl.s[0].b;',
+    '    $impl.s = $mod.TStatic$G1$clone($impl.s);',
     '  };',
     '}, null, function () {',
     '  var $mod = this;',
@@ -2104,8 +2106,8 @@ begin
     '});']));
   CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
     LinesToStr([ // statements
-    'pas.UnitA.$rtti["TDyn$G1"].eltype = pas.UnitA.$rtti["TBird"];',
-    'pas.UnitA.$rtti["TStatic$G1"].eltype = pas.UnitA.$rtti["TBird"];',
+    'pas.UnitA.$rtti["TDyn<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];',
+    'pas.UnitA.$rtti["TStatic<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];',
     '']),
     LinesToStr([ // $mod.$main
     '']));
@@ -2142,7 +2144,7 @@ begin
     '']));
 end;
 
-procedure TTestGenerics.TestGen_ProcType_ProcLocal_RTTI;
+procedure TTestGenerics.TestGen_ProcType_Local_RTTI_Fail;
 begin
   WithTypeInfo:=true;
   StartProgram(false);
@@ -2183,8 +2185,10 @@ begin
   'var',
   '  f: specialize TAnt<TBird>;',
   '  b: TBird;',
+  '  p: pointer;',
   'begin',
   '  b:=f(b);',
+  '  p:=typeinfo(f);',
   '']));
   Add([
   'uses UnitA;',
@@ -2196,13 +2200,14 @@ begin
     'rtl.module("UnitA", ["system"], function () {',
     '  var $mod = this;',
     '  var $impl = $mod.$impl;',
-    '  $mod.$rtti.$ProcVar("TAnt$G1", {',
+    '  $mod.$rtti.$ProcVar("TAnt<UnitA.TBird>", {',
     '    init: function () {',
     '      this.procsig = rtl.newTIProcSig([["a", $mod.$rtti["TBird"], 2]], $mod.$rtti["TBird"]);',
     '    }',
     '  });',
     '  $mod.$init = function () {',
     '    $impl.b.$assign($impl.f($impl.b));',
+    '    $impl.p = $mod.$rtti["TAnt<UnitA.TBird>"];',
     '  };',
     '}, null, function () {',
     '  var $mod = this;',
@@ -2221,10 +2226,11 @@ begin
     '  });',
     '  $impl.f = null;',
     '  $impl.b = $impl.TBird.$new();',
+    '  $impl.p = null;',
     '});']));
   CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
     LinesToStr([ // statements
-    'pas.UnitA.$rtti["TAnt$G1"].init();',
+    'pas.UnitA.$rtti["TAnt<UnitA.TBird>"].init();',
     '']),
     LinesToStr([ // $mod.$main
     '']));

tests/Makefile

@@ -2458,6 +2458,7 @@ CPP_OBJECTS=$(addprefix $(C_OBJECTS_DIR)/, $(subst .cpp,.o, $(CPP_SOURCES)))
 TASM_OBJECTS=$(addprefix $(C_OBJECTS_DIR)/, $(subst .asm,.obj, $(TASM_SOURCES)))
 create_c_objects:
 ifneq ($(TEST_CCOMPILER),)
+		$(MKDIRTREE) $(C_OBJECTS_DIR)
 		-$(COPY) $(addprefix $(C_SOURCE_DIR)/, $(C_SOURCES)) $(C_OBJECTS_DIR)
 		$(MAKE) $(C_OBJECTS)
 		-$(COPY) $(addprefix $(C_SOURCE_DIR)/, $(CPP_SOURCES)) $(C_OBJECTS_DIR)

tests/Makefile.fpc

@@ -255,6 +255,7 @@ TASM_OBJECTS=$(addprefix $(C_OBJECTS_DIR)/, $(subst .asm,.obj, $(TASM_SOURCES)))
 
 create_c_objects:
 ifneq ($(TEST_CCOMPILER),)
+		$(MKDIRTREE) $(C_OBJECTS_DIR)
 		-$(COPY) $(addprefix $(C_SOURCE_DIR)/, $(C_SOURCES)) $(C_OBJECTS_DIR)
 		$(MAKE) $(C_OBJECTS)
 		-$(COPY) $(addprefix $(C_SOURCE_DIR)/, $(CPP_SOURCES)) $(C_OBJECTS_DIR)
@@ -278,7 +279,7 @@ $(C_OBJECTS) : %.o: %.c
 
 $(CPP_OBJECTS) : %.o: %.cpp
 		$(TEST_CCOMPILER) -c $(TEST_CFLAGS) $< -o $@
-		
+
 copyfiles:
         -$(MKDIRTREE) $(TEST_OUTPUTDIR)/test/cg
         -$(COPY) $(C_OBJECTS) $(TEST_OUTPUTDIR)/test/cg
@@ -460,7 +461,7 @@ test_c_objects: testprep
 	$(MAKE) $(patsubst %.pp,%.elg, $(wildcard test/cg/cdecl/tcalext*.pp))
 	$(MAKE) $(patsubst %.pp,%.log, $(wildcard test/cg/cdecl/tcppcl*.pp))
 	$(MAKE) $(patsubst %.pp,%.elg, $(wildcard test/cg/cdecl/tcppcl*.pp))
-	
+
 ################################
 # Compile and Run tests
 #

utils/pas2js/dist/rtl.js

@@ -286,15 +286,16 @@ var rtl = {
     return parent;
   },
 
-  initClass: function(c,parent,name,initfn){
+  initClass: function(c,parent,name,initfn,rttiname){
+    if (!rttiname) rttiname = name;
     parent[name] = c;
     c.$class = c; // Note: o.$class === Object.getPrototypeOf(o)
-    c.$classname = name;
+    c.$classname = rttiname;
     parent = rtl.initStruct(c,parent,name);
     c.$fullname = parent.$name+'.'+name;
     // rtti
     if (rtl.debug_rtti) rtl.debug('initClass '+c.$fullname);
-    var t = c.$module.$rtti.$Class(c.$name,{ "class": c });
+    var t = c.$module.$rtti.$Class(rttiname,{ "class": c });
     c.$rtti = t;
     if (rtl.isObject(c.$ancestor)) t.ancestor = c.$ancestor.$rtti;
     if (!t.ancestor) t.ancestor = null;
@@ -302,7 +303,7 @@ var rtl = {
     initfn.call(c);
   },
 
-  createClass: function(parent,name,ancestor,initfn){
+  createClass: function(parent,name,ancestor,initfn,rttiname){
     // create a normal class,
     // ancestor must be null or a normal class,
     // the root ancestor can be an external class
@@ -340,10 +341,10 @@ var rtl = {
         this.$final();
       };
     };
-    rtl.initClass(c,parent,name,initfn);
+    rtl.initClass(c,parent,name,initfn,rttiname);
   },
 
-  createClassExt: function(parent,name,ancestor,newinstancefnname,initfn){
+  createClassExt: function(parent,name,ancestor,newinstancefnname,initfn,rttiname){
     // Create a class using an external ancestor.
     // If newinstancefnname is given, use that function to create the new object.
     // If exist call BeforeDestruction and AfterConstruction.
@@ -391,7 +392,7 @@ var rtl = {
       if (this[fnname]) this[fnname]();
       if (this.$final) this.$final();
     };
-    rtl.initClass(c,parent,name,initfn);
+    rtl.initClass(c,parent,name,initfn,rttiname);
     if (isFunc){
       function f(){}
       f.prototype = c;