fcl-passrc: specialize non forward generic procedure

git-svn-id: trunk@43050 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -193,7 +193,7 @@ const
   nConstraintXSpecifiedMoreThanOnce = 3127;
   nConstraintXAndConstraintYCannotBeTogether = 3128;
   nXIsNotAValidConstraint = 3129;
-  nWrongNumberOfParametersForGenericType = 3130;
+  nWrongNumberOfParametersForGenericX = 3130;
   nGenericsWithoutSpecializationAsType = 3131;
   nDeclOfXDiffersFromPrevAtY = 3132;
   nTypeParamXIsMissingConstraintY = 3133;
@@ -342,7 +342,7 @@ resourcestring
   sConstraintXSpecifiedMoreThanOnce = 'Constraint "%s" specified more than once';
   sConstraintXAndConstraintYCannotBeTogether = '"%s" constraint and "%s" constraint cannot be specified together';
   sXIsNotAValidConstraint = '"%s" is not a valid constraint';
-  sWrongNumberOfParametersForGenericType = 'wrong number of parameters for generic type %s';
+  sWrongNumberOfParametersForGenericX = 'wrong number of parameters for generic %s';
   sGenericsWithoutSpecializationAsType = 'Generics without specialization cannot be used as a type for a %s';
   sDeclOfXDiffersFromPrevAtY = 'Declaration of "%s" differs from previous declaration at %s';
   sTypeParamXIsMissingConstraintY = 'Type parameter "%s" is missing constraint "%s"';
@@ -791,7 +791,7 @@ function CodePointToUnicodeString(u: longword): UnicodeString;
 
 function GetObjName(o: TObject): string;
 function GetObjPath(o: TObject): string;
-function GetTypeParamCommas(Cnt: integer): string;
+function GetGenericParamCommas(Cnt: integer): string;
 function dbgs(const Flags: TResEvalFlags): string; overload;
 function dbgs(v: TResEvalValue): string; overload;
 function LastPos(c: char; const s: string): sizeint;
@@ -1023,7 +1023,7 @@ begin
       GenType:=TPasGenericType(o);
       if (GenType.GenericTemplateTypes<>nil)
           and (GenType.GenericTemplateTypes.Count>0) then
-        Result:=Result+GetTypeParamCommas(GenType.GenericTemplateTypes.Count);
+        Result:=Result+GetGenericParamCommas(GenType.GenericTemplateTypes.Count);
       end;
     Result:=Result+':'+o.ClassName;
     end
@@ -1049,7 +1049,7 @@ begin
         GenType:=TPasGenericType(El);
         if (GenType.GenericTemplateTypes<>nil)
             and (GenType.GenericTemplateTypes.Count>0) then
-          Result:=GetTypeParamCommas(GenType.GenericTemplateTypes.Count)+Result;
+          Result:=GetGenericParamCommas(GenType.GenericTemplateTypes.Count)+Result;
         end;
       if El.Name<>'' then
         begin
@@ -1067,7 +1067,7 @@ begin
     Result:=GetObjName(o);
 end;
 
-function GetTypeParamCommas(Cnt: integer): string;
+function GetGenericParamCommas(Cnt: integer): string;
 begin
   if Cnt<=0 then
     Result:=''

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -1015,17 +1015,17 @@ function TPasAnalyzer.CanSkipGenericType(El: TPasGenericType): boolean;
   procedure RaiseHalfSpecialized;
   var
     GenScope: TPasGenericScope;
-    Item: TPSSpecializedItem;
+    Item: TPRSpecializedItem;
   begin
     if (El.GenericTemplateTypes<>nil) and (El.GenericTemplateTypes.Count>0) then
       RaiseNotSupported(20190817151437,El);
     if not (El.CustomData is TPasGenericScope) then
       RaiseNotSupported(20190826141320,El,GetObjName(El.CustomData));
     GenScope:=TPasGenericScope(El.CustomData);
-    Item:=GenScope.SpecializedItem;
+    Item:=GenScope.SpecializedFromItem;
     if Item=nil then
       RaiseNotSupported(20190826141352,El);
-    if Item.SpecializedType=nil then
+    if Item.SpecializedEl=nil then
       RaiseNotSupported(20190826141516,El);
     if Item.FirstSpecialize=nil then
       RaiseNotSupported(20190826141649,El);
@@ -2740,7 +2740,7 @@ begin
   else
     ImplProc:=ProcScope.ImplProc;
   if (ProcScope.ClassRecScope<>nil)
-      and (ProcScope.ClassRecScope.SpecializedItem<>nil) then
+      and (ProcScope.ClassRecScope.SpecializedFromItem<>nil) then
     exit; // specialized proc
 
   if not PAElementExists(DeclProc) then
@@ -3049,7 +3049,7 @@ begin
   if El is TPasGenericType then
     begin
     GenScope:=El.CustomData as TPasGenericScope;
-    if (GenScope<>nil) and (GenScope.SpecializedItem<>nil) then
+    if (GenScope<>nil) and (GenScope.SpecializedFromItem<>nil) then
       exit(true);
     end;
   Result:=false;

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -84,6 +84,7 @@ type
     procedure TestGen_Class_Self;
     procedure TestGen_Class_MemberTypeConstructor;
     procedure TestGen_Class_List;
+    // ToDo: different modeswitches at parse time and specialize time
 
     // generic external class
     procedure TestGen_ExtClass_Array;
@@ -104,6 +105,7 @@ type
     procedure TestGen_PointerDirectSpecializeFail;
 
     // ToDo: helpers for generics
+    // ToDo: default class prop array helper: arr<b>[c]
 
     // generic statements
     procedure TestGen_LocalVar;
@@ -114,20 +116,30 @@ type
     procedure TestGen_TryExcept;
     procedure TestGen_Call;
     procedure TestGen_NestedProc;
+    // ToDo: obj<b>[c]
 
     // generic functions
-    procedure TestGenProc_Function; // ToDo
-    //procedure TestGenProc_Forward; // ToDo
+    procedure TestGenProc_Function;
+    procedure TestGenProc_FunctionDelphi;
+    procedure TestGenProc_OverloadDuplicate;
+    procedure TestGenProc_Forward; // ToDo
+    //procedure TestGenProc_External;
+    //procedure TestGenProc_UnitIntf;
+    procedure TestGenProc_BackRef1Fail;
+    procedure TestGenProc_BackRef2Fail;
+    procedure TestGenProc_BackRef3Fail;
+    //procedure TestGenProc_Inference;
     // ToDo: forward parametrized impl must not repeat constraints
     // ToDo: forward parametrized impl overloads
     // ToDo: parametrized nested proc fail
-    // ToDo: generic class method overload <T> <S,T>
-    // ToDo: procedure TestGenMethod_ClassConstructorFail;
-    // ToDo: procedure TestGenMethod_NestedProc;
     // ToDo: virtual method cannot have type parameters
     // ToDo: message method cannot have type parameters
     // ToDo: interface method cannot have type parameters
     // ToDo: parametrized method mismatch interface method
+    // ToDo: generic class method overload <T> <S,T>
+    // ToDo: generic class method overload <T>(bool) <T>(word)
+    // ToDo: procedure TestGenMethod_ClassConstructorFail;
+    // ToDo: procedure TestGenMethod_NestedProc;
   end;
 
 implementation
@@ -1689,7 +1701,6 @@ end;
 
 procedure TTestResolveGenerics.TestGenProc_Function;
 begin
-  exit;
   StartProgram(false);
   Add([
   'generic function DoIt<T>(a: T): T;',
@@ -1700,11 +1711,101 @@ begin
   'end;',
   'var w: word;',
   'begin',
+  '  w:=specialize DoIt<word>(3);',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGenProc_FunctionDelphi;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'function DoIt<T>(a: T): T;',
+  'var i: T;',
+  'begin',
+  '  a:=i;',
+  '  Result:=a;',
+  'end;',
+  'var w: word;',
+  'begin',
   '  w:=DoIt<word>(3);',
   '']);
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGenProc_OverloadDuplicate;
+begin
+  StartProgram(false);
+  Add([
+  'generic procedure Fly<T>(a: T);',
+  'begin',
+  'end;',
+  'generic procedure Fly<T>(a: T);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('Duplicate identifier "Fly" at afile.pp(2,25)',nDuplicateIdentifier);
+end;
+
+procedure TTestResolveGenerics.TestGenProc_Forward;
+begin
+  exit;
+  StartProgram(false);
+  Add([
+  'generic procedure Fly<T>(a: T); forward;',
+  //'generic procedure Run;',
+  //'begin',
+  //'  specialize Fly<word>(3);',
+  //'end;',
+  'generic procedure Fly<T>(a: T);',
+  'var i: T;',
+  'begin',
+  '  i:=a;',
+  'end;',
+  'begin',
+  '  specialize Fly<boolean>(true);',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGenProc_BackRef1Fail;
+begin
+  StartProgram(false);
+  Add([
+  'generic function Fly<T>(a: Fly): T;',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('Wrong number of parameters specified for call to "function Fly<>(untyped)"',nWrongNumberOfParametersForCallTo);
+end;
+
+procedure TTestResolveGenerics.TestGenProc_BackRef2Fail;
+begin
+  StartProgram(false);
+  Add([
+  'generic function Fly<T>(a: Fly<word>): T;',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('Wrong number of parameters specified for call to "function Fly<>(untyped)"',nWrongNumberOfParametersForCallTo);
+end;
+
+procedure TTestResolveGenerics.TestGenProc_BackRef3Fail;
+begin
+  StartProgram(false);
+  Add([
+  'generic function Fly<T>(a: Fly<T>): T;',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('Wrong number of parameters specified for call to "function Fly<>(untyped)"',nWrongNumberOfParametersForCallTo);
+end;
+
 initialization
   RegisterTests([TTestResolveGenerics]);
 

packages/pastojs/tests/tcgenerics.pas

@@ -23,6 +23,7 @@ type
     Procedure TestGen_Class_TList;
     Procedure TestGen_ClassAncestor;
     Procedure TestGen_TypeInfo;
+    // ToDo: TBird, TBird<T>, TBird<S,T>
 
     // generic external class
     procedure TestGen_ExtClass_Array;
@@ -31,6 +32,14 @@ type
     Procedure TestGen_InlineSpec_Constructor;
     Procedure TestGen_CallUnitImplProc;
     Procedure TestGen_IntAssignTemplVar;
+    // ToDo: TBird<word>(o).field:=3;
+
+    // generic helper
+    // ToDo: helper for gen array: TArray<word>.Fly(aword);
+
+    // generic functions
+    // ToDo: Fly<word>(3);
+    // ToDo: inference Fly(3);
   end;
 
 implementation

utils/pas2js/dist/rtl.js

@@ -176,8 +176,7 @@ var rtl = {
 
   loaduseslist: function(module,useslist,f){
     if (useslist==undefined) return;
-    var len = useslist.length;
-    for (var i = 0; i<len; i++) {
+    for (var i in useslist){
       var unitname=useslist[i];
       if (rtl.debug_load_units) rtl.debug('loaduseslist of "'+module.$name+'" uses="'+unitname+'"');
       if (pas[unitname]==undefined)