Browse Source

# revisions: 43198,43199,43201,43202,43204,43206,43207,43209,43210,43212,43213,43214,43215,43216,43219,43220,43221,43222,43223,43224,43225,43228,43229,43285,43286,43287,43288,43295,43296,43297,43303,43304,43310,43316,43317,43318,43320,43321,43322,43323,43325,43326,43329,43330,43331,43332,43333

git-svn-id: branches/fixes_3_2@43380 -
marco 5 years ago
parent
commit
cf2b4ee4f7

+ 3 - 0
.gitattributes

@@ -7000,10 +7000,13 @@ packages/pastojs/src/pas2jsfileutilsunix.inc svneol=native#text/plain
 packages/pastojs/src/pas2jsfileutilswin.inc svneol=native#text/plain
 packages/pastojs/src/pas2jsfs.pp svneol=native#text/plain
 packages/pastojs/src/pas2jsfscompiler.pp svneol=native#text/plain
+packages/pastojs/src/pas2jshtmlresources.pp svneol=native#text/plain
+packages/pastojs/src/pas2jsjsresources.pp svneol=native#text/plain
 packages/pastojs/src/pas2jslibcompiler.pp svneol=native#text/plain
 packages/pastojs/src/pas2jslogger.pp svneol=native#text/plain
 packages/pastojs/src/pas2jspcucompiler.pp svneol=native#text/plain
 packages/pastojs/src/pas2jspparser.pp svneol=native#text/plain
+packages/pastojs/src/pas2jsresources.pp svneol=native#text/plain
 packages/pastojs/src/pas2jsresstrfile.pp svneol=native#text/plain
 packages/pastojs/src/pas2jsuseanalyzer.pp svneol=native#text/plain
 packages/pastojs/src/pas2jsutils.pp svneol=native#text/plain

+ 39 - 3
packages/fcl-passrc/src/pasresolveeval.pas

@@ -71,7 +71,7 @@ unit PasResolveEval;
 interface
 
 uses
-  Sysutils, Math, PasTree, PScanner;
+  Sysutils, Classes, Math, PasTree, PScanner;
 
 // message numbers
 const
@@ -106,7 +106,7 @@ const
   nTypesAreNotRelatedXY = 3029;
   nAbstractMethodsCannotBeCalledDirectly = 3030;
   nMissingParameterX = 3031;
-  nCannotAccessThisMemberFromAX = 3032;
+  nInstanceMemberXInaccessible = 3032;
   nInOperatorExpectsSetElementButGot = 3033;
   nWrongNumberOfParametersForTypeCast = 3034;
   nIllegalTypeConversionTo = 3035;
@@ -250,7 +250,7 @@ resourcestring
   sTypesAreNotRelatedXY = 'Types are not related: "%s" and "%s"';
   sAbstractMethodsCannotBeCalledDirectly = 'Abstract methods cannot be called directly';
   sMissingParameterX = 'Missing parameter %s';
-  sCannotAccessThisMemberFromAX = 'Cannot access this member from a %s';
+  sInstanceMemberXInaccessible = 'Instance member "%s" inaccessible here';
   sInOperatorExpectsSetElementButGot = 'the in-operator expects a set element, but got %s';
   sWrongNumberOfParametersForTypeCast = 'wrong number of parameters for type cast to %s';
   sIllegalTypeConversionTo = 'Illegal type conversion: "%s" to "%s"';
@@ -798,6 +798,8 @@ function CodePointToUnicodeString(u: longword): UnicodeString;
 function GetObjName(o: TObject): string;
 function GetObjPath(o: TObject): string;
 function GetGenericParamCommas(Cnt: integer): string;
+function GetElementNameAndParams(El: TPasElement; MaxLvl: integer = 3): string;
+function GetTypeParamNames(Templates: TFPList; MaxLvl: integer = 3): string;
 function dbgs(const Flags: TResEvalFlags): string; overload;
 function dbgs(v: TResEvalValue): string; overload;
 function LastPos(c: char; const s: string): sizeint;
@@ -1081,6 +1083,40 @@ begin
     Result:='<'+StringOfChar(',',Cnt-1)+'>';
 end;
 
+function GetElementNameAndParams(El: TPasElement; MaxLvl: integer): string;
+begin
+  if El=nil then
+    exit('(nil)');
+  Result:=El.Name;
+  if El is TPasGenericType then
+    Result:=Result+GetTypeParamNames(TPasGenericType(El).GenericTemplateTypes,MaxLvl-1);
+end;
+
+function GetTypeParamNames(Templates: TFPList; MaxLvl: integer): string;
+var
+  i: Integer;
+  El: TPasElement;
+begin
+  if (Templates=nil) or (Templates.Count=0) then
+    exit('');
+  if MaxLvl<=0 then
+    exit('...');
+  Result:='<';
+  for i:=0 to Templates.Count-1 do
+    begin
+    if i>0 then
+      Result:=Result+',';
+    El:=TPasElement(Templates[i]);
+    if El.Name<>'' then
+      Result:=Result+GetElementNameAndParams(El,MaxLvl-1)
+    else if El is TPasArrayType then
+      Result:=Result+'array...'
+    else
+      Result:=Result+'...';
+    end;
+  Result:=Result+'>';
+end;
+
 function dbgs(const Flags: TResEvalFlags): string;
 var
   s: string;

File diff suppressed because it is too large
+ 391 - 88
packages/fcl-passrc/src/pasresolver.pp


+ 4 - 0
packages/fcl-passrc/src/pastree.pp

@@ -848,6 +848,7 @@ type
     Args: TFPList;        // List of TPasArgument objects
     CallingConvention: TCallingConvention;
     Modifiers: TProcTypeModifiers;
+    VarArgsType: TPasType;
     property IsOfObject: Boolean read GetIsOfObject write SetIsOfObject;
     property IsNested : Boolean read GetIsNested write SetIsNested;
     property IsReferenceTo : Boolean Read GetIsReference write SetIsReference;
@@ -3501,6 +3502,7 @@ begin
   for i := 0 to Args.Count - 1 do
     TPasArgument(Args[i]).Release{$IFDEF CheckPasTreeRefCount}('TPasProcedureType.Args'){$ENDIF};
   FreeAndNil(Args);
+  ReleaseAndNil(TPasElement(VarArgsType){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
   inherited Destroy;
 end;
 
@@ -3526,6 +3528,7 @@ begin
   inherited ForEachCall(aMethodCall, Arg);
   for i:=0 to Args.Count-1 do
     ForEachChildCall(aMethodCall,Arg,TPasElement(Args[i]),false);
+  ForEachChildCall(aMethodCall,Arg,VarArgsType,false);
 end;
 
 { TPasResultElement }
@@ -4092,6 +4095,7 @@ procedure TPasAliasType.ForEachCall(const aMethodCall: TOnForEachPasElement;
 begin
   inherited ForEachCall(aMethodCall, Arg);
   ForEachChildCall(aMethodCall,Arg,DestType,true);
+  ForEachChildCall(aMethodCall,Arg,Expr,false);
 end;
 
 procedure TPasAliasType.ClearTypeReferences(aType: TPasElement);

+ 96 - 16
packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -55,7 +55,7 @@ uses
   {$else}
   AVL_Tree,
   {$endif}
-  Classes, SysUtils, Types,
+  Classes, SysUtils, Types, contnrs,
   PasTree, PScanner, PasResolveEval, PasResolver;
 
 const
@@ -253,6 +253,7 @@ type
     function ElementVisited(El: TPasElement; OtherCheck: TPAOtherCheckedEl): boolean; overload;
     procedure MarkImplScopeRef(El, RefEl: TPasElement; Access: TPSRefAccess);
     function CanSkipGenericType(El: TPasGenericType): boolean;
+    function CanSkipGenericProc(DeclProc: TPasProcedure): boolean;
     procedure UseElement(El: TPasElement; Access: TResolvedRefAccess;
       UseFull: boolean); virtual;
     procedure UseTypeInfo(El: TPasElement); virtual;
@@ -1043,7 +1044,7 @@ begin
   else
     begin
     // analyze a module
-    if ((El.GenericTemplateTypes<>nil) and (El.GenericTemplateTypes.Count>0)) then
+    if (El.GenericTemplateTypes<>nil) and (El.GenericTemplateTypes.Count>0) then
       // generic template -> analyze
     else if not Resolver.IsFullySpecialized(El) then
       // half specialized -> skip
@@ -1051,6 +1052,52 @@ begin
     end;
 end;
 
+function TPasAnalyzer.CanSkipGenericProc(DeclProc: TPasProcedure): boolean;
+
+  procedure RaiseHalfSpecialized;
+  var
+    Templates: TFPList;
+    ProcScope: TPasProcedureScope;
+    Item: TPRSpecializedItem;
+  begin
+    Templates:=Resolver.GetProcTemplateTypes(DeclProc);
+    if (Templates<>nil) and (Templates.Count>0) then
+      RaiseNotSupported(20191016132828,DeclProc);
+    if not (DeclProc.CustomData is TPasProcedureScope) then
+      RaiseNotSupported(20191016132836,DeclProc,GetObjName(DeclProc.CustomData));
+    ProcScope:=TPasProcedureScope(DeclProc.CustomData);
+    Item:=ProcScope.SpecializedFromItem;
+    if Item=nil then
+      RaiseNotSupported(20191016133013,DeclProc);
+    if Item.SpecializedEl=nil then
+      RaiseNotSupported(20191016133017,DeclProc);
+    if Item.FirstSpecialize=nil then
+      RaiseNotSupported(20191016133019,DeclProc);
+    RaiseNotSupported(20191016133022,DeclProc,'SpecializedAt:'+GetObjPath(Item.FirstSpecialize)+' '+Resolver.GetElementSourcePosStr(Item.FirstSpecialize));
+  end;
+
+var
+  Templates: TFPList;
+begin
+  Result:=false;
+  if ScopeModule=nil then
+    begin
+    // analyze whole program
+    if not Resolver.IsFullySpecialized(DeclProc) then
+      RaiseHalfSpecialized;
+    end
+  else
+    begin
+    // analyze a module
+    Templates:=Resolver.GetProcTemplateTypes(DeclProc);
+    if (Templates<>nil) and (Templates.Count>0) then
+      // generic template -> analyze
+    else if not Resolver.IsFullySpecialized(DeclProc) then
+      // half specialized -> skip
+      exit(true);
+    end;
+end;
+
 procedure TPasAnalyzer.UseElement(El: TPasElement; Access: TResolvedRefAccess;
   UseFull: boolean);
 var
@@ -1357,7 +1404,10 @@ begin
       UseVariable(TPasVariable(Decl),rraNone,true);
       end
     else if C=TPasResString then
-      UseResourcestring(TPasResString(Decl))
+      begin
+      if OnlyExports then continue;
+      UseResourcestring(TPasResString(Decl));
+      end
     else if C=TPasAttributes then
       // attributes are never used directly
     else
@@ -1864,6 +1914,7 @@ begin
   ProcScope:=Proc.CustomData as TPasProcedureScope;
   if ProcScope.DeclarationProc<>nil then
     exit; // skip implementation, Note:PasResolver always refers the declaration
+  if CanSkipGenericProc(Proc) then exit;
 
   if not MarkElementAsUsed(Proc) then exit;
   {$IFDEF VerbosePasAnalyzer}
@@ -1932,7 +1983,7 @@ begin
   writeln('TPasAnalyzer.UseProcedureType ',GetElModName(ProcType));
   {$ENDIF}
   if not MarkElementAsUsed(ProcType) then exit;
-  if (ScopeModule=nil) and not Resolver.IsFullySpecialized(ProcType) then
+  if CanSkipGenericType(ProcType) then
     RaiseNotSupported(20190817151651,ProcType);
 
   for i:=0 to ProcType.Args.Count-1 do
@@ -2630,8 +2681,10 @@ var
   C: TClass;
   Usage: TPAElement;
   i: Integer;
-  Member: TPasElement;
+  Member, SpecEl: TPasElement;
   Members: TFPList;
+  GenScope: TPasGenericScope;
+  SpecializedItems: TObjectList;
 begin
   {$IFDEF VerbosePasAnalyzer}
   writeln('TPasAnalyzer.EmitTypeHints ',GetElModName(El));
@@ -2640,6 +2693,21 @@ begin
   if Usage=nil then
     begin
     // the whole type was never used
+    if IsSpecializedGenericType(El) then
+      exit; // no hints for not used specializations
+    if (El.CustomData is TPasGenericScope) then
+      begin
+      GenScope:=TPasGenericScope(El.CustomData);
+      SpecializedItems:=GenScope.SpecializedItems;
+      if SpecializedItems<>nil then
+        for i:=0 to SpecializedItems.Count-1 do
+          begin
+          SpecEl:=TPRSpecializedItem(SpecializedItems[i]).SpecializedEl;
+          if FindElement(SpecEl)<>nil then
+            exit; // a specialization of this generic type is used
+          end;
+      end;
+
     if (El.Visibility in [visPrivate,visStrictPrivate]) then
       EmitMessage(20170312000020,mtHint,nPAPrivateTypeXNeverUsed,
         sPAPrivateTypeXNeverUsed,[El.FullName],El)
@@ -2647,10 +2715,9 @@ begin
       begin
       if (El is TPasClassType) and (TPasClassType(El).ObjKind=okInterface) then
         exit;
-      if IsSpecializedGenericType(El) then exit;
 
       EmitMessage(20170312000025,mtHint,nPALocalXYNotUsed,
-        sPALocalXYNotUsed,[El.ElementTypeName,El.Name],El);
+        sPALocalXYNotUsed,[El.ElementTypeName,GetElementNameAndParams(El)],El);
       end;
     exit;
     end;
@@ -2726,6 +2793,8 @@ var
   Usage: TPAElement;
   ProcScope: TPasProcedureScope;
   DeclProc, ImplProc: TPasProcedure;
+  SpecializedItems: TObjectList;
+  SpecEl: TPasElement;
 begin
   {$IFDEF VerbosePasAnalyzer}
   writeln('TPasAnalyzer.EmitProcedureHints ',GetElModName(El));
@@ -2746,15 +2815,26 @@ begin
   if not PAElementExists(DeclProc) then
     begin
     // procedure never used
-    if ProcScope.DeclarationProc=nil then
-      begin
-      if El.Visibility in [visPrivate,visStrictPrivate] then
-        EmitMessage(20170312093348,mtHint,nPAPrivateMethodIsNeverUsed,
-          sPAPrivateMethodIsNeverUsed,[El.FullName],El)
-      else
-        EmitMessage(20170312093418,mtHint,nPALocalXYNotUsed,
-          sPALocalXYNotUsed,[El.ElementTypeName,El.Name],El);
-      end;
+    if ProcScope.DeclarationProc<>nil then
+      exit;
+
+    if ProcScope.SpecializedFromItem<>nil then
+      exit; // no hint for not used specialized procedure
+    SpecializedItems:=ProcScope.SpecializedItems;
+    if SpecializedItems<>nil then
+      for i:=0 to SpecializedItems.Count-1 do
+        begin
+        SpecEl:=TPRSpecializedItem(SpecializedItems[i]).SpecializedEl;
+        if FindElement(SpecEl)<>nil then
+          exit; // a specialization of this generic procedure is used
+        end;
+
+    if El.Visibility in [visPrivate,visStrictPrivate] then
+      EmitMessage(20170312093348,mtHint,nPAPrivateMethodIsNeverUsed,
+        sPAPrivateMethodIsNeverUsed,[El.FullName],El)
+    else
+      EmitMessage(20170312093418,mtHint,nPALocalXYNotUsed,
+        sPALocalXYNotUsed,[El.ElementTypeName,El.Name],El);
     exit;
     end;
 

+ 168 - 113
packages/fcl-passrc/src/pparser.pp

@@ -410,7 +410,7 @@ type
     function ArrayExprToText(Expr: TPasExprArray): String;
     // Type declarations
     function ResolveTypeReference(Name: string; Parent: TPasElement; ParamCnt: integer = 0): TPasType;
-    function ParseComplexType(Parent : TPasElement = Nil): TPasType;
+    function ParseVarType(Parent : TPasElement = Nil): TPasType;
     function ParseTypeDecl(Parent: TPasElement): TPasType;
     function ParseGenericTypeDecl(Parent: TPasElement; AddToParent: boolean): TPasGenericType;
     function ParseType(Parent: TPasElement; const NamePos: TPasSourcePos; const TypeName: String = ''; Full: Boolean = false): TPasType;
@@ -420,7 +420,7 @@ type
     function ParseSimpleType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; IsFull : Boolean = False): TPasType;
     function ParseAliasType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String): TPasType;
     function ParseTypeReference(Parent: TPasElement; NeedExpr: boolean; out Expr: TPasExpr): TPasType;
-    function ParseSpecializeType(Parent: TPasElement; const TypeName, GenName: string; var GenNameExpr: TPasExpr): TPasSpecializeType;
+    function ParseSpecializeType(Parent: TPasElement; Const NamePos: TPasSourcePos; const TypeName, GenName: string; var GenNameExpr: TPasExpr): TPasSpecializeType;
     function ParsePointerType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String): TPasPointerType;
     Function ParseArrayType(Parent : TPasElement; Const NamePos: TPasSourcePos; Const TypeName : String; PackMode : TPackMode) : TPasArrayType;
     Function ParseFileType(Parent : TPasElement; Const NamePos: TPasSourcePos; Const TypeName  : String) : TPasFileType;
@@ -530,6 +530,79 @@ type
   TDeclType = (declNone, declConst, declResourcestring, declType,
                declVar, declThreadvar, declProperty, declExports);
 
+{$IF FPC_FULLVERSION<30301}
+Function SplitCommandLine(S: String) : TStringDynArray;
+
+  Function GetNextWord : String;
+
+  Const
+    WhiteSpace = [' ',#9,#10,#13];
+    Literals = ['"',''''];
+
+  Var
+    Wstart,wend : Integer;
+    InLiteral : Boolean;
+    LastLiteral : Char;
+
+    Procedure AppendToResult;
+
+    begin
+      Result:=Result+Copy(S,WStart,WEnd-WStart);
+      WStart:=Wend+1;
+    end;
+
+  begin
+    Result:='';
+    WStart:=1;
+    While (WStart<=Length(S)) and charinset(S[WStart],WhiteSpace) do
+      Inc(WStart);
+    WEnd:=WStart;
+    InLiteral:=False;
+    LastLiteral:=#0;
+    While (Wend<=Length(S)) and (Not charinset(S[Wend],WhiteSpace) or InLiteral) do
+      begin
+      if charinset(S[Wend],Literals) then
+        If InLiteral then
+          begin
+          InLiteral:=Not (S[Wend]=LastLiteral);
+          if not InLiteral then
+            AppendToResult;
+          end
+        else
+          begin
+          InLiteral:=True;
+          LastLiteral:=S[Wend];
+          AppendToResult;
+          end;
+       inc(wend);
+       end;
+     AppendToResult;
+     While (WEnd<=Length(S)) and (S[Wend] in WhiteSpace) do
+       inc(Wend);
+     Delete(S,1,WEnd-1);
+  end;
+
+Var
+  W : String;
+  len : Integer;
+
+begin
+  Len:=0;
+  Result:=Default(TStringDynArray);
+  SetLength(Result,(Length(S) div 2)+1);
+  While Length(S)>0 do
+    begin
+    W:=GetNextWord;
+    If (W<>'') then
+      begin
+      Result[Len]:=W;
+      Inc(Len);
+      end;
+    end;
+  SetLength(Result,Len);
+end;
+{$ENDIF}
+
 Function IsHintToken(T : String; Out AHint : TPasMemberHint) : boolean;
 
 Const
@@ -610,96 +683,27 @@ end;
 
 function ParseSource(AEngine: TPasTreeContainer;
   const FPCCommandLine, OSTarget, CPUTarget: String): TPasModule;
-
+var
+  FPCParams: TStringDynArray;
 begin
-  Result:=ParseSource(AEngine,FPCCommandLine, OSTarget, CPUTarget,[]);
+  FPCParams:=SplitCommandLine(FPCCommandLine);
+  Result:=ParseSource(AEngine, FPCParams, OSTarget, CPUTarget,[]);
 end;
 
 {$ifdef HasStreams}
 function ParseSource(AEngine: TPasTreeContainer;
   const FPCCommandLine, OSTarget, CPUTarget: String; UseStreams : Boolean): TPasModule;
-
+var
+  FPCParams: TStringDynArray;
 begin
+  FPCParams:=SplitCommandLine(FPCCommandLine);
   if UseStreams then
-    Result:=ParseSource(AEngine,FPCCommandLine, OSTarget, CPUTarget,[poUseStreams])
+    Result:=ParseSource(AEngine,FPCParams, OSTarget, CPUTarget,[poUseStreams])
   else
-    Result:=ParseSource(AEngine,FPCCommandLine, OSTarget, CPUTarget,[]);
+    Result:=ParseSource(AEngine,FPCParams, OSTarget, CPUTarget,[]);
 end;
 {$endif}
 
-{$IF FPC_FULLVERSION<30301}
-Function SplitCommandLine(S: String) : TStringDynArray;
-
-  Function GetNextWord : String;
-
-  Const
-    WhiteSpace = [' ',#9,#10,#13];
-    Literals = ['"',''''];
-
-  Var
-    Wstart,wend : Integer;
-    InLiteral : Boolean;
-    LastLiteral : Char;
-
-    Procedure AppendToResult;
-
-    begin
-      Result:=Result+Copy(S,WStart,WEnd-WStart);
-      WStart:=Wend+1;
-    end;
-
-  begin
-    Result:='';
-    WStart:=1;
-    While (WStart<=Length(S)) and charinset(S[WStart],WhiteSpace) do
-      Inc(WStart);
-    WEnd:=WStart;
-    InLiteral:=False;
-    LastLiteral:=#0;
-    While (Wend<=Length(S)) and (Not charinset(S[Wend],WhiteSpace) or InLiteral) do
-      begin
-      if charinset(S[Wend],Literals) then
-        If InLiteral then
-          begin
-          InLiteral:=Not (S[Wend]=LastLiteral);
-          if not InLiteral then
-            AppendToResult;
-          end
-        else
-          begin
-          InLiteral:=True;
-          LastLiteral:=S[Wend];
-          AppendToResult;
-          end;
-       inc(wend);
-       end;
-     AppendToResult;
-     While (WEnd<=Length(S)) and (S[Wend] in WhiteSpace) do
-       inc(Wend);
-     Delete(S,1,WEnd-1);
-  end;
-
-Var
-  W : String;
-  len : Integer;
-
-begin
-  Len:=0;
-  Result:=Default(TStringDynArray);
-  SetLength(Result,(Length(S) div 2)+1);
-  While Length(S)>0 do
-    begin
-    W:=GetNextWord;
-    If (W<>'') then
-      begin
-      Result[Len]:=W;
-      Inc(Len);
-      end;
-    end;
-  SetLength(Result,Len);
-end;
-{$ENDIF}
-
 function ParseSource(AEngine: TPasTreeContainer;
   const FPCCommandLine, OSTarget, CPUTarget: String;
   Options : TParseSourceOptions): TPasModule;
@@ -1500,10 +1504,11 @@ begin
       begin
       Params:=TParamsExpr(CreateElement(TParamsExpr,'',Result));
       Params.Value:=Result.Expr;
+      Params.Value.Parent:=Params;
       Result.Expr:=Params;
       LengthAsText:='';
       NextToken;
-      LengthExpr:=DoParseExpression(Result,nil,false);
+      LengthExpr:=DoParseExpression(Params,nil,false);
       Params.AddParam(LengthExpr);
       CheckToken(tkSquaredBraceClose);
       LengthAsText:=ExprToText(LengthExpr);
@@ -1580,7 +1585,7 @@ begin
     else if (CurToken = tkLessThan)
         and (MustBeSpecialize or (msDelphi in CurrentModeswitches)) then // A = B<t>;
       begin
-      Result:=ParseSpecializeType(Parent,TypeName,Name,Expr);
+      Result:=ParseSpecializeType(Parent,NamePos,TypeName,Name,Expr);
       ok:=true;
       exit;
       end
@@ -1672,11 +1677,13 @@ function TPasParser.ParseTypeReference(Parent: TPasElement; NeedExpr: boolean;
 var
   Name: String;
   IsSpecialize, ok: Boolean;
+  NamePos: TPasSourcePos;
 begin
   Result:=nil;
   Expr:=nil;
   ok:=false;
   try
+    NamePos:=CurSourcePos;
     if CurToken=tkspecialize then
       begin
       IsSpecialize:=true;
@@ -1693,9 +1700,11 @@ begin
       // specialize
       if IsSpecialize or (msDelphi in CurrentModeswitches) then
         begin
-        Result:=ParseSpecializeType(Parent,'',Name,Expr);
+        Result:=ParseSpecializeType(Parent,NamePos,'',Name,Expr);
         NextToken;
-        end;
+        end
+      else
+        CheckToken(tkend);
       end
     else if IsSpecialize then
       CheckToken(tkLessThan)
@@ -1717,8 +1726,9 @@ begin
   end;
 end;
 
-function TPasParser.ParseSpecializeType(Parent: TPasElement; const TypeName,
-  GenName: string; var GenNameExpr: TPasExpr): TPasSpecializeType;
+function TPasParser.ParseSpecializeType(Parent: TPasElement;
+  const NamePos: TPasSourcePos; const TypeName, GenName: string;
+  var GenNameExpr: TPasExpr): TPasSpecializeType;
 // after parsing CurToken is at >
 var
   ST: TPasSpecializeType;
@@ -1726,7 +1736,7 @@ begin
   Result:=nil;
   if CurToken<>tkLessThan then
     ParseExcTokenError('[20190801112729]');
-  ST:=TPasSpecializeType(CreateElement(TPasSpecializeType,TypeName,Parent));
+  ST:=TPasSpecializeType(CreateElement(TPasSpecializeType,TypeName,Parent,NamePos));
   try
     if GenNameExpr<>nil then
       begin
@@ -1992,7 +2002,9 @@ begin
   Result.IsReferenceTo:=True;
 end;
 
-function TPasParser.ParseComplexType(Parent : TPasElement = Nil): TPasType;
+function TPasParser.ParseVarType(Parent : TPasElement = Nil): TPasType;
+var
+  NamePos: TPasSourcePos;
 begin
   NextToken;
   case CurToken of
@@ -2011,8 +2023,9 @@ begin
           UngetToken;        // Unget semicolon
       end;
   else
+    NamePos:=CurSourcePos;
     UngetToken;
-    Result := ParseType(Parent,CurSourcePos);
+    Result := ParseType(Parent,NamePos);
   end;
 end;
 
@@ -2404,6 +2417,7 @@ begin
       try
         ProcExpr:=TProcedureExpr(CreateElement(TProcedureExpr,'',AParent,visPublic));
         ProcExpr.Proc:=TPasAnonymousProcedure(ParseProcedureOrFunctionDecl(ProcExpr,ProcType,false));
+        Engine.FinishScope(stProcedure,ProcExpr.Proc);
         Result:=ProcExpr;
       finally
         if Result=nil then
@@ -2413,16 +2427,15 @@ begin
       end;
     tkCaret:
       begin
-      // is this still needed?
-      // ^A..^_ characters. See #16341
+      // Why is this still needed?
+      // ^A..^_ characters
       NextToken;
       if not (length(CurTokenText)=1) or not (CurTokenText[1] in ['A'..'_']) then
         begin
         UngetToken;
         ParseExcExpectedIdentifier;
         end;
-      Result:=CreatePrimitiveExpr(AParent,pekString, '^'+CurTokenText);
-      exit;
+      Last:=CreatePrimitiveExpr(AParent,pekString, '^'+CurTokenText);
       end;
     tkBraceOpen:
       begin
@@ -2947,6 +2960,7 @@ begin
       Functions.Add(AProc);
       end;
     end;
+  Engine.FinishScope(stProcedure,AProc);
 end;
 
 // Return the parent of a function declaration. This is AParent,
@@ -3546,13 +3560,9 @@ begin
       SetBlock(declNone);
       SaveComments;
       NextToken;
-      If CurToken in [tkprocedure,tkFunction,tkConstructor,tkDestructor] then
-        begin
-        pt:=GetProcTypeFromToken(CurToken,True);
-        AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt, MustBeGeneric));
-        end
-      else
-        CheckToken(tkprocedure);
+      CheckTokens([tkprocedure,tkFunction,tkConstructor,tkDestructor,tkoperator]);
+      pt:=GetProcTypeFromToken(CurToken,True);
+      AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt, MustBeGeneric));
       end;
     tkIdentifier:
       begin
@@ -3667,7 +3677,7 @@ begin
     tkGeneric:
       begin
       NextToken;
-      if (CurToken in [tkprocedure,tkfunction]) then
+      if (CurToken in [tkclass,tkprocedure,tkfunction]) then
         begin
         if msDelphi in CurrentModeswitches then
           ParseExcSyntaxError; // inconsistency, tkGeneric should be in Scanner.NonTokens
@@ -4614,14 +4624,15 @@ begin
                                         AVisibility,CurTokenPos));
       VarList.Add(VarEl);
       NextToken;
-      if Not (CurToken in [tkComma,tkColon]) then
-        ParseExc(nParserExpectedCommaColon,SParserExpectedCommaColon);
-      if CurToken=tkComma then
-        ExpectIdentifier;
+      case CurToken of
+      tkColon: break;
+      tkComma: ExpectIdentifier;
+      else     ParseExc(nParserExpectedCommaColon,SParserExpectedCommaColon);
+      end;
     Until (CurToken=tkColon);
     OldForceCaret:=Scanner.SetForceCaret(True);
     try
-      VarType := ParseComplexType(VarEl);
+      VarType := ParseVarType(VarEl);
       {$IFDEF CheckPasTreeRefCount}if VarType.RefIds.IndexOf('CreateElement')>=0 then VarType.ChangeRefId('CreateElement','TPasVariable.VarType'){$ENDIF};
     finally
       Scanner.SetForceCaret(OldForceCaret);
@@ -5102,10 +5113,28 @@ end;
 
 procedure TPasParser.HandleProcedureTypeModifier(ProcType: TPasProcedureType;
   ptm: TProcTypeModifier);
+var
+  Expr: TPasExpr;
 begin
   if ptm in ProcType.Modifiers then
     ParseExcSyntaxError;
   Include(ProcType.Modifiers,ptm);
+  if ptm=ptmVarargs then
+    begin
+    NextToken;
+    if CurToken<>tkof then
+      begin
+      UngetToken;
+      exit;
+      end;
+    NextToken;
+    Expr:=nil;
+    try
+      ProcType.VarArgsType:=ParseTypeReference(ProcType,false,Expr);
+    finally
+      if Expr<>nil then Expr.Release{$IFDEF CheckPasTreeRefCount}('20191029145019'){$ENDIF};
+    end;
+    end;
 end;
 
 // Next token is expected to be a "(", ";" or for a function ":". The caller
@@ -5398,8 +5427,6 @@ begin
      or IsAnonymous)
   then
     ParseProcedureBody(Parent);
-  if not IsProcType then
-    Engine.FinishScope(stProcedure,Parent);
 end;
 
 // starts after the semicolon
@@ -6498,12 +6525,14 @@ var
   end;
 
 var
-  Name: String;
+  N,Name: String;
   PC : TPTreeElement;
   Ot : TOperatorType;
   IsTokenBased , ok: Boolean;
   j, i: Integer;
+
 begin
+  N:='';
   NameParts:=nil;
   Result:=nil;
   ok:=false;
@@ -6518,10 +6547,28 @@ begin
       if IsTokenBased then
         OT:=TPasOperator.TokenToOperatorType(CurTokenText)
       else
+        begin
         OT:=TPasOperator.NameToOperatorType(CurTokenString);
+        N:=CurTokenString;
+        // Case Class operator TMyRecord.+
+        if (OT=otUnknown) then
+          begin
+          NextToken;
+          if CurToken<>tkDot then
+            ParseExc(nErrUnknownOperatorType,SErrUnknownOperatorType,[N]);
+          NextToken;
+          IsTokenBased:=CurToken<>tkIdentifier;
+          if IsTokenBased then
+            OT:=TPasOperator.TokenToOperatorType(CurTokenText)
+          else
+            OT:=TPasOperator.NameToOperatorType(CurTokenString);
+          end;
+        end;
       if (ot=otUnknown) then
         ParseExc(nErrUnknownOperatorType,SErrUnknownOperatorType,[CurTokenString]);
       Name:=OperatorNames[Ot];
+      if N<>'' then
+        Name:=N+'.'+Name;
       NamePos:=CurTokenPos;
       end;
     ptAnonymousProcedure,ptAnonymousFunction:
@@ -6696,8 +6743,10 @@ Var
   OldCount, i: Integer;
   CurEl: TPasElement;
   LastToken: TToken;
+  AllowVisibility: Boolean;
 begin
-  if AllowMethods then
+  AllowVisibility:=msAdvancedRecords in CurrentModeswitches;
+  if AllowVisibility then
     v:=visPublic
   else
     v:=visDefault;
@@ -6780,13 +6829,14 @@ begin
           TPasOverloadedProc(Proc.Parent).Overloads.Add(Proc)
         else
           ARec.Members.Add(Proc);
+        Engine.FinishScope(stProcedure,Proc);
         end;
       tkDestructor:
         ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
       tkGeneric,tkSelf, // Counts as field name
       tkIdentifier :
         begin
-        If AllowMethods and CheckVisibility(CurTokenString,v) then
+        If AllowVisibility and CheckVisibility(CurTokenString,v) then
           begin
           if not (v in [visPrivate,visPublic,visStrictPrivate]) then
             ParseExc(nParserInvalidRecordVisibility,SParserInvalidRecordVisibility);
@@ -6849,14 +6899,18 @@ function TPasParser.ParseRecordDecl(Parent: TPasElement;
 
 var
   ok: Boolean;
+  allowadvanced : Boolean;
+
 begin
   Result := TPasRecordType(CreateElement(TPasRecordType, TypeName, Parent, NamePos));
   ok:=false;
   try
     Result.PackMode:=PackMode;
     NextToken;
-    ParseRecordMembers(Result,tkEnd,
-      (msAdvancedRecords in Scanner.CurrentModeSwitches) and not (Parent is TProcedureBody));
+    allowAdvanced:=(msAdvancedRecords in Scanner.CurrentModeSwitches)
+                   and not (Parent is TProcedureBody)
+                   and (Result.Name<>'');
+    ParseRecordMembers(Result,tkEnd,allowAdvanced);
     Engine.FinishScope(stTypeDef,Result);
     ok:=true;
   finally
@@ -6934,6 +6988,7 @@ begin
     TPasOverloadedProc(Proc.Parent).Overloads.Add(Proc)
   else
     AType.Members.Add(Proc);
+  Engine.FinishScope(stProcedure,Proc);
 end;
 
 procedure TPasParser.ParseClassFields(AType: TPasClassType;

+ 274 - 39
packages/fcl-passrc/src/pscanner.pp

@@ -80,12 +80,16 @@ const
   nMisplacedGlobalCompilerSwitch = 1029;
   nLogMacroXSetToY = 1030;
   nInvalidDispatchFieldName = 1031;
+  nErrWrongSwitchToggle = 1032;
+  nNoResourceSupport = 1033;
+  nResourceFileNotFound = 1034;
 
 // resourcestring patterns of messages
 resourcestring
   SErrInvalidCharacter = 'Invalid character ''%s''';
   SErrOpenString = 'string exceeds end of line';
   SErrIncludeFileNotFound = 'Could not find include file ''%s''';
+  SErrResourceFileNotFound = 'Could not find resource file ''%s''';
   SErrIfXXXNestingLimitReached = 'Nesting of $IFxxx too deep';
   SErrInvalidPPElse = '$ELSE without matching $IFxxx';
   SErrInvalidPPEndif = '$ENDIF without matching $IFxxx';
@@ -116,6 +120,8 @@ resourcestring
   SMisplacedGlobalCompilerSwitch = 'Misplaced global compiler switch, ignored';
   SLogMacroXSetToY = 'Macro %s set to %s';
   SInvalidDispatchFieldName = 'Invalid Dispatch field name';
+  SErrWrongSwitchToggle = 'Wrong switch toggle, use ON/OFF or +/-';
+  SNoResourceSupport = 'No support for resources of type "%s"';
 
 type
   TMessageType = (
@@ -138,7 +144,7 @@ type
     tkIdentifier,
     tkString,
     tkNumber,
-    tkChar,
+    tkChar, // ^A .. ^Z
     // Simple (one-character) tokens
     tkBraceOpen,             // '('
     tkBraceClose,            // ')'
@@ -495,6 +501,7 @@ type
   TBaseFileResolver = class
   private
     FBaseDirectory: string;
+    FResourcePaths,
     FIncludePaths: TStringList;
     FStrictFileCase : Boolean;
   Protected
@@ -502,10 +509,13 @@ type
     procedure SetBaseDirectory(AValue: string); virtual;
     procedure SetStrictFileCase(AValue: Boolean); virtual;
     Property IncludePaths: TStringList Read FIncludePaths;
+    Property ResourcePaths: TStringList Read FResourcePaths;
   public
     constructor Create; virtual;
     destructor Destroy; override;
     procedure AddIncludePath(const APath: string); virtual;
+    procedure AddResourcePath(const APath: string); virtual;
+    function FindResourceFileName(const AName: string): String; virtual; abstract;
     function FindSourceFile(const AName: string): TLineReader; virtual; abstract;
     function FindIncludeFile(const AName: string): TLineReader; virtual; abstract;
     Property StrictFileCase : Boolean Read FStrictFileCase Write SetStrictFileCase;
@@ -522,9 +532,11 @@ type
     FUseStreams: Boolean;
     {$endif}
   Protected
+    function SearchLowUpCase(FN: string): string;
     Function FindIncludeFileName(const AName: string): String; override;
     Function CreateFileReader(Const AFileName : String) : TLineReader; virtual;
   Public
+    function FindResourceFileName(const AFileName: string): String; override;
     function FindSourceFile(const AName: string): TLineReader; override;
     function FindIncludeFile(const AName: string): TLineReader; override;
     {$ifdef HasStreams}
@@ -549,6 +561,7 @@ type
     constructor Create; override;
     destructor Destroy; override;
     Procedure Clear;
+    function FindResourceFileName(const AFileName: string): String; override;
     Procedure AddStream(Const AName : String; AStream : TStream);
     function FindSourceFile(const AName: string): TLineReader; override;
     function FindIncludeFile(const AName: string): TLineReader; override;
@@ -676,11 +689,18 @@ type
   TPScannerWarnEvent = procedure(Sender: TObject; Identifier: string; State: TWarnMsgState; var Handled: boolean) of object;
   TPScannerModeDirective = procedure(Sender: TObject; NewMode: TModeSwitch; Before: boolean; var Handled: boolean) of object;
 
+  // aFileName: full filename (search is already done) aOptions: list of name:value pairs.
+  TResourceHandler = Procedure (Sender : TObject; const aFileName : String; aOptions : TStrings) of object;
+
   TPasScannerTokenPos = {$ifdef UsePChar}PChar{$else}integer{$endif};
 
   TPascalScanner = class
   private
     type
+      TResourceHandlerRecord = record
+        Ext : String;
+        Handler : TResourceHandler;
+      end;
       TWarnMsgNumberState = record
         Number: integer;
         State: TWarnMsgState;
@@ -734,6 +754,7 @@ type
     FIncludeStack: TFPList;
     FFiles: TStrings;
     FWarnMsgStates: TWarnMsgNumberStateArr;
+    FResourceHandlers : Array of TResourceHandlerRecord;
 
     // Preprocessor $IFxxx skipping data
     PPSkipMode: TPascalScannerPPSkipMode;
@@ -761,6 +782,9 @@ type
     procedure SetReadOnlyModeSwitches(const AValue: TModeSwitches);
     procedure SetReadOnlyValueSwitches(const AValue: TValueSwitches);
   protected
+    // extension without initial dot (.)
+    Function IndexOfResourceHandler(Const aExt : string) : Integer;
+    Function FindResourceHandler(Const aExt : string) : TResourceHandler;
     function ReadIdentifier(const AParam: string): string;
     function FetchLine: boolean;
     procedure AddFile(aFilename: string); virtual;
@@ -788,7 +812,10 @@ type
     procedure HandleError(Param: String); virtual;
     procedure HandleMessageDirective(Param: String); virtual;
     procedure HandleIncludeFile(Param: String); virtual;
+    procedure HandleResource(Param : string); virtual;
+
     procedure HandleUnDefine(Param: String); virtual;
+
     function HandleInclude(const Param: String): TToken; virtual;
     procedure HandleMode(const Param: String); virtual;
     procedure HandleModeSwitch(const Param: String); virtual;
@@ -813,6 +840,9 @@ type
   public
     constructor Create(AFileResolver: TBaseFileResolver);
     destructor Destroy; override;
+    // extension without initial dot  (.), case insensitive
+    Procedure RegisterResourceHandler(aExtension : String; aHandler : TResourceHandler); overload;
+    Procedure RegisterResourceHandler(aExtensions : Array of String; aHandler : TResourceHandler); overload;
     procedure OpenFile(AFilename: string);
     procedure FinishedModule; virtual; // called by parser after end.
     function FormatPath(const aFilename: string): string; virtual;
@@ -2426,10 +2456,12 @@ constructor TBaseFileResolver.Create;
 begin
   inherited Create;
   FIncludePaths := TStringList.Create;
+  FResourcePaths := TStringList.Create;
 end;
 
 destructor TBaseFileResolver.Destroy;
 begin
+  FResourcePaths.Free;
   FIncludePaths.Free;
   inherited Destroy;
 end;
@@ -2453,35 +2485,56 @@ begin
     end;
 end;
 
+procedure TBaseFileResolver.AddResourcePath(const APath: string);
+Var
+  FP : String;
+
+begin
+  if (APath='') then
+    FResourcePaths.Add('./')
+  else
+    begin
+{$IFDEF HASFS}
+    FP:=IncludeTrailingPathDelimiter(ExpandFileName(APath));
+{$ELSE}
+    FP:=APath;
+{$ENDIF}
+    FResourcePaths.Add(FP);
+    end;
+end;
+
+
 {$IFDEF HASFS}
 
 { ---------------------------------------------------------------------
   TFileResolver
   ---------------------------------------------------------------------}
 
-function TFileResolver.FindIncludeFileName(const AName: string): String;
 
-  function SearchLowUpCase(FN: string): string;
+function TFileResolver.SearchLowUpCase(FN: string): string;
 
-  var
-    Dir: String;
+var
+  Dir: String;
+
+begin
+  If FileExists(FN) then
+    Result:=FN
+  else if StrictFileCase then
+    Result:=''
+  else
+    begin
+    Dir:=ExtractFilePath(FN);
+    FN:=ExtractFileName(FN);
+    Result:=Dir+LowerCase(FN);
+    If FileExists(Result) then exit;
+    Result:=Dir+uppercase(Fn);
+    If FileExists(Result) then exit;
+    Result:='';
+    end;
+end;
+
+function TFileResolver.FindIncludeFileName(const AName: string): String;
 
-  begin
-    If FileExists(FN) then
-      Result:=FN
-    else if StrictFileCase then
-      Result:=''
-    else
-      begin
-      Dir:=ExtractFilePath(FN);
-      FN:=ExtractFileName(FN);
-      Result:=Dir+LowerCase(FN);
-      If FileExists(Result) then exit;
-      Result:=Dir+uppercase(Fn);
-      If FileExists(Result) then exit;
-      Result:='';
-      end;
-  end;
 
   Function FindInPath(FN : String) : String;
 
@@ -2502,7 +2555,6 @@ function TFileResolver.FindIncludeFileName(const AName: string): String;
   end;
 
 var
-  i: Integer;
   FN : string;
 
 begin
@@ -2552,6 +2604,45 @@ begin
     Result:=TFileLineReader.Create(AFileName);
 end;
 
+function TFileResolver.FindResourceFileName(const AFileName: string): String;
+
+  Function FindInPath(FN : String) : String;
+
+  var
+    I : integer;
+
+  begin
+    Result:='';
+    I:=0;
+    While (Result='') and (I<FResourcePaths.Count) do
+      begin
+      Result:=SearchLowUpCase(FResourcePaths[i]+FN);
+      Inc(I);
+      end;
+    // search in BaseDirectory
+    if (Result='') and (BaseDirectory<>'') then
+      Result:=SearchLowUpCase(BaseDirectory+FN);
+  end;
+
+var
+  FN : string;
+
+begin
+  Result := '';
+  // convert pathdelims to system
+  FN:=SetDirSeparators(AFileName);
+  If FilenameIsAbsolute(FN) then
+    begin
+    Result := SearchLowUpCase(FN);
+    end
+  else
+    begin
+    // file name is relative
+    // search in include path
+    Result:=FindInPath(FN);
+    end;
+end;
+
 function TFileResolver.FindSourceFile(const AName: string): TLineReader;
 begin
   Result := nil;
@@ -2597,6 +2688,12 @@ begin
   Result:='';
 end;
 
+function TStreamResolver.FindResourceFileName(const AFileName: string): String;
+begin
+  raise EFileNotFoundError.Create('TStreamResolver.FindResourceFileName not supported '+aFileName);
+  Result:='';
+end;
+
 constructor TStreamResolver.Create;
 begin
   Inherited;
@@ -2738,6 +2835,36 @@ begin
   inherited Destroy;
 end;
 
+procedure TPascalScanner.RegisterResourceHandler(aExtension: String; aHandler: TResourceHandler);
+
+Var
+  Idx: Integer;
+
+begin
+  if (aExtension='') then
+    exit;
+  if (aExtension[1]='.') then
+    aExtension:=copy(aExtension,2,Length(aExtension)-1);
+  Idx:=IndexOfResourceHandler(lowerCase(aExtension));
+  if Idx=-1 then
+    begin
+    Idx:=Length(FResourceHandlers);
+    SetLength(FResourceHandlers,Idx+1);
+    FResourceHandlers[Idx].Ext:=LowerCase(aExtension);
+    end;
+  FResourceHandlers[Idx].handler:=aHandler;
+end;
+
+procedure TPascalScanner.RegisterResourceHandler(aExtensions: array of String; aHandler: TResourceHandler);
+
+Var
+  S : String;
+
+begin
+  For S in aExtensions do
+    RegisterResourceHandler(S,aHandler);
+end;
+
 procedure TPascalScanner.ClearFiles;
 
 begin
@@ -3214,6 +3341,53 @@ begin
     DoLog(mtInfo,nLogOpeningFile,SLogOpeningFile,[FormatPath(FCurFileName)],True);
 end;
 
+procedure TPascalScanner.HandleResource(Param: string);
+
+Var
+  Ext,aFullFileName,aFilename,aOptions : String;
+  P: Integer;
+  H : TResourceHandler;
+  OptList : TStrings;
+
+begin
+  aFilename:='';
+  aOptions:='';
+  P:=Pos(';',Param);
+  If P=0 then
+    aFileName:=Trim(Param)
+  else
+    begin
+    aFileName:=Trim(Copy(Param,1,P-1));
+    aOptions:=Copy(Param,P+1,Length(Param)-P);
+    end;
+  Ext:=ExtractFileExt(aFileName);
+  // Construct & find filename
+  If (ChangeFileExt(aFileName,'')='*') then
+    aFileName:=ChangeFileExt(ExtractFileName(CurFilename),Ext);
+  aFullFileName:=FileResolver.FindResourceFileName(aFileName);
+  if aFullFileName='' then
+    Error(nResourceFileNotFound,SErrResourceFileNotFound,[aFileName]);
+  // Check if we can find a handler.
+  if Ext<>'' then
+    Ext:=Copy(Ext,2,Length(Ext)-1);
+  H:=FindResourceHandler(LowerCase(Ext));
+  if (H=Nil) then
+    H:=FindResourceHandler('*');
+  if (H=Nil) then
+    Error(nNoResourceSupport,SNoResourceSupport,[Ext]);
+  // Let the handler take care of the rest.
+  OptList:=TStringList.Create;
+  try
+    OptList.NameValueSeparator:=':';
+    OptList.Delimiter:=';';
+    OptList.StrictDelimiter:=True;
+    OptList.DelimitedText:=aOptions;
+    H(Self,aFullFileName,OptList);
+  finally
+    OptList.Free;
+  end;
+end;
+
 function TPascalScanner.HandleMacro(AIndex : integer) : TToken;
 
 Var
@@ -3496,36 +3670,74 @@ begin
 end;
 
 procedure TPascalScanner.HandleModeSwitch(const Param: String);
-
+// $modeswitch param
+// name, name-, name+, name off, name on, name- comment, name on comment
 Var
   MS : TModeSwitch;
   MSN,PM : String;
-  P : Integer;
+  p : Integer;
+  Enable: Boolean;
 
 begin
-  MSN:=Uppercase(Param);
-  P:=Pos(' ',MSN);
-  if P<>0 then
-    begin
-    PM:=Trim(Copy(MSN,P+1,Length(MSN)-P));
-    MSN:=Copy(MSN,1,P-1);
-    end;
+  PM:=Param;
+  p:=1;
+  while (p<=length(PM)) and (PM[p] in ['a'..'z','A'..'Z','_','0'..'9']) do
+    inc(p);
+  MSN:=LeftStr(PM,p-1);
+  Delete(PM,1,p-1);
   MS:=StrToModeSwitch(MSN);
   if (MS=msNone) or not (MS in AllowedModeSwitches) then
     begin
     if po_CheckModeSwitches in Options then
-      Error(nErrInvalidModeSwitch,SErrInvalidModeSwitch,[Param])
+      Error(nErrInvalidModeSwitch,SErrInvalidModeSwitch,[MSN])
+    else
+      DoLog(mtWarning,nErrInvalidModeSwitch,SErrInvalidModeSwitch,[MSN]);
+    exit; // ignore
+    end;
+  if PM='' then
+    Enable:=true
+  else
+    case PM[1] of
+    '+','-':
+      begin
+      Enable:=PM[1]='+';
+      p:=2;
+      if (p<=length(PM)) and not (PM[p] in [' ',#9]) then
+        Error(nErrWrongSwitchToggle,SErrWrongSwitchToggle,[]);
+      end;
+    ' ',#9:
+      begin
+      PM:=TrimLeft(PM);
+      if PM<>'' then
+        begin
+        p:=1;
+        while (p<=length(PM)) and (PM[p] in ['A'..'Z']) do inc(p);
+        if (p<=length(PM)) and not (PM[p] in [' ',#9]) then
+          Error(nErrWrongSwitchToggle,SErrWrongSwitchToggle,[]);
+        PM:=LeftStr(PM,p-1);
+        if PM='ON' then
+          Enable:=true
+        else if PM='OFF' then
+          Enable:=false
+        else
+          Error(nErrWrongSwitchToggle,SErrWrongSwitchToggle,[]);
+        end;
+      end;
     else
-      exit; // ignore
+      Error(nErrWrongSwitchToggle,SErrWrongSwitchToggle,[]);
     end;
-  if (PM='-') or (PM='OFF') then
+
+  if MS in CurrentModeSwitches=Enable then
+    exit; // no change
+  if MS in ReadOnlyModeSwitches then
     begin
-    if MS in ReadOnlyModeSwitches then
-      Error(nErrInvalidModeSwitch,SErrInvalidModeSwitch,[Param]);
-    CurrentModeSwitches:=CurrentModeSwitches-[MS]
-    end
+    DoLog(mtWarning,nErrInvalidModeSwitch,SErrInvalidModeSwitch,[MSN]);
+    exit;
+    end;
+  if Enable then
+    CurrentModeSwitches:=CurrentModeSwitches+[MS]
   else
-    CurrentModeSwitches:=CurrentModeSwitches+[MS];
+    CurrentModeSwitches:=CurrentModeSwitches-[MS];
 end;
 
 procedure TPascalScanner.PushSkipMode;
@@ -3789,6 +4001,8 @@ begin
           DoBoolDirective(bsOverflowChecks);
         'POINTERMATH':
           DoBoolDirective(bsPointerMath);
+        'R' :
+          HandleResource(Param);
         'RANGECHECKS':
           DoBoolDirective(bsRangeChecks);
         'SCOPEDENUMS':
@@ -4797,6 +5011,27 @@ begin
   FReadOnlyValueSwitches:=AValue;
 end;
 
+function TPascalScanner.IndexOfResourceHandler(const aExt: string): Integer;
+
+begin
+  Result:=Length(FResourceHandlers)-1;
+  While (Result>=0) and (FResourceHandlers[Result].Ext<>aExt) do
+    Dec(Result);
+end;
+
+function TPascalScanner.FindResourceHandler(const aExt: string): TResourceHandler;
+
+Var
+  Idx : Integer;
+
+begin
+  Idx:=IndexOfResourceHandler(aExt);
+  if Idx=-1 then
+    Result:=Nil
+  else
+    Result:=FResourceHandlers[Idx].handler;
+end;
+
 function TPascalScanner.ReadIdentifier(const AParam: string): string;
 var
   p, l: Integer;

+ 226 - 24
packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -58,6 +58,10 @@ type
     // generic class
     procedure TestGen_Class;
     procedure TestGen_ClassDelphi;
+    procedure TestGen_ClassDelphi_TypeOverload;
+    procedure TestGen_ClassObjFPC;
+    procedure TestGen_ClassObjFPC_OverloadFail;
+    procedure TestGen_ClassObjFPC_OverloadOtherUnit;
     procedure TestGen_ClassForward;
     procedure TestGen_ClassForwardConstraints;
     procedure TestGen_ClassForwardConstraintNameMismatch;
@@ -65,8 +69,8 @@ type
     procedure TestGen_ClassForwardConstraintTypeMismatch;
     procedure TestGen_ClassForward_Circle;
     procedure TestGen_Class_RedeclareInUnitImplFail;
-    procedure TestGen_Class_AnotherInUnitImpl;
-    procedure TestGen_Class_Method;
+    procedure TestGen_Class_TypeOverloadInUnitImpl;
+    procedure TestGen_Class_MethodObjFPC;
     procedure TestGen_Class_MethodOverride;
     procedure TestGen_Class_MethodDelphi;
     procedure TestGen_Class_MethodDelphiTypeParamMissing;
@@ -105,6 +109,7 @@ type
     procedure TestGen_PointerDirectSpecializeFail;
 
     // ToDo: helpers for generics
+    procedure TestGen_HelperForArray;
     // ToDo: default class prop array helper: arr<b>[c]
 
     // generic statements
@@ -139,20 +144,26 @@ type
     procedure TestGenProc_TypeParamCntOverload;
     procedure TestGenProc_TypeParamCntOverloadNoParams;
     procedure TestGenProc_TypeParamWithDefaultParamDelphiFail;
-    procedure TestGenProc_Inference_NeedExplicitFail;
-    procedure TestGenProc_Inference_Overload;
-    procedure TestGenProc_Inference_OverloadForward;
-    procedure TestGenProc_Inference_Var_Overload;
-    //procedure TestGenProc_Inference_Widen;
-    procedure TestGenProc_Inference_DefaultValue;
-    procedure TestGenProc_Inference_DefaultValueMismatch;
-    procedure TestGenProc_Inference_ProcT;
-    procedure TestGenProc_Inference_Mismatch;
-    procedure TestGenProc_Inference_ArrayOfT;
-    // ToDo procedure TestGenProc_Inference_ProcType;
+    // ToDo: NestedResultAssign
+
+    // generic function infer types
+    procedure TestGenProc_Infer_NeedExplicitFail;
+    procedure TestGenProc_Infer_Overload;
+    procedure TestGenProc_Infer_OverloadForward;
+    procedure TestGenProc_Infer_Var_Overload;
+    procedure TestGenProc_Infer_Widen;
+    procedure TestGenProc_Infer_DefaultValue;
+    procedure TestGenProc_Infer_DefaultValueMismatch;
+    procedure TestGenProc_Infer_ProcT;
+    procedure TestGenProc_Infer_Mismatch;
+    procedure TestGenProc_Infer_ArrayOfT;
+    procedure TestGenProc_Infer_PassAsArgDelphi;
+    procedure TestGenProc_Infer_PassAsArgObjFPC;
+    // ToDo procedure TestGenProc_Infer_ProcType;
 
     // generic methods
     procedure TestGenMethod_VirtualFail;
+    procedure TestGenMethod_PublishedFail;
     procedure TestGenMethod_ClassInterfaceMethodFail;
     procedure TestGenMethod_ClassConstructorFail;
     procedure TestGenMethod_TemplNameDifferFail;
@@ -751,6 +762,96 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGen_ClassDelphi_TypeOverload;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TObject = class end;',
+  '  {#a}TBird = word;',
+  '  {#b}TBird<T> = class',
+  '    v: T;',
+  '  end;',
+  '  {=b}TEagle = TBird<word>;',
+  'var',
+  '  b: {@b}TBird<word>;',
+  '  {=a}w: TBird;',
+  'begin',
+  '  b.v:=w;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGen_ClassObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  generic TBird<T> = class',
+  '    v: TBird;',
+  '  end;',
+  'var',
+  '  b: specialize TBird<word>;',
+  'begin',
+  '  b.v:=b;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGen_ClassObjFPC_OverloadFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  TBird = word;',
+  '  generic TBird<T> = class',
+  '    v: T;',
+  '  end;',
+  'begin',
+  '']);
+  CheckResolverException('Duplicate identifier "TBird" at afile.pp(5,8)',nDuplicateIdentifier);
+end;
+
+procedure TTestResolveGenerics.TestGen_ClassObjFPC_OverloadOtherUnit;
+begin
+  AddModuleWithIntfImplSrc('unit1.pas',
+    LinesToStr([
+    'type',
+    '  TBird = class b1: word; end;',
+    '  generic TAnt<T> = class a1: T; end;',
+    '']),
+    LinesToStr([
+    '']));
+  AddModuleWithIntfImplSrc('unit2.pas',
+    LinesToStr([
+    'type',
+    '  generic TBird<T> = class b2:T; end;',
+    '  TAnt = class a2:word; end;',
+    '']),
+    LinesToStr([
+    '']));
+  StartProgram(true,[supTObject]);
+  Add([
+  'uses unit1, unit2;',
+  'var',
+  '  b1: TBird;',
+  '  b2: specialize TBird<word>;',
+  '  a1: specialize TAnt<word>;',
+  '  a2: TAnt;',
+  'begin',
+  '  b1.b1:=1;',
+  '  b2.b2:=2;',
+  '  a1.a1:=3;',
+  '  a2.a2:=4;',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolveGenerics.TestGen_ClassForward;
 begin
   StartProgram(false);
@@ -905,7 +1006,7 @@ begin
     nDuplicateIdentifier);
 end;
 
-procedure TTestResolveGenerics.TestGen_Class_AnotherInUnitImpl;
+procedure TTestResolveGenerics.TestGen_Class_TypeOverloadInUnitImpl;
 begin
   StartUnit(false);
   Add([
@@ -919,7 +1020,7 @@ begin
   ParseUnit;
 end;
 
-procedure TTestResolveGenerics.TestGen_Class_Method;
+procedure TTestResolveGenerics.TestGen_Class_MethodObjFPC;
 begin
   StartProgram(false);
   Add([
@@ -930,10 +1031,18 @@ begin
   '  generic TBird<{#Templ}T> = class',
   '    function Fly(p:T): T; virtual; abstract;',
   '    function Run(p:T): T;',
+  '    procedure Jump(p:T);',
+  '    class procedure Go(p:T);',
   '  end;',
   'function TBird.Run(p:T): T;',
   'begin',
   'end;',
+  'generic procedure TBird<T>.Jump(p:T);',
+  'begin',
+  'end;',
+  'generic class procedure TBird<T>.Go(p:T);',
+  'begin',
+  'end;',
   'var',
   '  b: specialize TBird<word>;',
   '  {=Typ}w: T;',
@@ -1520,6 +1629,27 @@ begin
   CheckParserException('Expected "Identifier" at token "specialize" in file afile.pp at line 4 column 11',nParserExpectTokenError);
 end;
 
+procedure TTestResolveGenerics.TestGen_HelperForArray;
+begin
+  StartProgram(false);
+  Add([
+  '{$ModeSwitch typehelpers}',
+  'type',
+  '  generic TArr<T> = array[1..2] of T;',
+  '  TWordArrHelper = type helper for specialize TArr<word>',
+  '    procedure Fly(w: word);',
+  '  end;',
+  'procedure TWordArrHelper.Fly(w: word);',
+  'begin',
+  'end;',
+  'var',
+  '  a: specialize TArr<word>;',
+  'begin',
+  '  a.Fly(3);',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolveGenerics.TestGen_LocalVar;
 begin
   StartProgram(false);
@@ -2061,7 +2191,7 @@ begin
   CheckResolverException(sParamOfThisTypeCannotHaveDefVal,nParamOfThisTypeCannotHaveDefVal);
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_NeedExplicitFail;
+procedure TTestResolveGenerics.TestGenProc_Infer_NeedExplicitFail;
 begin
   StartProgram(false);
   Add([
@@ -2076,7 +2206,7 @@ begin
     nCouldNotInferTypeArgXForMethodY);
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_Overload;
+procedure TTestResolveGenerics.TestGenProc_Infer_Overload;
 begin
   StartProgram(false);
   Add([
@@ -2098,7 +2228,7 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_OverloadForward;
+procedure TTestResolveGenerics.TestGenProc_Infer_OverloadForward;
 begin
   StartProgram(false);
   Add([
@@ -2126,7 +2256,7 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_Var_Overload;
+procedure TTestResolveGenerics.TestGenProc_Infer_Var_Overload;
 begin
   StartProgram(false);
   Add([
@@ -2152,7 +2282,24 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_DefaultValue;
+procedure TTestResolveGenerics.TestGenProc_Infer_Widen;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'procedure {#A}Run<S>(a: S; b: S);',
+  'begin',
+  'end;',
+  'begin',
+  '  {@A}Run(word(1),longint(2));',
+  '  {@A}Run(int64(1),longint(2));',
+  '  {@A}Run(boolean(false),wordbool(2));',
+  '  {@A}Run(''a'',''foo'');',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGenProc_Infer_DefaultValue;
 begin
   StartProgram(false);
   Add([
@@ -2169,7 +2316,7 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_DefaultValueMismatch;
+procedure TTestResolveGenerics.TestGenProc_Infer_DefaultValueMismatch;
 begin
   StartProgram(false);
   Add([
@@ -2185,7 +2332,7 @@ begin
                          nIncompatibleTypesGotExpected);
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_ProcT;
+procedure TTestResolveGenerics.TestGenProc_Infer_ProcT;
 begin
   StartProgram(false);
   Add([
@@ -2207,7 +2354,7 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_Mismatch;
+procedure TTestResolveGenerics.TestGenProc_Infer_Mismatch;
 begin
   StartProgram(false);
   Add([
@@ -2222,7 +2369,7 @@ begin
     nInferredTypeXFromDiffArgsMismatchFromMethodY);
 end;
 
-procedure TTestResolveGenerics.TestGenProc_Inference_ArrayOfT;
+procedure TTestResolveGenerics.TestGenProc_Infer_ArrayOfT;
 begin
   StartProgram(false);
   Add([
@@ -2239,6 +2386,43 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGenProc_Infer_PassAsArgDelphi;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'function Run<T>(a: T): T;',
+  'var b: T;',
+  'begin',
+  '  Run(Run<word>(3));',
+  '  Run(Run(4));',
+  'end;',
+  'begin',
+  '  Run(Run<word>(5));',
+  '  Run(Run(6));',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGenProc_Infer_PassAsArgObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  '{$ModeSwitch implicitfunctionspecialization}',
+  'generic function Run<T>(a: T): T;',
+  'var b: T;',
+  'begin',
+  '  Run(specialize Run<word>(3));',
+  '  Run(Run(4));',
+  'end;',
+  'begin',
+  '  Run(specialize Run<word>(5));',
+  '  Run(Run(6));',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolveGenerics.TestGenMethod_VirtualFail;
 begin
   StartProgram(false);
@@ -2253,6 +2437,24 @@ begin
     nXMethodsCannotHaveTypeParams);
 end;
 
+procedure TTestResolveGenerics.TestGenMethod_PublishedFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  published',
+  '    generic procedure Run<T>(a: T);',
+  '  end;',
+  'generic procedure TObject.Run<T>(a: T);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('published methods cannot have type parameters',
+    nXMethodsCannotHaveTypeParams);
+end;
+
 procedure TTestResolveGenerics.TestGenMethod_ClassInterfaceMethodFail;
 begin
   StartProgram(false);

+ 265 - 22
packages/fcl-passrc/tests/tcresolver.pas

@@ -131,8 +131,9 @@ type
     procedure OnCheckElementParent(El: TPasElement; arg: pointer);
     procedure FreeSrcMarkers;
     procedure OnPasResolverLog(Sender: TObject; const Msg: String);
-    procedure ScannerDirective(Sender: TObject; Directive, Param: String;
+    procedure OnScannerDirective(Sender: TObject; Directive, Param: String;
       var Handled: boolean);
+    procedure OnScannerLog(Sender: TObject; const Msg: String);
   Protected
     FirstSrcMarker, LastSrcMarker: PSrcMarker;
     Procedure SetUp; override;
@@ -382,6 +383,7 @@ type
     // procs
     Procedure TestProcParam;
     Procedure TestProcParamAccess;
+    Procedure TestProcParamConstRefFail;
     Procedure TestFunctionResult;
     Procedure TestProcedureResultFail;
     Procedure TestProc_ArgVarPrecisionLossFail;
@@ -447,6 +449,8 @@ type
     Procedure TestProcedureExternal;
     Procedure TestProc_UntypedParam_Forward;
     Procedure TestProc_Varargs;
+    Procedure TestProc_VarargsOfT;
+    Procedure TestProc_VarargsOfTMismatch;
     Procedure TestProc_ParameterExprAccess;
     Procedure TestProc_FunctionResult_DeclProc;
     Procedure TestProc_TypeCastFunctionResult;
@@ -640,6 +644,9 @@ type
     Procedure TestNestedClass_Forward;
     procedure TestNestedClass_StrictPrivateFail;
     procedure TestNestedClass_AccessStrictPrivate;
+    procedure TestNestedClass_AccessParent;
+    procedure TestNestedClass_BodyAccessParentVarFail;
+    procedure TestNestedClass_PropertyAccessParentVarFail;
 
     // external class
     Procedure TestExternalClass;
@@ -712,8 +719,8 @@ type
     Procedure TestClassProperty;
     Procedure TestClassPropertyNonStaticFail;
     Procedure TestClassPropertyNonStaticAllow;
-    //Procedure TestClassPropertyStaticMismatchFail;
     Procedure TestArrayProperty;
+    Procedure TestArrayProperty_PassImplicitCallClassFunc;
     Procedure TestProperty_WrongTypeAsIndexFail;
     Procedure TestProperty_Option_ClassPropertyNonStatic;
     Procedure TestDefaultProperty;
@@ -803,6 +810,7 @@ type
     Procedure TestArray_OpenArrayAsDynArraySetLengthFail;
     Procedure TestArray_OpenArrayAsDynArray;
     Procedure TestArray_OpenArrayDelphi;
+    Procedure TestArray_OpenArrayChar;
     Procedure TestArray_CopyConcat;
     Procedure TestStaticArray_CopyConcat;// ToDo
     Procedure TestArray_CopyMismatchFail;
@@ -1046,7 +1054,8 @@ begin
   FModules:=TObjectList.Create(true);
   inherited SetUp;
   Parser.Options:=Parser.Options+[po_ResolveStandardTypes];
-  Scanner.OnDirective:=@ScannerDirective;
+  Scanner.OnDirective:=@OnScannerDirective;
+  Scanner.OnLog:=@OnScannerLog;
 end;
 
 procedure TCustomTestResolver.TearDown;
@@ -1455,7 +1464,9 @@ var
         if El.CustomData is TResolvedReference then
           Ref:=TResolvedReference(El.CustomData).Declaration
         else if El.CustomData is TPasPropertyScope then
-          Ref:=TPasPropertyScope(El.CustomData).AncestorProp;
+          Ref:=TPasPropertyScope(El.CustomData).AncestorProp
+        else if El.CustomData is TPasSpecializeTypeData then
+          Ref:=TPasSpecializeTypeData(El.CustomData).SpecializedType;
         if Ref<>nil then
           for j:=0 to LabelElements.Count-1 do
             begin
@@ -1471,11 +1482,17 @@ var
         El:=TPasElement(ReferenceElements[i]);
         write('Reference candidate for "',aMarker^.Identifier,'" at reference ',aMarker^.Filename,'(',aMarker^.Row,',',aMarker^.StartCol,'-',aMarker^.EndCol,')');
         write(' El=',GetObjName(El));
+        if EL is TPrimitiveExpr then
+          begin
+           writeln('CheckResolverReference ',TPrimitiveExpr(El).Value);
+          end;
         Ref:=nil;
         if El.CustomData is TResolvedReference then
           Ref:=TResolvedReference(El.CustomData).Declaration
         else if El.CustomData is TPasPropertyScope then
-          Ref:=TPasPropertyScope(El.CustomData).AncestorProp;
+          Ref:=TPasPropertyScope(El.CustomData).AncestorProp
+        else if El.CustomData is TPasSpecializeTypeData then
+          Ref:=TPasSpecializeTypeData(El.CustomData).SpecializedType;
         if Ref<>nil then
           begin
           write(' Decl=',GetObjName(Ref));
@@ -1483,7 +1500,7 @@ var
           write(',',Ref.SourceFilename,'(',aLine,',',aCol,')');
           end
         else
-          write(' has no TResolvedReference');
+          write(' has no TResolvedReference. El.CustomData=',GetObjName(El.CustomData));
         writeln;
         end;
       for i:=0 to LabelElements.Count-1 do
@@ -1526,7 +1543,7 @@ var
       for i:=0 to ReferenceElements.Count-1 do
         begin
         El:=TPasElement(ReferenceElements[i]);
-        //writeln('CheckDirectReference ',i,'/',ReferenceElements.Count,' ',GetTreeDesc(El,2));
+        //writeln('CheckDirectReference ',i,'/',ReferenceElements.Count,' ',GetTreeDbg(El,2));
         if El.ClassType=TPasVariable then
           begin
           if TPasVariable(El).VarType=nil then
@@ -1575,6 +1592,8 @@ var
         begin
         El:=TPasElement(ReferenceElements[i]);
         writeln('  Reference ',GetObjName(El),' at ',ResolverEngine.GetElementSourcePosStr(El));
+        //if EL is TPasVariable then
+        //  writeln('CheckDirectReference ',GetObjPath(TPasVariable(El).VarType),' ',ResolverEngine.GetElementSourcePosStr(TPasVariable(EL).VarType));
         end;
       RaiseErrorAtSrcMarker('wrong direct reference "'+aMarker^.Identifier+'"',aMarker);
     finally
@@ -2544,7 +2563,7 @@ begin
   FResolverMsgs.Add(Item);
 end;
 
-procedure TCustomTestResolver.ScannerDirective(Sender: TObject; Directive,
+procedure TCustomTestResolver.OnScannerDirective(Sender: TObject; Directive,
   Param: String; var Handled: boolean);
 var
   aScanner: TPascalScanner;
@@ -2559,6 +2578,17 @@ begin
   if Param='' then ;
 end;
 
+procedure TCustomTestResolver.OnScannerLog(Sender: TObject; const Msg: String);
+var
+  aScanner: TPascalScanner;
+begin
+  aScanner:=TPascalScanner(Sender);
+  if aScanner=nil then exit;
+  {$IFDEF VerbosePasResolver}
+  writeln('TCustomTestResolver.OnScannerLog ',GetObjName(Sender),' ',aScanner.LastMsgType,' ',aScanner.LastMsgNumber,' Msg="', Msg,'"');
+  {$ENDIF}
+end;
+
 function TCustomTestResolver.GetModules(Index: integer): TTestEnginePasResolver;
 begin
   Result:=TTestEnginePasResolver(FModules[Index]);
@@ -6099,6 +6129,16 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestProcParamConstRefFail;
+begin
+  StartProgram(false);
+  Add('procedure Run(constref a: word);');
+  Add('begin');
+  Add('end;');
+  Add('begin');
+  CheckResolverException('not yet implemented: constref',nNotYetImplemented);
+end;
+
 procedure TTestResolver.TestFunctionResult;
 begin
   StartProgram(false);
@@ -7269,7 +7309,7 @@ begin
   Add('procedure {#ProcA}ProcA(var {#A}A); forward;');
   Add('procedure {#ProcB}ProcB(const {#B}B); forward;');
   Add('procedure {#ProcC}ProcC(out {#C}C); forward;');
-  Add('procedure {#ProcD}ProcD(constref {#D}D); forward;');
+  //Add('procedure {#ProcD}ProcD(constref {#D}D); forward;');
   Add('procedure ProcA(var A);');
   Add('begin');
   Add('end;');
@@ -7279,15 +7319,15 @@ begin
   Add('procedure ProcC(out C);');
   Add('begin');
   Add('end;');
-  Add('procedure ProcD(constref D);');
-  Add('begin');
-  Add('end;');
+  //Add('procedure ProcD(constref D);');
+  //Add('begin');
+  //Add('end;');
   Add('var i: longint;');
   Add('begin');
   Add('  {@ProcA}ProcA(i);');
   Add('  {@ProcB}ProcB(i);');
   Add('  {@ProcC}ProcC(i);');
-  Add('  {@ProcD}ProcD(i);');
+  //Add('  {@ProcD}ProcD(i);');
   ParseProgram;
 end;
 
@@ -7316,6 +7356,41 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestProc_VarargsOfT;
+begin
+  StartProgram(false);
+  Add([
+  'procedure ProcA(i:longint); varargs of word; external;',
+  'procedure ProcB; varargs of boolean; external;',
+  'procedure ProcC(i: longint = 17); varargs of double; external;',
+  'begin',
+  '  ProcA(1);',
+  '  ProcA(2,3);',
+  '  ProcA(4,5,6);',
+  '  ProcB;',
+  '  ProcB();',
+  '  ProcB(false);',
+  '  ProcB(true,false);',
+  '  ProcC;',
+  '  ProcC();',
+  '  ProcC(7);',
+  '  ProcC(8,9.3);',
+  '  ProcC(8,9.3,1.3);',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestProc_VarargsOfTMismatch;
+begin
+  StartProgram(false);
+  Add([
+  'procedure ProcA(i:longint); varargs of word; external;',
+  'begin',
+  '  ProcA(1,false);',
+  '']);
+  CheckResolverException('Incompatible type arg no. 2: Got "Boolean", expected "Word"',nIncompatibleTypeArgNo);
+end;
+
 procedure TTestResolver.TestProc_ParameterExprAccess;
 begin
   StartProgram(false);
@@ -10340,8 +10415,8 @@ begin
   Add('  end;');
   Add('begin');
   Add('  if TObject.i=7 then ;');
-  CheckResolverException(sCannotAccessThisMemberFromAX,
-    nCannotAccessThisMemberFromAX);
+  CheckResolverException(sInstanceMemberXInaccessible,
+    nInstanceMemberXInaccessible);
 end;
 
 procedure TTestResolver.TestClass_FuncReturningObjectMember;
@@ -11475,6 +11550,88 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestNestedClass_AccessParent;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TLimb = class',
+  '    {#tlimb_d}d: longint;',
+  '  end;',
+  '  TAnt = boolean;',
+  '  TBird = class',
+  '  public type',
+  '    TBody = class',
+  '    public type',
+  '      TAnt = word;',
+  '      TWing = class(TLimb)',
+  '        {#ant}ant: TAnt;',
+  '        procedure Fly(i: longint);',
+  '      end;',
+  '    public',
+  '      class var {#tbody_a}a, {#tbody_b}b, {#tbody_d}d, {#tbody_e}e: longint;',
+  '    end;',
+  '  public',
+  '    class var {#tbird_a}a, {#tbird_b}b, {#tbird_c}c, {#tbird_d}d, {#tbird_e}e: longint;',
+  '  end;',
+  'var {#intf_a}a, {#intf_d}d: longint;',
+  'implementation',
+  'var {#impl_e}e: longint;',
+  'procedure TBird.TBody.TWing.Fly(i: longint);',
+  'begin',
+  '  {@ant}ant:=2;',
+  '  {@intf_a}a:=3;',
+  '  {@tbody_b}b:=4;',
+  '  {@tbird_c}c:=5;',
+  '  {@tlimb_d}d:=6;',
+  '  {@impl_e}e:=7;',
+  'end;',
+  '']);
+  ParseUnit;
+end;
+
+procedure TTestResolver.TestNestedClass_BodyAccessParentVarFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  TBird = class',
+  '  public type',
+  '    TWing = class',
+  '      procedure Fly;',
+  '    end;',
+  '  public',
+  '    var i: longint;',
+  '  end;',
+  'procedure TBird.TWing.Fly;',
+  'begin',
+  '  i:=3;',
+  'end;',
+  'begin']);
+  CheckResolverException('Instance member "i" inaccessible here',nInstanceMemberXInaccessible);
+end;
+
+procedure TTestResolver.TestNestedClass_PropertyAccessParentVarFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  TBird = class',
+  '    fSize: word;',
+  '  public type',
+  '    TWing = class',
+  '      property Size: word read fSize;',
+  '    end;',
+  '  end;',
+  'begin']);
+  CheckResolverException('identifier not found "fSize"',nIdentifierNotFound);
+end;
+
 procedure TTestResolver.TestExternalClass;
 begin
   StartProgram(false);
@@ -11736,8 +11893,8 @@ begin
   Add('  oc: TObjectClass;');
   Add('begin');
   Add('  oc.Id:=3;');
-  CheckResolverException(sCannotAccessThisMemberFromAX,
-    nCannotAccessThisMemberFromAX);
+  CheckResolverException(sInstanceMemberXInaccessible,
+    nInstanceMemberXInaccessible);
 end;
 
 procedure TTestResolver.TestClassOfDotClassProc;
@@ -11796,8 +11953,8 @@ begin
   Add('  oc: TObjectClass;');
   Add('begin');
   Add('  oc.ProcA;');
-  CheckResolverException(sCannotAccessThisMemberFromAX,
-    nCannotAccessThisMemberFromAX);
+  CheckResolverException(sInstanceMemberXInaccessible,
+    nInstanceMemberXInaccessible);
 end;
 
 procedure TTestResolver.TestClassOfDotClassProperty;
@@ -11843,8 +12000,8 @@ begin
   Add('  oc: TObjectClass;');
   Add('begin');
   Add('  if oc.A=3 then ;');
-  CheckResolverException(sCannotAccessThisMemberFromAX,
-    nCannotAccessThisMemberFromAX);
+  CheckResolverException(sInstanceMemberXInaccessible,
+    nInstanceMemberXInaccessible);
 end;
 
 procedure TTestResolver.TestClass_ClassProcSelf;
@@ -12773,6 +12930,76 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestArrayProperty_PassImplicitCallClassFunc;
+var
+  aMarker: PSrcMarker;
+  Elements: TFPList;
+  ActualImplicitCallWithoutParams, ExpectedImplicitCallWithoutParams: Boolean;
+  i: Integer;
+  El: TPasElement;
+  Ref: TResolvedReference;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    function GetItems(s: string): string;',
+  '    property Items[s: string]: string read GetItems; default;',
+  '    class function Desc: string; virtual; abstract;',
+  '  end;',
+  'function TObject.GetItems(s: string): string;',
+  'begin',
+  '  Result:=Items[{#a_implicit}Desc];',
+  '  Result:=Items[{#b_direct}Desc()];',
+  '  Result:=Items[Self.{#c_implicit}Desc];',
+  '  Result:=Items[Self.{#d_direct}Desc()];',
+  'end;',
+  'var b: TObject;',
+  '  s: string;',
+  'begin',
+  '  s:=b.Items[b.{#m_implicit}Desc];',
+  '  s:=b.Items[b.{#n_direct}Desc()];',
+  '  s:=b.Items[TObject.{#o_implicit}Desc];',
+  '  s:=b.Items[TObject.{#p_direct}Desc()];',
+  '  s:=b[b.{#q_implicit}Desc];',
+  '  s:=b[b.{#r_direct}Desc()];',
+  '  s:=b[TObject.{#s_implicit}Desc];',
+  '  s:=b[TObject.{#t_direct}Desc()];',
+  '']);
+  ParseProgram;
+  aMarker:=FirstSrcMarker;
+  while aMarker<>nil do
+    begin
+    //writeln('TTestResolver.TestArrayProperty_PassImplicitCallClassFunc ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
+    Elements:=FindElementsAt(aMarker);
+    try
+      ActualImplicitCallWithoutParams:=false;
+      Ref:=nil;
+      for i:=0 to Elements.Count-1 do
+        begin
+        El:=TPasElement(Elements[i]);
+        //writeln('TTestResolver.TestArrayProperty_PassImplicitCallClassFunc ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
+        if not (El.CustomData is TResolvedReference) then continue;
+        Ref:=TResolvedReference(El.CustomData);
+        if Ref.Declaration is TPasProcedure then
+          break
+        else
+          Ref:=nil;
+        end;
+      if Ref=nil then
+        RaiseErrorAtSrcMarker('missing proc ref at "#'+aMarker^.Identifier+'"',aMarker);
+      ActualImplicitCallWithoutParams:=rrfImplicitCallWithoutParams in Ref.Flags;
+      ExpectedImplicitCallWithoutParams:=RightStr(aMarker^.Identifier,length('_implicit'))='_implicit';
+      if ActualImplicitCallWithoutParams<>ExpectedImplicitCallWithoutParams then
+        RaiseErrorAtSrcMarker('wrong implicit call at "#'+aMarker^.Identifier
+          +', ExpectedImplicitCall='+BoolToStr(ExpectedImplicitCallWithoutParams,true)+'"',aMarker);
+    finally
+      Elements.Free;
+    end;
+    aMarker:=aMarker^.Next;
+    end;
+end;
+
 procedure TTestResolver.TestProperty_WrongTypeAsIndexFail;
 begin
   StartProgram(false);
@@ -14534,6 +14761,21 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestArray_OpenArrayChar;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'Function CharInSet(Ch: Char;Const CSet : array of char) : Boolean;',
+  'begin',
+  'end;',
+  'var Key: Char;',
+  'begin',
+  '  if CharInSet(Key, [^V, ^X, ^C]) then ;',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestArray_CopyConcat;
 begin
   StartProgram(false);
@@ -17610,7 +17852,8 @@ begin
   'begin',
   '  TFlag.Fly;',
   '']);
-  CheckResolverException('Cannot access this member from a type helper',nCannotAccessThisMemberFromAX);
+  CheckResolverException('Instance member "Fly" inaccessible here',
+    nInstanceMemberXInaccessible);
 end;
 
 procedure TTestResolver.TestTypeHelper_Set;

+ 1 - 1
packages/fcl-passrc/tests/tcscanner.pas

@@ -1730,7 +1730,7 @@ begin
       if SModeSwitchNames[M]<>'' then
         begin
         Scanner.CurrentModeSwitches:=[];
-        NewSource('{$MODESWITCH '+SModeSwitchNames[M]+' '+C+'}');
+        NewSource('{$MODESWITCH '+SModeSwitchNames[M]+C+'}');
         While not (Scanner.FetchToken=tkEOF) do;
         if C in [' ','+'] then
           AssertTrue(SModeSwitchNames[M]+C+' sets '+GetEnumName(TypeInfo(TModeSwitch),Ord(M)),M in Scanner.CurrentModeSwitches)

+ 81 - 0
packages/fcl-passrc/tests/tctypeparser.pas

@@ -361,6 +361,9 @@ type
     Procedure TestAdvRec_ProcOverrideFail;
     Procedure TestAdvRec_ProcMessageFail;
     Procedure TestAdvRec_DestructorFail;
+    Procedure TestAdvRecordInFunction;
+    Procedure TestAdvRecordInAnonFunction;
+    Procedure TestAdvRecordClassOperator;
   end;
 
   { TTestProcedureTypeParser }
@@ -2607,6 +2610,84 @@ begin
   ParseRecordFail(SParserNoConstructorAllowed,nParserNoConstructorAllowed);
 end;
 
+procedure TTestRecordTypeParser.TestAdvRecordInFunction;
+
+// Src from bug report 36179
+
+Const
+   Src =
+    '{$mode objfpc}'+sLineBreak+
+    '{$modeswitch advancedrecords}'+sLineBreak+
+    'program afile;'+sLineBreak+
+    '  procedure DoThis;'+sLineBreak+
+    '  type'+sLineBreak+
+    '    TMyRecord = record'+sLineBreak+
+    '      private'+sLineBreak+
+    '        x, y, z: integer;'+sLineBreak+
+    '    end;'+sLineBreak+
+    '  begin'+sLineBreak+
+    '  end;'+sLineBreak+
+    'begin'+sLineBreak+
+    'end.';
+
+begin
+  Source.Text:=Src;
+  ParseModule; // We're just interested in that it parses.
+end;
+
+procedure TTestRecordTypeParser.TestAdvRecordInAnonFunction;
+
+// Src from bug report 36179, modified to put record in anonymous function
+//  Delphi 10.3.2 allows this
+
+Const
+   Src =
+    '{$mode objfpc}'+sLineBreak+
+    '{$modeswitch advancedrecords}'+sLineBreak+
+    'program afile;'+sLineBreak+
+    'var a : Procedure;'+sLineBreak+
+    'begin'+sLineBreak+
+    ' a := '+sLineBreak+
+    '  procedure '+sLineBreak+
+    '  type'+sLineBreak+
+    '    TMyRecord = record'+sLineBreak+
+    '      private'+sLineBreak+
+    '        x, y, z: integer;'+sLineBreak+
+    '    end;'+sLineBreak+
+    '  begin'+sLineBreak+
+    '  end;'+sLineBreak+
+    'end.';
+
+begin
+  Source.Text:=Src;
+  ParseModule; // We're just interested in that it parses.
+end;
+
+procedure TTestRecordTypeParser.TestAdvRecordClassOperator;
+
+// Source from bug id 36180
+
+Const
+   SRC =
+    '{$mode objfpc}'+sLineBreak+
+    '{$modeswitch advancedrecords}'+sLineBreak+
+    'program afile;'+sLineBreak+
+    'type'+sLineBreak+
+    '  TMyRecord = record'+sLineBreak+
+    '    class operator = (a, b: TMyRecord): boolean;'+sLineBreak+
+    '  end;'+sLineBreak+
+    'class operator TMyRecord.= (a, b: TMyRecord): boolean;'+sLineBreak+
+    'begin'+sLineBreak+
+    '  result := (@a = @b);'+sLineBreak+
+    'end;'+sLineBreak+
+    'begin'+sLineBreak+
+    'end.';
+
+begin
+  Source.Text:=Src;
+  ParseModule;   // We're just interested in that it parses.
+end;
+
 { TBaseTestTypeParser }
 
 Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;

+ 24 - 1
packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -134,6 +134,7 @@ type
     procedure TestM_Hint_FunctionResultAssembler;
     procedure TestM_Hint_FunctionResultExit;
     procedure TestM_Hint_AbsoluteVar;
+    procedure TestM_Hint_GenFunctionResultArgNotUsed;
 
     // whole program optimization
     procedure TestWP_LocalVar;
@@ -841,9 +842,9 @@ begin
   StartProgram(false);
   Add([
   'resourcestring',
-  'resourcestring',
   '  {#a_used}a = ''txt'';',
   '  {#b_used}b = ''foo'';',
+  '  {#c_notused}c = ''bar'';',
   'procedure {#DoIt_used}DoIt(s: string);',
   'var',
   '  {#d_used}d: string;',
@@ -2282,6 +2283,28 @@ begin
   CheckUseAnalyzerUnexpectedHints;
 end;
 
+procedure TTestUseAnalyzer.TestM_Hint_GenFunctionResultArgNotUsed;
+begin
+  StartProgram(true);
+  Add([
+  'type',
+  '  generic TPoint<U> = record X,Y: U; end;',
+  'generic procedure Three<S>(out x: S);',
+  'begin',
+  '  x:=3;',
+  'end;',
+  'generic function Point<T>(): specialize TPoint<T>;',
+  'begin',
+  '  specialize Three<T>(Result.X)',
+  'end;',
+  'begin',
+  '  specialize Point<word>();',
+  '']);
+  AnalyzeProgram;
+  CheckUseAnalyzerHint(mtHint,nPALocalVariableNotUsed,'Local variable "Y" not used');
+  CheckUseAnalyzerUnexpectedHints;
+end;
+
 procedure TTestUseAnalyzer.TestWP_LocalVar;
 begin
   StartProgram(false);

+ 258 - 95
packages/pastojs/src/fppas2js.pp

@@ -400,22 +400,24 @@ Works:
   - pass class property, static class property
   - pass array property
 - array of const, TVarRec
+- attributes
+- overflow check:
+  -Co   : Overflow checking of integer operations
+- generics
 
 ToDos:
 - range check:
    type helper self:=
-- overflow check:
-   ?
 - cmd line param to set modeswitch
 - Result:=inherited;
 - asm-block annotate/reference
   - pas()  test or use or read or write
+  - trailing [,,,]
 - bug: DoIt(typeinfo(i))  where DoIt is in another unit and has TTypeInfo
 - $OPTIMIZATION ON|OFF
 - $optimization REMOVEEMPTYPROCS
 - $optimization REMOVEEMPTYPROCS,RemoveNotUsedDeclarations-
 - setlength(dynarray)  modeswitch to not create a copy
-- 'new', 'Function' -> class var use .prototype
 - static arrays
   - clone multi dim static array
 - RTTI
@@ -428,50 +430,22 @@ ToDos:
 - stdcall of methods: pass original 'this' as first parameter
 - property read Arr[0]  https://bugs.freepascal.org/view.php?id=33416
 - write, writeln
-- array of const
 - call array of proc element without ()
 - enums with custom values
 - library
 - constref
 - option overflow checking -Co
   +, -, *, Succ, Pred, Inc, Dec
-  -Co   : Overflow checking of integer operations
   -CO   : Check for possible overflow of integer operations
 -C3 : Turn on ieee error checking for constants
 - optimizations:
-  - move rtl.js functions to system.pp
-  - add $mod only if needed
-  - add Self only if needed
-  - use a number for small sets
-  - put set literals into constants
-  - shortcut for test set is empty  a=[]  a<>[]
-  - set operators on literals without temporary arrays, a in [b], [a]*b<>[]
-  - combine multiple var a=0,b=0
-  - init a local var with the first assignment
-  - skip clone array for new array and arraysetlength
-  - SetLength(scope.a,l) -> read scope only once, same for
-    Include, Exclude, Inc, Dec, +=, -=, *=, /=
-  - inline  -Si
-  - autoinline
-  -O1 insert unit vars for complex literals
-  -O1 no function Result var when assigned only once
-  -O1 replace constant expression with result
-  -O1 pass array element by ref: when index is constant, use that directly
-  -O1 case-of with 6+ elements as binary tree
-  -O2 insert local/unit vars for global type references:
-      at start of intf var $r1=null;
-      at end of impl: $r1=path;
-  -O2 removeemptyprocs
-  -O2 skip dead code If(false){...}
-  -O2 CSE
-  -O3 DFA
+  see https://wiki.lazarus.freepascal.org/Pas2js_optimizations
 - objects
 - generics
 - operator overloading
   - operator enumerator
 - inline
 - extended RTTI
-- attributes
 
 Debugging this unit: -d<x>
    VerbosePas2JS
@@ -562,6 +536,7 @@ const
   ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter
   IsExtModePasClassInstance = 1;
   IsExtModePasClass = 2;
+  LocalVarHide = '-';
 
 type
   TPas2JSBuiltInName = (
@@ -645,6 +620,7 @@ type
     pbifnRTTINewClassRef,// typeinfo of tkClassRef $ClassRef
     pbifnRTTINewDynArray,// typeinfo of tkDynArray $DynArray
     pbifnRTTINewEnum,// typeinfo of tkEnumeration $Enum
+    pbifnRTTINewExtClass,// typeinfo creator of tkExtClass $ExtClass
     pbifnRTTINewInt,// typeinfo of tkInt $Int
     pbifnRTTINewInterface,// typeinfo creator of tkInterface $Interface
     pbifnRTTINewMethodVar,// typeinfo of tkMethod $MethodVar
@@ -701,16 +677,18 @@ type
     pbivnRTTIInt_MinValue,
     pbivnRTTIInt_OrdType,
     pbivnRTTILocal, // $r
-    pbivnRTTIMemberAttributes,
+    pbivnRTTIMemberAttributes, // attr
     pbivnRTTIMethodKind, // tTypeInfoMethodVar has methodkind
-    pbivnRTTIPointer_RefType,
-    pbivnRTTIProcFlags,
-    pbivnRTTIProcVar_ProcSig,
-    pbivnRTTIPropDefault,
-    pbivnRTTIPropIndex,
-    pbivnRTTIPropStored,
-    pbivnRTTISet_CompType,
-    pbivnRTTITypeAttributes,
+    pbivnRTTIPointer_RefType, // reftype
+    pbivnRTTIProcFlags, // flags
+    pbivnRTTIProcVar_ProcSig, // procsig
+    pbivnRTTIPropDefault, // Default
+    pbivnRTTIPropIndex, // index
+    pbivnRTTIPropStored, // stored
+    pbivnRTTISet_CompType, // comptype
+    pbivnRTTITypeAttributes, // attr
+    pbivnRTTIExtClass_Ancestor, // ancestor
+    pbivnRTTIExtClass_JSClass, // jsclass
     pbivnSelf,
     pbivnTObjectDestroy,
     pbivnWith,
@@ -722,6 +700,7 @@ type
     pbitnTIClassRef,
     pbitnTIDynArray,
     pbitnTIEnum,
+    pbitnTIExtClass,
     pbitnTIHelper,
     pbitnTIInteger,
     pbitnTIInterface,
@@ -816,6 +795,7 @@ const
     '$ClassRef',
     '$DynArray',
     '$Enum',
+    '$ExtClass',
     '$Int',
     '$Interface',
     '$MethodVar',
@@ -881,6 +861,8 @@ const
     'stored', // pbivnRTTIPropStored
     'comptype', // pbivnRTTISet_CompType
     'attr', // pbivnRTTITypeAttributes
+    'ancestor', // pbivnRTTIExtClass_Ancestor
+    'jsclass', // pbivnRTTIExtClass_JSClass
     '$Self', // pbivnSelf
     'tObjectDestroy', // rtl.tObjectDestroy  pbivnTObjectDestroy
     '$with', // pbivnWith
@@ -891,6 +873,7 @@ const
     'tTypeInfoClassRef', // pbitnTIClassRef
     'tTypeInfoDynArray', // pbitnTIDynArray
     'tTypeInfoEnum', // pbitnTIEnum
+    'tTypeInfoExtClass', // pbitnTIExtClass
     'tTypeInfoHelper', // pbitnTIHelper
     'tTypeInfoInteger', // pbitnTIInteger
     'tTypeInfoInterface', // pbitnTIInterface
@@ -1217,7 +1200,8 @@ const
     msArrayOperators,
     msPrefixedAttributes,
     msOmitRTTI,
-    msMultiHelpers];
+    msMultiHelpers,
+    msImplicitFunctionSpec];
 
   bsAllPas2jsBoolSwitchesReadOnly = [
     bsLongStrings
@@ -1870,7 +1854,7 @@ type
     Function CreateCloneStaticArray(El: TPasElement; ArrTypeEl: TPasArrayType;
       ArrayExpr: TJSElement; AContext: TConvertContext): TJSElement; virtual;
     // class
-    Procedure AddInstanceMemberFunction(El: TPasClassType; Src: TJSSourceElements;
+    Procedure AddClassConDestructorFunction(El: TPasClassType; Src: TJSSourceElements;
       ClassContext: TConvertContext; IsTObject: boolean; Ancestor: TPasType;
       Kind: TMemberFunc);
     Procedure AddClassRTTI(El: TPasClassType; Src: TJSSourceElements;
@@ -1902,6 +1886,7 @@ type
       AContext: TConvertContext): TJSElement; virtual;
     Procedure AddRTTIArgument(Arg: TPasArgument; TargetParams: TJSArrayLiteral;
       AContext: TConvertContext); virtual;
+    Function GetClassBIName(El: TPasClassType): string; virtual;
     Function CreateRTTINewType(El: TPasType; const CallFuncName: string;
       IsForward: boolean; AContext: TConvertContext; out ObjLit: TJSObjectLiteral): TJSCallExpression; virtual;
     Function CreateRTTIAttributes(const Attr: TPasExprArray; PosEl: TPasElement; aContext: TConvertContext): TJSElement; virtual;
@@ -2037,6 +2022,7 @@ type
     Function ConvertClassType(El: TPasClassType; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertClassForwardType(El: TPasClassType; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertClassOfType(El: TPasClassOfType; AContext: TConvertContext): TJSElement; virtual;
+    Function ConvertExtClassType(El: TPasClassType; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertEnumType(El: TPasEnumType; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertSetType(El: TPasSetType; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertRangeType(El: TPasRangeType; AContext: TConvertContext): TJSElement; virtual;
@@ -2312,7 +2298,7 @@ begin
     end;
   {$ENDIF}
   {$IFDEF VerbosePasResolver}
-  if FindElevatedLocal(Item.Identifier)<>Item then
+  if Find(Item.Identifier)<>Item then
     raise Exception.Create('20160925183849');
   {$ENDIF}
 end;
@@ -2858,6 +2844,8 @@ begin
     if ProcScope.DeclarationProc<>nil then
       // implementation proc -> only count the header -> skip
       exit(false);
+    if ProcScope.SpecializedFromItem<>nil then
+      exit(false);
     end;
   Result:=true;
 end;
@@ -4075,13 +4063,7 @@ begin
               // constructor of external class can't be overriden -> forbid virtual
               RaiseMsg(20170323100447,nInvalidXModifierY,sInvalidXModifierY,
                 [Proc.ElementTypeName,'virtual,external'],Proc);
-            ExtName:=ComputeConstString(Proc.LibrarySymbolName,true,true);
-            if CompareText(Proc.Name,'new')=0 then
-              begin
-              if ExtName<>Proc.Name then
-                RaiseMsg(20170323083511,nVirtualMethodNameMustMatchExternal,
-                  sVirtualMethodNameMustMatchExternal,[],Proc.LibrarySymbolName);
-              end;
+            ComputeConstString(Proc.LibrarySymbolName,true,true);
             end
           else
             RaiseMsg(20170322163210,nPasElementNotSupported,sPasElementNotSupported,
@@ -4881,6 +4863,9 @@ var
   TypeEl: TPasType;
   FoundClass: TPasClassType;
   ScopeDepth: Integer;
+  TemplType: TPasGenericTemplateType;
+  ConEl: TPasElement;
+  ConToken: TToken;
 begin
   Param:=Params.Params[0];
   ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
@@ -4939,7 +4924,11 @@ begin
       TIName:=Pas2JSBuiltInNames[pbitnTIRecord]
     else if C=TPasClassType then
       case TPasClassType(TypeEl).ObjKind of
-      okClass: TIName:=Pas2JSBuiltInNames[pbitnTIClass];
+      okClass:
+        if TPasClassType(TypeEl).IsExternal then
+          TIName:=Pas2JSBuiltInNames[pbitnTIExtClass]
+        else
+          TIName:=Pas2JSBuiltInNames[pbitnTIClass];
       okInterface: TIName:=Pas2JSBuiltInNames[pbitnTIInterface];
       okClassHelper,okRecordHelper,okTypeHelper: TIName:=Pas2JSBuiltInNames[pbitnTIHelper];
       else
@@ -4960,7 +4949,37 @@ begin
         TIName:=Pas2JSBuiltInNames[pbitnTIDynArray];
       end
     else if C=TPasPointerType then
-      TIName:=Pas2JSBuiltInNames[pbitnTIPointer];
+      TIName:=Pas2JSBuiltInNames[pbitnTIPointer]
+    else if C=TPasGenericTemplateType then
+      begin
+      TemplType:=TPasGenericTemplateType(TypeEl);
+      if length(TemplType.Constraints)>0 then
+        begin
+        ConEl:=TemplType.Constraints[0];
+        ConToken:=GetGenericConstraintKeyword(ConEl);
+        case ConToken of
+        tkrecord: TIName:=Pas2JSBuiltInNames[pbitnTIRecord];
+        tkclass,tkConstructor: TIName:=Pas2JSBuiltInNames[pbitnTIClass];
+        else
+          if not (ConEl is TPasType) then
+            RaiseNotYetImplemented(20191018180031,ConEl,GetObjPath(Param));
+          if ConEl is TPasClassType then
+            begin
+            if TPasClassType(ConEl).IsExternal then
+              TIName:=Pas2JSBuiltInNames[pbitnTIExtClass]
+            else
+              TIName:=Pas2JSBuiltInNames[pbitnTIClass];
+            end
+          else
+            RaiseNotYetImplemented(20191018180131,ConEl,GetObjPath(Param));
+        end;
+        end;
+      if TIName='' then
+        begin
+        // generic template without constraints
+        TIName:=Pas2JSBuiltInNames[pbitnTI];
+        end;
+      end;
     end
   else if ParamResolved.BaseType=btSet then
     begin
@@ -4989,7 +5008,7 @@ begin
     else if ParamResolved.BaseType in [btChar,btBoolean] then
       TIName:=Pas2JSBuiltInNames[pbitnTI]
     end;
-  //writeln('TPas2JSResolver.BI_TypeInfo_OnGetCallResult TIName=',TIName);
+  //writeln('TPas2JSResolver.BI_TypeInfo_OnGetCallResult TIName=',TIName,' ',GetObjName(TypeEl));
   if TIName='' then
     begin
     {$IFDEF VerbosePas2JS}
@@ -5818,12 +5837,30 @@ end;
 function TPas2JSResolver.GetOverloadName(El: TPasElement): string;
 var
   Data: TObject;
+  ProcScope, GenScope: TPas2JSProcedureScope;
+  GenEl: TPasElement;
 begin
   Data:=El.CustomData;
   if Data is TPas2JSProcedureScope then
     begin
-    Result:=TPas2JSProcedureScope(Data).OverloadName;
-    if Result<>'' then exit;
+    ProcScope:=TPas2JSProcedureScope(Data);
+    if ProcScope.SpecializedFromItem<>nil then
+      begin
+      // specialized proc -> generic name + 's' + index
+      GenEl:=ProcScope.SpecializedFromItem.GenericEl;
+      GenScope:=TPas2JSProcedureScope(GenEl.CustomData);
+      Result:=GenScope.OverloadName;
+      if Result='' then
+        Result:=GenEl.Name+'$';
+      Result:=Result+'s'+IntToStr(ProcScope.SpecializedFromItem.Index);
+      end
+    else
+      begin
+      Result:=ProcScope.OverloadName;
+      if Result='' then
+        Result:=El.Name;
+      end;
+    exit;
     end;
   Result:=El.Name;
 end;
@@ -5841,8 +5878,6 @@ function TPas2JSResolver.HasTypeInfo(El: TPasType): boolean;
 begin
   Result:=inherited HasTypeInfo(El);
   if not Result then exit;
-  if (El.ClassType=TPasClassType) and TPasClassType(El).IsExternal then
-    exit(false);
   if El.Parent is TProcedureBody then
     Result:=false;
 end;
@@ -6191,7 +6226,11 @@ begin
   if El=nil then exit('');
   V:=FindLocalIdentifier(El);
   if V<>nil then
-    Result:=V.Name
+    begin
+    Result:=V.Name;
+    if Result=LocalVarHide then
+      Result:='';
+    end
   else if ThisPas=El then
     Result:='this'
   else
@@ -6315,12 +6354,17 @@ end;
 function TConvertContext.GetSelfContext: TFunctionContext;
 var
   Ctx: TConvertContext;
+  FuncContext: TFunctionContext;
 begin
   Ctx:=Self;
   while Ctx<>nil do
     begin
-    if (Ctx is TFunctionContext) and (TFunctionContext(Ctx).ThisPas is TPasMembersType) then
-      exit(TFunctionContext(Ctx));
+    if (Ctx is TFunctionContext) then
+      begin
+      FuncContext:=TFunctionContext(Ctx);
+      if FuncContext.ThisPas is TPasMembersType then
+        exit(FuncContext);
+      end;
     Ctx:=Ctx.Parent;
     end;
   Result:=nil;
@@ -9951,6 +9995,13 @@ begin
     DotBin:=TBinaryExpr(Value);
     Value:=DotBin.right;
     end;
+  if (not (Value.CustomData is TResolvedReference))
+      and (aResolver<>nil)
+      and (Value is TInlineSpecializeExpr) then
+    begin
+    //  Value<>()
+    Value:=TInlineSpecializeExpr(Value).NameExpr;
+    end;
 
   if Value.CustomData is TResolvedReference then
     begin
@@ -10376,6 +10427,7 @@ begin
   Result:=nil;
   aResolver:=AContext.Resolver;
   NewExpr:=nil;
+  ExtName:='';
   ExtNameEl:=nil;
   try
     Proc:=Ref.Declaration as TPasConstructor;
@@ -10383,7 +10435,13 @@ begin
 
     if CompareText(Proc.Name,'new')=0 then
       begin
-      if Left<>nil then
+      if Proc.LibrarySymbolName<>nil then
+        begin
+        ExtName:=ComputeConstString(Proc.LibrarySymbolName,AContext,true);
+        if not SameText(ExtName,'new') then
+          ExtNameEl:=CreatePrimitiveDotExpr(ExtName,PosEl);
+        end;
+      if (ExtNameEl=nil) and (Left<>nil) then
         begin
         if aResolver<>nil then
           begin
@@ -13398,7 +13456,7 @@ begin
       begin
       P:=TPasElement(El.Declarations[i]);
       {$IFDEF VerbosePas2JS}
-      //writeln('TPasToJSConverter.ConvertDeclarations El[',i,']=',GetObjName(P));
+      writeln('TPasToJSConverter.ConvertDeclarations El[',i,']=',GetObjName(P));
       {$ENDIF}
       if not IsElementUsed(P) then continue;
 
@@ -13552,12 +13610,9 @@ begin
   if El.Parent is TProcedureBody then
     RaiseNotSupported(El,AContext,20181231004355);
   if El.IsForward then
-    begin
-    Result:=ConvertClassForwardType(El,AContext);
-    exit;
-    end;
-
-  if El.IsExternal then exit;
+    exit(ConvertClassForwardType(El,AContext))
+  else if El.IsExternal then
+    exit(ConvertExtClassType(El,AContext));
 
   if El.CustomData is TPas2JSClassScope then
     begin
@@ -13716,9 +13771,9 @@ begin
       if El.ObjKind in [okClass] then
         begin
         // instance initialization function
-        AddInstanceMemberFunction(El,Src,FuncContext,IsTObject,Ancestor,mfInit);
+        AddClassConDestructorFunction(El,Src,FuncContext,IsTObject,Ancestor,mfInit);
         // instance finalization function
-        AddInstanceMemberFunction(El,Src,FuncContext,IsTObject,Ancestor,mfFinalize);
+        AddClassConDestructorFunction(El,Src,FuncContext,IsTObject,Ancestor,mfFinalize);
         end;
 
       if El.ObjKind in ([okClass]+okAllHelpers) then
@@ -13805,7 +13860,7 @@ begin
   if IsClassRTTICreatedBefore(aClass,El,AContext) then exit;
   // module.$rtti.$Class("classname");
   case aClass.ObjKind of
-  okClass: Creator:=GetBIName(pbifnRTTINewClass);
+  okClass: Creator:=GetClassBIName(aClass);
   okInterface: Creator:=GetBIName(pbifnRTTINewInterface);
   else
     RaiseNotSupported(El,AContext,20190128102749);
@@ -13828,7 +13883,7 @@ var
   Call: TJSCallExpression;
   ok: Boolean;
   List: TJSStatementList;
-  DestType: TPasType;
+  DestType: TPasClassType;
 begin
   Result:=nil;
   if not HasTypeInfo(El,AContext) then exit;
@@ -13841,16 +13896,16 @@ begin
   try
     Prop:=ObjLit.Elements.AddElement;
     Prop.Name:=TJSString(GetBIName(pbivnRTTIClassRef_InstanceType));
-    DestType:=AContext.Resolver.ResolveAliasType(El.DestType);
+    DestType:=AContext.Resolver.ResolveAliasType(El.DestType) as TPasClassType;
     Prop.Expr:=CreateTypeInfoRef(DestType,AContext,El);
 
-    if not IsClassRTTICreatedBefore(DestType as TPasClassType,El,AContext) then
+    if not IsClassRTTICreatedBefore(DestType,El,AContext) then
       begin
       // class rtti must be forward registered
       if not (AContext is TFunctionContext) then
         RaiseNotSupported(El,AContext,20170412102916);
       // prepend   module.$rtti.$Class("classname");
-      Call:=CreateRTTINewType(DestType,GetBIName(pbifnRTTINewClass),true,AContext,ObjLit);
+      Call:=CreateRTTINewType(DestType,GetClassBIName(DestType),true,AContext,ObjLit);
       if ObjLit<>nil then
         RaiseInconsistency(20170412102654,El);
       List:=TJSStatementList(CreateElement(TJSStatementList,El));
@@ -13865,6 +13920,59 @@ begin
   end;
 end;
 
+function TPasToJSConverter.ConvertExtClassType(El: TPasClassType;
+  AContext: TConvertContext): TJSElement;
+//   module.$rtti.$ExtClass("TJSObject",{
+//     ancestor: ancestortypeinfo,
+//     jsclass: "Object"
+//   });
+var
+  TIObj: TJSObjectLiteral;
+  Call: TJSCallExpression;
+  TIProp: TJSObjectLiteralElement;
+  ClassScope: TPas2JSClassScope;
+  AncestorType: TPasClassType;
+begin
+  Result:=nil;
+  if not El.IsExternal then
+    RaiseNotSupported(El,AContext,20191027183236);
+
+  if not HasTypeInfo(El,AContext) then
+    exit;
+  // create typeinfo
+  if not (AContext is TFunctionContext) then
+    RaiseNotSupported(El,AContext,20191027182023,'typeinfo');
+  if El.Parent is TProcedureBody then
+    RaiseNotSupported(El,AContext,20191027182019);
+
+  ClassScope:=El.CustomData as TPas2JSClassScope;
+  if ClassScope.AncestorScope<>nil then
+    AncestorType:=ClassScope.AncestorScope.Element as TPasClassType
+  else
+    AncestorType:=nil;
+
+  Call:=nil;
+  try
+    // module.$rtti.$ExtClass("TMyClass",{...});
+    Call:=CreateRTTINewType(El,GetBIName(pbifnRTTINewExtClass),false,AContext,TIObj);
+    if AncestorType<>nil then
+      begin
+      // add  ancestor: ancestortypeinfo
+      TIProp:=TIObj.Elements.AddElement;
+      TIProp.Name:=TJSString(GetBIName(pbivnRTTIExtClass_Ancestor));
+      TIProp.Expr:=CreateTypeInfoRef(AncestorType,AContext,El);
+      end;
+    // add  jsclass: "extname"
+    TIProp:=TIObj.Elements.AddElement;
+    TIProp.Name:=TJSString(GetBIName(pbivnRTTIExtClass_JSClass));
+    TIProp.Expr:=CreateLiteralString(El,TPasClassType(El).ExternalName);
+    Result:=Call;
+  finally
+    if Result=nil then
+      Call.Free;
+  end;
+end;
+
 function TPasToJSConverter.ConvertEnumType(El: TPasEnumType;
   AContext: TConvertContext): TJSElement;
 // TMyEnum = (red, green)
@@ -13875,7 +13983,7 @@ function TPasToJSConverter.ConvertEnumType(El: TPasEnumType;
 //     "0":"green",
 //     "green":0,
 //   };
-//   module.$rtti.$TIEnum("TMyEnum",{
+//   module.$rtti.$Enum("TMyEnum",{
 //     enumtype: this.TMyEnum,
 //     minvalue: 0,
 //     maxvalue: 1
@@ -14643,7 +14751,7 @@ Var
   SelfSt: TJSVariableStatement;
   ImplProc: TPasProcedure;
   BodyPas: TProcedureBody;
-  PosEl, ThisPas: TPasElement;
+  PosEl, ThisPas, ClassOrRec: TPasElement;
   Call: TJSCallExpression;
   ClassPath: String;
   ArgResolved: TPasResolverResult;
@@ -14652,6 +14760,7 @@ Var
   ArgTypeEl, HelperForType: TPasType;
   aResolver: TPas2JSResolver;
   IsClassConDestructor: Boolean;
+  LocalVar: TFCLocalIdentifier;
 begin
   Result:=nil;
 
@@ -14663,11 +14772,12 @@ begin
     exit;
   IsClassConDestructor:=(El.ClassType=TPasClassConstructor)
                      or (El.ClassType=TPasClassDestructor);
+  aResolver:=AContext.Resolver;
+  if not aResolver.IsFullySpecialized(El) then exit;
 
   {$IFDEF VerbosePas2JS}
   writeln('TPasToJSConverter.ConvertProcedure "',El.Name,'" Overload="',ProcScope.OverloadName,'" ',El.Parent.ClassName);
   {$ENDIF}
-  aResolver:=AContext.Resolver;
 
   ImplProc:=El;
   if ProcScope.ImplProc<>nil then
@@ -14780,8 +14890,10 @@ begin
         if not AContext.IsGlobal then
           begin
           // nested sub procedure  ->  no 'this'
-          FuncContext.ThisPas:=nil;
+          ThisPas:=nil;
           end
+        else if El.IsStatic then
+          ThisPas:=nil
         else
           begin
           ThisPas:=ProcScope.ClassRecScope.Element;
@@ -14796,7 +14908,11 @@ begin
               // 'this' in a type helper is a temporary getter/setter JS object
               ThisPas:=nil;
             end;
-          FuncContext.ThisPas:=ThisPas;
+          end;
+        FuncContext.ThisPas:=ThisPas;
+
+        if ThisPas<>nil then
+          begin
           if (bsObjectChecks in FuncContext.ScannerBoolSwitches)
               and (ThisPas is TPasMembersType) then
             begin
@@ -14809,14 +14925,13 @@ begin
             ClassPath:=CreateReferencePath(ProcScope.ClassRecScope.Element,AContext,rpkPathAndName);
             Call.AddArg(CreatePrimitiveDotExpr(ClassPath,PosEl));
             end;
-
           if (ImplProc.Body.Functions.Count>0)
               or aResolver.HasAnonymousFunctions(ImplProc.Body.Body) then
             begin
             // has nested procs -> add "var self = this;"
-            FuncContext.AddLocalVar(GetBIName(pbivnSelf),FuncContext.ThisPas);
+            FuncContext.AddLocalVar(GetBIName(pbivnSelf),ThisPas);
             SelfSt:=CreateVarStatement(GetBIName(pbivnSelf),
-                                CreatePrimitiveDotExpr('this',ImplProc),ImplProc);
+                              CreatePrimitiveDotExpr('this',ImplProc),ImplProc);
             AddBodyStatement(SelfSt,PosEl);
             if ImplProcScope.SelfArg<>nil then
               begin
@@ -14829,6 +14944,23 @@ begin
             // no nested procs ->  redirect Pascal-Self to JS-this
             FuncContext.AddLocalVar('this',ImplProcScope.SelfArg);
             end;
+          end
+        else
+          begin
+          // no "this"
+          if ProcScope.ClassRecScope<>nil then
+            begin
+            // static method -> hide local
+            ClassOrRec:=ProcScope.ClassRecScope.Element;
+            LocalVar:=FuncContext.FindLocalIdentifier(ClassOrRec);
+            if (LocalVar<>nil) and (LocalVar.Name='this') then
+              FuncContext.AddLocalVar(LocalVarHide,ClassOrRec);
+            end;
+          if ImplProcScope.SelfArg<>nil then
+            begin
+            // no nested procs ->  redirect Pascal-Self to JS-this
+            FuncContext.AddLocalVar('this',ImplProcScope.SelfArg);
+            end;
           end;
         end;
       {$IFDEF VerbosePas2JS}
@@ -16306,7 +16438,7 @@ begin
     end;
 end;
 
-procedure TPasToJSConverter.AddInstanceMemberFunction(El: TPasClassType;
+procedure TPasToJSConverter.AddClassConDestructorFunction(El: TPasClassType;
   Src: TJSSourceElements; ClassContext: TConvertContext; IsTObject: boolean;
   Ancestor: TPasType; Kind: TMemberFunc);
 const
@@ -17226,6 +17358,14 @@ begin
     Param.Elements.AddElement.Expr:=CreateLiteralNumber(Arg,Flags);
 end;
 
+function TPasToJSConverter.GetClassBIName(El: TPasClassType): string;
+begin
+  if El.IsExternal then
+    Result:=GetBIName(pbifnRTTINewExtClass)
+  else
+    Result:=GetBIName(pbifnRTTINewClass);
+end;
+
 function TPasToJSConverter.CreateRTTINewType(El: TPasType;
   const CallFuncName: string; IsForward: boolean; AContext: TConvertContext;
   out ObjLit: TJSObjectLiteral): TJSCallExpression;
@@ -21752,17 +21892,22 @@ var
   end;
 
   procedure Append_GetClass(Member: TPasElement);
+  var
+    P: TPasElement;
   begin
-    if Member.Parent is TPasClassType then
+    P:=Member.Parent;
+    if P=nil then
+      RaiseNotSupported(Member,AContext,20191018125004);
+    if P.ClassType=TPasClassType then
       begin
-      if TPasClassType(Member.Parent).IsExternal then
+      if TPasClassType(P).IsExternal then
         exit;
       if Result<>'' then
         Result:=Result+'.'+GetBIName(pbivnPtrClass)
       else
         Result:=GetBIName(pbivnPtrClass);
       end
-    else if Member.Parent is TPasRecordType then
+    else if P.ClassType=TPasRecordType then
       begin
       if Result<>'' then
         Result:=Result+'.'+GetBIName(pbivnPtrRecord)
@@ -21796,15 +21941,25 @@ var
   end;
 
   function IsA(SrcType, DstType: TPasType): boolean;
+  var
+    C: TClass;
   begin
     while SrcType<>nil do
       begin
       if SrcType=DstType then exit(true);
-      if SrcType.ClassType=TPasClassType then
+      C:=SrcType.ClassType;
+      if C=TPasClassType then
         SrcType:=TPas2JSClassScope(SrcType.CustomData).DirectAncestor
-      else if (SrcType.ClassType=TPasAliasType)
-          or (SrcType.ClassType=TPasTypeAliasType) then
+      else if (C=TPasAliasType)
+          or (C=TPasTypeAliasType) then
         SrcType:=TPasAliasType(SrcType).DestType
+      else if C=TPasSpecializeType then
+        begin
+        if SrcType.CustomData is TPasSpecializeTypeData then
+          SrcType:=TPasSpecializeTypeData(SrcType.CustomData).SpecializedType
+        else
+          RaiseInconsistency(20191027172642,SrcType);
+        end
       else
         exit(false);
       end;
@@ -21861,7 +22016,8 @@ begin
     begin
     // El is local var -> does not need path
     end
-  else if ElClass.InheritsFrom(TPasProcedure) and (TPasProcedure(El).LibrarySymbolName<>nil)
+  else if ElClass.InheritsFrom(TPasProcedure)
+      and (TPasProcedure(El).LibrarySymbolName<>nil)
       and not (El.Parent is TPasMembersType) then
     begin
     // an external global function -> use the literal
@@ -21965,8 +22121,13 @@ begin
           else if (SelfContext<>nil)
               and IsA(TPasType(SelfContext.ThisPas),TPasMembersType(ParentEl)) then
             begin
-            ShortName:=SelfContext.GetLocalName(SelfContext.ThisPas);
-            Prepend(Result,ShortName);
+            ShortName:=AContext.GetLocalName(SelfContext.ThisPas);
+            if ShortName='' then
+              begin
+              if PrependClassName(Result,TPasMembersType(ParentEl)) then break;
+              end
+            else
+              Prepend(Result,ShortName);
             end
           else
             begin
@@ -21983,6 +22144,7 @@ begin
             //RaiseNotSupported(El,AContext,20180125004049);
             end;
           if (El.Parent=ParentEl) and (SelfContext<>nil)
+              and (SelfContext.PasElement is TPasProcedure)
               and not IsClassProc(SelfContext.PasElement) then
             begin
             // inside a method -> Self is a class instance
@@ -22317,7 +22479,8 @@ begin
                 Result:=Call;
                 Call.AddArg(CreateReferencePathExpr(ArgTypeEl,AContext));
                 end;
-              else RaiseNotSupported(El,AContext,20180401230251,InterfaceTypeNames[TPasClassType(ArgTypeEl).InterfaceType]);
+              else
+                RaiseNotSupported(El,AContext,20180401230251,InterfaceTypeNames[TPasClassType(ArgTypeEl).InterfaceType]);
               end;
               end
             else

+ 134 - 3
packages/pastojs/src/pas2jscompiler.pp

@@ -38,7 +38,7 @@ uses
   Classes, SysUtils, contnrs,
   jsbase, jstree, jswriter, JSSrcMap, fpjson,
   PScanner, PParser, PasTree, PasResolver, PasResolveEval, PasUseAnalyzer,
-  pas2jsresstrfile,
+  pas2jsresstrfile, pas2jsresources, pas2jshtmlresources, pas2jsjsresources,
   FPPas2Js, FPPJsSrcMap, Pas2jsLogger, Pas2jsFS, Pas2jsPParser, Pas2jsUseAnalyzer;
 
 const
@@ -150,11 +150,14 @@ type
     rvcUnit
     );
   TP2JSResourceStringFile = (rsfNone,rsfUnit,rsfProgram);
+  TResourceMode = (rmNone,rmHTML,rmJS);
 
 const
   DefaultP2jsCompilerOptions = [coShowErrors,coSourceMapXSSIHeader,coUseStrict];
   DefaultP2JSResourceStringFile = rsfProgram;
   DefaultP2jsRTLVersionCheck = rvcNone;
+  DefaultResourceMode = rmHTML;
+
   coShowAll = [coShowErrors..coShowDebug];
   coO1Enable = [coEnumValuesAsNumbers];
   coO1Disable = [coKeepNotUsedPrivates,coKeepNotUsedDeclarationsWPO];
@@ -350,6 +353,7 @@ type
     FPCUFilename: string;
     FPCUSupport: TPCUSupport;
     FReaderState: TPas2jsReaderState;
+    FResourceHandler: TPas2jsResourceHandler;
     FScanner: TPas2jsPasScanner;
     FShowDebug: boolean;
     FUnitFilename: string;
@@ -357,6 +361,7 @@ type
     FUsedBy: array[TUsedBySection] of TFPList; // list of TPas2jsCompilerFile
     function GetUsedBy(Section: TUsedBySection; Index: integer): TPas2jsCompilerFile;
     function GetUsedByCount(Section: TUsedBySection): integer;
+    procedure HandleResources(Sender: TObject; const aFileName: String; aOptions: TStrings);
     function OnConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean;
     function OnConverterIsTypeInfoUsed(Sender: TObject; El: TPasElement): boolean;
     procedure OnPasResolverLog(Sender: TObject; const Msg: String);
@@ -403,6 +408,7 @@ type
     function GetModuleName: string;
     class function GetFile(aModule: TPasModule): TPas2jsCompilerFile;
   public
+    Property ResourceHandler : TPas2jsResourceHandler Read FResourceHandler Write FResourceHandler;
     property PasFileName: String Read FPasFileName;
     property PasUnitName: string read FPasUnitName write FPasUnitName;// unit name in source, initialized from UnitFilename
     property Converter: TPasToJSConverter read FConverter;
@@ -497,6 +503,8 @@ type
     FSrcMapSourceRoot: string;
     FUnits: TPasAnalyzerKeySet; // set of TPas2jsCompilerFile, key is PasUnitName
     FWPOAnalyzer: TPas2JSAnalyzer;
+    FResourceMode : TResourceMode;
+    FResources : TPas2JSResourceHandler;
     FResourceStrings : TResourceStringsFile;
     FResourceStringFile :  TP2JSResourceStringFile;
     procedure AddInsertJSFilename(const aFilename: string);
@@ -551,6 +559,7 @@ type
     procedure SetWriteMsgToStdErr(const AValue: boolean);
     procedure WriteJSToFile(const MapFileName: string; aFileWriter: TPas2JSMapper);
     procedure WriteResourceStrings(aFileName: String);
+    procedure WriteResources(aFileName: String);
     procedure WriteSrcMap(const MapFileName: string; aFileWriter: TPas2JSMapper);
   private
     procedure AddDefinesForTargetPlatform;
@@ -561,6 +570,7 @@ type
   private
     // params, cfg files
     FCurParam: string;
+    FResourceOutputFile: String;
     procedure LoadConfig(CfgFilename: string);
     procedure ReadEnvironment;
     procedure ReadParam(Param: string; Quick, FromCmdLine: boolean);
@@ -603,7 +613,7 @@ type
     procedure CreateJavaScript(aFile: TPas2jsCompilerFile;
       Checked: TPasAnalyzerKeySet { set of TPas2jsCompilerFile, key is UnitFilename });
     procedure FinishSrcMap(SrcMap: TPas2JSSrcMap); virtual;
-    // WriteSingleJSFile does not
+    // WriteSingleJSFile does not recurse
     procedure WriteSingleJSFile(aFile: TPas2jsCompilerFile; CombinedFileWriter: TPas2JSMapper);
     // WriteJSFiles recurses uses clause
     procedure WriteJSFiles(aFile: TPas2jsCompilerFile;
@@ -618,6 +628,8 @@ type
     function GetExitCode: Longint; virtual;
     procedure SetExitCode(Value: Longint); virtual;
     Procedure SetWorkingDir(const aDir: String); virtual;
+    Procedure CreateResourceSupport; virtual;
+
   public
     constructor Create; virtual;
     destructor Destroy; override;
@@ -698,6 +710,8 @@ type
     property SrcMapBaseDir: string read FSrcMapBaseDir write SetSrcMapBaseDir; // includes trailing pathdelim
     property Namespaces: TStringList read FNamespaces;
     property NamespacesFromCmdLine: integer read FNamespacesFromCmdLine;
+    Property ResourceMode : TResourceMode Read FResourceMode Write FResourceMode;
+    Property ResourceOutputFile : String Read FResourceOutputFile Write FResourceOutputFile;
     // can be set optionally, will be freed by compiler
     property ConfigSupport: TPas2JSConfigSupport Read FConfigSupport Write FConfigSupport;
     property PostProcessorSupport: TPas2JSPostProcessorSupport Read FPostProcessorSupport Write FPostProcessorSupport;
@@ -1052,6 +1066,7 @@ begin
   Scanner.LogEvents:=PascalResolver.ScannerLogEvents;
   Scanner.OnLog:=@OnScannerLog;
   Scanner.OnFormatPath:[email protected];
+  Scanner.RegisterResourceHandler('*',@HandleResources);
 
   // create parser (Note: this sets some scanner options to defaults)
   FParser := TPas2jsPasParser.Create(Scanner, FileResolver, PascalResolver);
@@ -1147,6 +1162,13 @@ begin
   Result:=FUsedBy[Section].Count;
 end;
 
+procedure TPas2jsCompilerFile.HandleResources(Sender: TObject; const aFileName: String; aOptions: TStrings);
+begin
+  // maybe emit message ?
+  FResourceHandler.StartUnit(PasModule.Name);
+  FResourceHandler.HandleResource(aFileName,aOptions);
+end;
+
 function TPas2jsCompilerFile.OnConverterIsElementUsed(Sender: TObject;
   El: TPasElement): boolean;
 begin
@@ -1506,6 +1528,8 @@ begin
     Converter.OnIsElementUsed:=@OnConverterIsElementUsed;
     Converter.OnIsTypeInfoUsed:=@OnConverterIsTypeInfoUsed;
     FJSModule:=Converter.ConvertPasElement(PasModule,PascalResolver);
+    if FResourceHandler.Outputmode=romJS then
+      FJSModule:=FResourceHandler.WriteJS(PasUnitName,FJSModule);
   except
     on E: ECompilerTerminate do
       raise;
@@ -2633,6 +2657,55 @@ begin
 
 end;
 
+procedure TPas2jsCompiler.WriteResources(aFileName: String);
+
+Var
+  {$IFDEF Pas2js}
+  buf: TJSArray;
+  {$ELSE}
+  buf: TMemoryStream;
+  {$ENDIF}
+  S : TJSONStringType;
+begin
+    Log.LogMsg(nWritingFile,[FullFormatPath(aFilename)],'',0,0,False);
+    try
+      {$IFDEF Pas2js}
+      buf:=TJSArray.new;
+      {$ELSE}
+      buf:=TMemoryStream.Create;
+      {$ENDIF}
+      try
+        S:=FResources.AsString;
+        {$ifdef pas2js}
+        buf.push(S);
+        {$else}
+        buf.Write(S[1],length(S));
+        {$endif}
+        FS.SaveToFile(buf,aFilename);
+      finally
+        {$IFDEF Pas2js}
+        buf:=nil;
+        {$ELSE}
+        buf.Free;
+        {$ENDIF}
+      end;
+    except
+      on E: Exception do begin
+        if ShowDebug then
+          Log.LogExceptionBackTrace(E);
+        {$IFDEF FPC}
+        if E.Message<>SafeFormat(SFCreateError,[aFileName]) then
+        {$ENDIF}
+          Log.LogPlain('Error: '+E.Message);
+        Log.LogMsg(nUnableToWriteFile,[FullFormatPath(aFilename)]);
+        Terminate(ExitCodeWriteError);
+      end
+      {$IFDEF Pas2js}
+      else HandleJSException('[20181031190737] TPas2jsCompiler.WriteJSFiles',JSExceptValue);
+      {$ENDIF}
+    end;
+end;
+
 procedure TPas2jsCompiler.WriteSingleJSFile(aFile: TPas2jsCompilerFile; CombinedFileWriter: TPas2JSMapper);
 
   Procedure WriteToStandardOutput(aFileWriter : TPas2JSMapper);
@@ -2674,7 +2747,7 @@ procedure TPas2jsCompiler.WriteSingleJSFile(aFile: TPas2jsCompilerFile; Combined
 Var
   aFileWriter : TPas2JSMapper;
   isSingleFile : Boolean;
-  MapFilename : String;
+  ResFileName,MapFilename : String;
 
 begin
   aFileWriter:=CombinedFileWriter;
@@ -2685,11 +2758,16 @@ begin
       begin
       aFileWriter:=CreateFileWriter(aFile,'');
       if aFile.IsMainFile and Not AllJSIntoMainJS then
+        begin
         InsertCustomJSFiles(aFileWriter);
+        if FResources.OutputMode=romExtraJS then
+          aFileWriter.WriteFile(FResources.AsString,GetResolvedMainJSFile);
+        end;
       end;
 
     if FResourceStringFile<>rsfNone then
       AddUnitResourceStrings(aFile);
+    FResources.DoneUnit(aFile.isMainFile);
     EmitJavaScript(aFile,aFileWriter);
 
 
@@ -2719,6 +2797,16 @@ begin
       if (FResourceStringFile=rsfUnit) or (aFile.IsMainFile and (FResourceStringFile<>rsfNone)) then
         if FResourceStrings.StringsCount>0 then
           WriteResourceStrings(ChangeFileExt(aFileWriter.DestFileName,'.jrs'));
+//      Writeln('IsSingleFile ',isSingleFile,' mainfile: ',aFile.IsMainFile,' filename: ', aFileWriter.DestFileName);
+      if aFile.isMainFile and (FResources.OutputMode=romFile) and (FResources.ResourceCount>0) then
+        begin
+        ResFileName:=FResourceOutputFile;
+        if ResFileName='' then
+          // default is projectname-res.ext, to avoid projectname.html, used in web projects in Lazarus IDE
+          ResFileName:=ChangeFileExt(aFileWriter.DestFileName,'-res'+FResources.OutputFileExtension);
+        WriteResources(ResFileName);
+        end;
+
       // write source map
       if aFileWriter.SrcMap<>nil then
         WriteSrcMap(MapFileName,aFileWriter);
@@ -2759,17 +2847,21 @@ begin
   if Checked.ContainsItem(aFile) then exit;
   Checked.Add(aFile);
 
+
   aFileWriter:=CombinedFileWriter;
   if AllJSIntoMainJS and (aFileWriter=nil) then
     begin
     // create CombinedFileWriter
     aFileWriter:=CreateFileWriter(aFile,GetResolvedMainJSFile);
     InsertCustomJSFiles(aFileWriter);
+    if FResources.OutputMode=romExtraJS then
+      aFileWriter.WriteFile(FResources.AsString,GetResolvedMainJSFile);
     end;
   Try
     // convert dependencies
     CheckUsesClause(aFileWriter,aFile.GetPasMainUsesClause);
     CheckUsesClause(aFileWriter,aFile.GetPasImplUsesClause);
+
     // Write me...
     WriteSingleJSFile(aFile,aFileWriter);
   finally
@@ -2879,6 +2971,15 @@ begin
   if aDir='' then ;
 end;
 
+procedure TPas2jsCompiler.CreateResourceSupport;
+begin
+  Case FResourceMode of
+    rmNone : FResources:=TNoResources.Create(FS);
+    rmHTML : FResources:=THTMLResourceLinkHandler.Create(FS);
+    rmJS : FResources:=TJSResourceHandler.Create(FS);
+  end;
+end;
+
 procedure TPas2jsCompiler.Terminate(TheExitCode: integer);
 begin
   ExitCode:=TheExitCode;
@@ -3442,6 +3543,27 @@ begin
     else
       ParamFatal('invalid resource string file format (-Jr) "'+aValue+'"');
     end;
+  'R': // -JR<...>
+    begin
+    I:=Pos('=',aValue);
+    if I=0 then
+      I:=Length(aValue)+1;
+    S:=Copy(aValue,1,I-1);
+    if S='' then
+      ParamFatal('missing value for -JR option')
+    else if (S='none') then
+      FResourceMode:=rmNone
+    else if (S='js') then
+      FResourceMode:= rmJS
+    else if (S='html') then
+      begin
+      FResourceMode:=rmHTML;
+      S:=Copy(aValue,I+1,Length(aValue)-I);
+      FResourceOutputFile:=S;
+      if (FResourceOutputFile<>'') and (ExtractFileExt(FResourceOutputFile)='') then
+        FResourceOutputFile:=FResourceOutputFile+'.html';
+      end;
+    end;
   'u': // -Ju<foreign path>
     if not Quick then
       begin
@@ -4028,6 +4150,7 @@ begin
 
   FFiles:=CreateSetOfCompilerFiles(kcFilename);
   FUnits:=CreateSetOfCompilerFiles(kcUnitName);
+  FResourceMode:=DefaultResourceMode;
   FResourceStrings:=TResourceStringsFile.Create;
   FReadingModules:=TFPList.Create;
   InitParamMacros;
@@ -4323,6 +4446,9 @@ begin
     for i:=0 to ParamList.Count-1 do
       ReadParam(ParamList[i],false,true);
 
+    // At this point we know what kind of resources we must use
+    CreateResourceSupport;
+
     // now we know, if the logo can be displayed
     if ShowLogo then
       WriteLogo;
@@ -4514,6 +4640,10 @@ begin
   w('     -Jrnone: Do not write resource string file');
   w('     -Jrunit: Write resource string file per unit with all resource strings');
   w('     -Jrprogram: Write resource string file per program with all used resource strings in program');
+  w('   -Jr<x> Control writing of linked resources');
+  w('     -JRnone: Do not write resources');
+  w('     -JRjs: Write resources in Javascript structure');
+  w('     -JRhtml[=filename] : Write resources as preload links in HTML file (default is projectfile-res.html)');
   w('   -Jpcmd<command>: Run postprocessor. For each generated js execute command passing the js as stdin and read the new js from stdout. This option can be added multiple times to call several postprocessors in succession.');
   w('   -Ju<x>: Add <x> to foreign unit paths. Foreign units are not compiled.');
   WritePrecompiledFormats;
@@ -4809,6 +4939,7 @@ begin
     aPasTree.ParserLogEvents:=aPasTree.ParserLogEvents+[pleInterface,pleImplementation];
 
   // scanner
+  aFile.ResourceHandler:=FResources;;
   aFile.CreateScannerAndParser(FS.CreateResolver);
 
   if ShowDebug then

+ 48 - 0
packages/pastojs/src/pas2jsfilecache.pp

@@ -228,6 +228,7 @@ type
     FOnReadFile: TPas2jsReadFileEvent;
     FOnWriteFile: TPas2jsWriteFileEvent;
     FResetStamp: TChangeStamp;
+    FResourcePaths: TStringList;
     FUnitPaths: TStringList;
     FUnitPathsFromCmdLine: integer;
     FPCUPaths: TStringList;
@@ -257,6 +258,7 @@ type
     function FindCustomJSFileName(const aFilename: string): String; override;
     function FindUnitJSFileName(const aUnitFilename: string): String; override;
     function FindUnitFileName(const aUnitname, InFilename, ModuleDir: string; out IsForeign: boolean): String; override;
+    function FindResourceFileName(const aFilename, ModuleDir: string): String; override;
     function FindIncludeFileName(const aFilename, ModuleDir: string): String; override;
     function AddIncludePaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
     function AddUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
@@ -286,6 +288,7 @@ type
   public
     property BaseDirectory: string read FBaseDirectory write SetBaseDirectory; // includes trailing pathdelim
     property ForeignUnitPaths: TStringList read FForeignUnitPaths;
+    property ResourcePaths : TStringList read FResourcePaths;
     property ForeignUnitPathsFromCmdLine: integer read FForeignUnitPathsFromCmdLine;
     property IncludePaths: TStringList read FIncludePaths;
     property IncludePathsFromCmdLine: integer read FIncludePathsFromCmdLine;
@@ -1453,6 +1456,7 @@ begin
   FIncludePaths:=TStringList.Create;
   FForeignUnitPaths:=TStringList.Create;
   FUnitPaths:=TStringList.Create;
+  FResourcePaths:=TStringList.Create;
   FFiles:=TPasAnalyzerKeySet.Create(
     {$IFDEF Pas2js}
     @Pas2jsCachedFileToKeyName,@PtrFilenameToKeyName
@@ -1977,6 +1981,50 @@ begin
   Result:='';
 end;
 
+function TPas2jsFilesCache.FindResourceFileName(const aFilename, ModuleDir: string): String;
+
+var
+  SearchedDirs: TStringList;
+
+  function SearchInDir(Dir: string; var Filename: string): boolean;
+  // search in Dir for pp, pas, p times given case, lower case, upper case
+  begin
+    Dir:=IncludeTrailingPathDelimiter(Dir);
+    if IndexOfFile(SearchedDirs,Dir)>=0 then exit(false);
+    SearchedDirs.Add(Dir);
+    if SearchLowUpCase(Filename) then exit(true);
+    Result:=false;
+  end;
+
+var
+  i: Integer;
+
+begin
+  //writeln('TPas2jsFilesCache.FindUnitFileName "',aUnitname,'" ModuleDir="',ModuleDir,'"');
+  Result:='';
+  SearchedDirs:=TStringList.Create;
+  try
+    Result:=SetDirSeparators(aFilename);
+
+    // First search in ModuleDir
+    if SearchInDir(ModuleDir,Result) then
+      exit;
+
+    // Then in resource paths
+    for i:=0 to ResourcePaths.Count-1 do
+      if SearchInDir(ResourcePaths[i],Result) then
+        exit;
+    // Not sure
+    // finally search in unit paths
+    // for i:=0 to UnitPaths.Count-1 do
+    //  if SearchInDir(UnitPaths[i],Result) then exit;
+  finally
+    SearchedDirs.Free;
+  end;
+
+  Result:='';
+end;
+
 function TPas2jsFilesCache.FindUnitJSFileName(const aUnitFilename: string): String;
 
 begin

+ 16 - 2
packages/pastojs/src/pas2jsfiler.pp

@@ -694,6 +694,7 @@ type
     procedure AddReferenceToArray(Arr: TJSONArray; El: TPasElement; WriteNull: boolean = true); virtual;
     procedure AddReferenceToObj(Obj: TJSONObject; const PropName: string;
       El: TPasElement; WriteNil: boolean = false); virtual;
+    procedure CreateAutoElReferenceId(Ref: TPCUFilerElementRef); virtual;
     procedure CreateElReferenceId(Ref: TPCUFilerElementRef); virtual;
     function CreateElementRef(El: TPasElement): TPCUFilerElementRef; override;
     procedure AddedBuiltInRef(Ref: TPCUFilerElementRef); override;
@@ -2086,12 +2087,17 @@ begin
     end;
 end;
 
-procedure TPCUWriter.CreateElReferenceId(Ref: TPCUFilerElementRef);
+procedure TPCUWriter.CreateAutoElReferenceId(Ref: TPCUFilerElementRef);
 begin
   if Ref.Id<>0 then
     RaiseMsg(20180207114300,Ref.Element,IntToStr(Ref.Id));
   inc(FElementIdCounter);
   Ref.Id:=FElementIdCounter;
+end;
+
+procedure TPCUWriter.CreateElReferenceId(Ref: TPCUFilerElementRef);
+begin
+  CreateAutoElReferenceId(Ref);
   Ref.Obj.Add('Id',Ref.Id);
 end;
 
@@ -3528,6 +3534,7 @@ var
   ScopeIntf: TFPList;
   o: TObject;
   SubObj: TJSONObject;
+  Ref: TPCUFilerElementRef;
 begin
   WriteIdentifierScope(Obj,Scope,aContext);
   aClass:=Scope.Element as TPasClassType;
@@ -3549,6 +3556,10 @@ begin
       RaiseMsg(20180217143857,aClass);
     if CanonicalClassOf.SourceLinenumber<>aClass.SourceLinenumber then
       RaiseMsg(20180217143905,aClass);
+    Ref:=GetElementReference(CanonicalClassOf);
+    CreateAutoElReferenceId(Ref);
+    Obj.Add('ClassOf',Ref.Id);
+    ResolvePendingElRefs(Ref);
     end
   else if CanonicalClassOf<>nil then
     RaiseMsg(20180329110817,aClass,GetObjName(CanonicalClassOf));
@@ -7213,10 +7224,11 @@ procedure TPCUReader.ReadClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope;
 var
   aClass: TPasClassType;
   CanonicalClassOf: TPasClassOfType;
+  CanonicalClassOfId: integer;
 begin
   aClass:=Scope.Element as TPasClassType;
 
-  if aClass.ObjKind=okClass then
+  if aClass.ObjKind in ([okClass]+okAllHelpers) then
     begin
     CanonicalClassOf:=TPasClassOfType(CreateElement(TPasClassOfType,'Self',aClass));
     Scope.CanonicalClassOf:=CanonicalClassOf;
@@ -7225,6 +7237,8 @@ begin
     CanonicalClassOf.SourceLinenumber:=aClass.SourceLinenumber;
     CanonicalClassOf.DestType:=aClass;
     aClass.AddRef{$IFDEF CheckPasTreeRefCount}('TPasClassScope.CanonicalClassOf'){$ENDIF};
+    if ReadInteger(Obj,'ClassOf',CanonicalClassOfId,CanonicalClassOf) then
+      AddElReference(CanonicalClassOfId,CanonicalClassOf,CanonicalClassOf);
     end;
 
   ReadElementReference(Obj,Scope,'NewInstanceFunction',@Set_ClassScope_NewInstanceFunction);

+ 8 - 0
packages/pastojs/src/pas2jsfs.pp

@@ -97,6 +97,7 @@ Type
     function FindSourceFileName(const aFilename: string): String; virtual; abstract;
   Public
     // Public Abstract. Must be overridden
+    function FindResourceFileName(const aFilename, ModuleDir: string): String; virtual; abstract;
     function FindIncludeFileName(const aFilename, ModuleDir: string): String; virtual; abstract;
     function LoadFile(Filename: string; Binary: boolean = false): TPas2jsFile; virtual; abstract;
     Function FileExists(Const aFileName: String): Boolean; virtual; abstract;
@@ -164,6 +165,7 @@ Type
   public
     constructor Create(aFS: TPas2jsFS); reintroduce;
     // Redirect all calls to FS.
+    function FindResourceFileName(const aFilename: string): String; override;
     function FindIncludeFileName(const aFilename: string): String; override;
     function FindIncludeFile(const aFilename: string): TLineReader; override;
     function FindSourceFile(const aFilename: string): TLineReader; override;
@@ -430,9 +432,15 @@ end;
 
 constructor TPas2jsFSResolver.Create(aFS: TPas2jsFS);
 begin
+  Inherited Create;
   FFS:=aFS;
 end;
 
+function TPas2jsFSResolver.FindResourceFileName(const aFilename: string): String;
+begin
+  Result:=FS.FindResourceFileName(aFilename,BaseDirectory);
+end;
+
 function TPas2jsFSResolver.FindIncludeFileName(const aFilename: string): String;
 
 begin

+ 111 - 0
packages/pastojs/src/pas2jshtmlresources.pp

@@ -0,0 +1,111 @@
+unit pas2jshtmlresources;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, pas2jsResources, pas2jsFS;
+
+Type
+
+  { THTMLResourceLinkHandler }
+
+  THTMLResourceLinkHandler = Class(TPas2jsResourceHandler)
+  Private
+    FLinkType: string;
+    FPrefix: String;
+    FResources : tstrings;
+  Protected
+    function GetResourceCount: Integer; override;
+    function GetAsString: String; override;
+    Function CreateDataLink(Const aResourceName,aFormat,aData : String) : String;
+  Public
+    Constructor Create(aFS : TPas2JSFS); override;
+    Class Function OutputMode : TResourceOUtputMode; override;
+    Class Function OutputFileExtension : String; override;
+    Procedure HandleResource (aFileName : string; Options : TStrings); override;
+    Procedure ClearUnit; override;
+    Procedure DoneUnit(IsMainFile : Boolean); override;
+    destructor Destroy; override;
+    // ID is IDPrefix-resourcename. The default Prefix is 'resource'
+    Property IDPrefix : String Read FPrefix Write FPrefix;
+    Property LinkType : string Read FLinkType Write FLinkType;
+    Property Resources : TStrings Read FResources;
+  end;
+
+implementation
+
+{ THTMLResourceLinkHandler }
+
+function THTMLResourceLinkHandler.GetResourceCount: Integer;
+begin
+  Result:=FResources.Count;
+end;
+
+function THTMLResourceLinkHandler.GetAsString: String;
+begin
+  Result:=FResources.Text;
+end;
+
+function THTMLResourceLinkHandler.CreateDataLink(const aResourceName, aFormat, aData: String): String;
+begin
+  Result:=Format('<link rel="%s" as="script" id="%s-%s" data-unit="%s" href="data:%s;base64,%s" />',[linkType,IDPrefix,aResourceName,CurrentUnitName,aFormat,aData]);
+end;
+
+procedure THTMLResourceLinkHandler.HandleResource(aFileName: string; Options: TStrings);
+
+Var
+  S : String;
+  aFormat,ResourceName : String;
+
+
+begin
+  S:=GetFileAsBase64(aFileName);
+  aFormat:=GetFormat(aFileName,Options);
+  ResourceName:=Options.Values['name'];
+  if ResourceName='' then
+    ResourceName:=ChangeFileExt(ExtractFileName(aFileName),'');
+  Resources.Add(CreateDataLink(ResourceName,aFormat,S))
+end;
+
+constructor THTMLResourceLinkHandler.Create(aFS: TPas2JSFS);
+begin
+  inherited Create(aFS);
+  FResources:=TStringList.Create;
+  IDPrefix:='resource';
+  LinkType:='preload';
+end;
+
+class function THTMLResourceLinkHandler.OutputMode: TResourceOutputMode;
+begin
+  Result:=romFile;
+end;
+
+
+class function THTMLResourceLinkHandler.OutputFileExtension: String;
+begin
+  Result:='.html';
+end;
+
+procedure THTMLResourceLinkHandler.ClearUnit;
+begin
+  inherited ClearUnit;
+  FResources.Clear;
+end;
+
+procedure THTMLResourceLinkHandler.DoneUnit(IsMainFile : Boolean);
+begin
+  // Do no call inherited, it will clear the list
+  if IsMainFile then ;
+end;
+
+
+destructor THTMLResourceLinkHandler.Destroy;
+begin
+  FreeAndNil(FResources);
+  inherited Destroy;
+end;
+
+end.
+

+ 103 - 0
packages/pastojs/src/pas2jsjsresources.pp

@@ -0,0 +1,103 @@
+unit pas2jsjsresources;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, pas2jsResources, pas2jsFS;
+
+Type
+
+  { TJSResourceLinkHandler }
+
+  { TJSResourceHandler }
+
+  TJSResourceHandler = Class(TPas2jsResourceHandler)
+  Private
+    FResources : TStrings;
+    function GetResourceJSStatement(aFileName: String; Options: TStrings): String;
+  Protected
+    function GetResourceCount: Integer; override;
+    function GetAsString: String; override;
+  Public
+    Constructor Create(aFS : TPas2JSFS); override;
+    Class Function OutputMode : TResourceOutputMode; override;
+    Class Function OutputFileExtension : String; override;
+    Procedure HandleResource (aFileName : string; Options : TStrings); override;
+    destructor Destroy; override;
+    Property Resources : TStrings Read FResources;
+  end;
+
+implementation
+
+{ TJSResourceHandler }
+
+function TJSResourceHandler.GetResourceCount: Integer;
+begin
+  Result:=FResources.Count;
+end;
+
+function TJSResourceHandler.GetAsString: String;
+
+Var
+  I : Integer;
+  N,V : String;
+
+begin
+  Result:='';
+  For I:=0 to FResources.Count-1 do
+    begin
+    FResources.GetNameValue(I,N,V);
+    Result:=Result+V+#10;
+    end;
+end;
+
+constructor TJSResourceHandler.Create(aFS: TPas2JSFS);
+begin
+  inherited Create(aFS);
+  FResources:=TStringList.Create;
+end;
+
+class function TJSResourceHandler.OutputMode: TResourceOutputMode;
+begin
+  Result:=romExtraJS;
+end;
+
+class function TJSResourceHandler.OutputFileExtension: String;
+begin
+  Result:='.js';
+end;
+
+Function TJSResourceHandler.GetResourceJSStatement(aFileName : String; Options: TStrings) : String;
+
+Const
+  SAddResource = 'rtl.addResource({name: "%s", unit: "%s", format: "%s", encoding: "base64", data: "%s"});';
+
+Var
+  aFormat,aName,aData : String;
+
+begin
+  aData:=GetFileAsBase64(aFileName);
+  aFormat:=GetFormat(aFileName,Options);
+  aName:=Options.Values['name'];
+  if aName='' then
+    aName:=ChangeFileExt(ExtractFileName(aFileName),'');
+  Result:=Format(SAddResource,[aName,CurrentUnitName,aFormat,aData]);
+end;
+
+procedure TJSResourceHandler.HandleResource(aFileName: string; Options: TStrings);
+begin
+  // PRepending unit name allows to extract easier all resources for a single unit
+  FResources.Add(CurrentUnitName+'='+GetResourceJSStatement(aFileName,Options));
+end;
+
+
+destructor TJSResourceHandler.Destroy;
+begin
+  FreeAndNil(FResources);
+  inherited Destroy;
+end;
+
+end.
+

+ 179 - 0
packages/pastojs/src/pas2jsresources.pp

@@ -0,0 +1,179 @@
+unit pas2jsresources;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, pas2jsfs, jsTree;
+
+Type
+  TResourceScopeMode = (rmProgram,rmUnit);
+
+  { TPas2jsResourceHandler }
+  TResourceOutputMode = (romNone,romJS,romFile,romExtraJS);
+  TPas2jsResourceHandler = class(TObject)
+  private
+    FCurrentUnitName: String;
+    FFS: TPas2JSFS;
+  Protected
+    // Must be overridden
+    function GetResourceCount: Integer; virtual; abstract;
+    // Content of file, if file based.
+    function GetAsString: String; virtual; abstract;
+    // Detect some common formats
+    Function GetFormat(const aFileName : string; aOptions : TStrings) : string; virtual;
+  Public
+    Constructor Create(aFS : TPas2JSFS); virtual;
+    // Called for every found resource
+    Procedure HandleResource (aFileName : string; Options : TStrings); virtual; abstract;
+    // Extension of output file, if file based
+    Class Function OutputFileExtension : String; virtual;
+    // True if output is file based (i.e. written to separate file)
+    Class Function OutputMode : TResourceOutputMode; virtual; abstract;
+    // Load resource file. Can be used in descendents
+    Function LoadFile(aFileName : string) : TPas2jsFile;
+    // Load resource file and encode as base64 string. Can be used in descendents
+    Function GetFileAsBase64(aFileName : string)  : string;
+    // This is called for every unit.
+    Procedure StartUnit(Const aUnitName : String); virtual;
+    // This is called at the start of every unit if OutputIsUnitBased is true.
+    Procedure ClearUnit; virtual;
+    // This is called at the end of every unit if OutputIsUnitBased is true. Only once if not.
+    Procedure DoneUnit(isMainFile : Boolean); virtual;
+    // This is called when Javascript is written for a unit
+    Function WriteJS(const aUnitName : String; aModule : TJSElement) : TJSElement; virtual;
+    // Current unit.
+    Property CurrentUnitName : String Read FCurrentUnitName;
+    // Passed at create
+    property FS : TPas2JSFS Read FFS;
+    // Return file content for writing to file if IsFileBased
+    Property AsString : String Read GetAsString;
+    // Number of resources
+    Property ResourceCount : Integer Read GetResourceCount;
+  end;
+
+  { TNoResources }
+
+  TNoResources = Class(TPas2jsResourceHandler)
+  Public
+    Procedure HandleResource (aFileName : string; Options : TStrings); override;
+    Class Function OutputMode : TResourceOutputMode; override;
+    function GetResourceCount: Integer; override;
+    function GetAsString: String; override;
+  end;
+implementation
+
+{$IFNDEF PAS2JS}
+uses base64;
+
+{ TNoResources }
+
+procedure TNoResources.HandleResource(aFileName: string; Options: TStrings);
+begin
+  // Do nothing
+  if aFileName='' then ;
+  if Options=nil then ;
+end;
+
+
+class function TNoResources.OutputMode: TResourceOutputMode;
+begin
+  result:=romNone;
+end;
+
+function TNoResources.GetResourceCount: Integer;
+begin
+  Result:=0;
+end;
+
+function TNoResources.GetAsString: String;
+begin
+  Result:='';
+end;
+
+{$ENDIF}
+
+{ TPas2jsResourceHandler }
+
+
+function TPas2jsResourceHandler.GetFormat(const aFileName: string; aOptions: TStrings): string;
+
+Var
+  E : String;
+
+begin
+  Result:=aOptions.Values['format'];
+  if Result='' then
+    begin
+    E:=ExtractFileExt(aFileName);
+    if (E<>'') and (E[1]='.') then
+      E:=Copy(E,2,Length(E)-1);
+    if Pos(LowerCase(E),';png;jpg;jpeg;bmp;ico;')>0 then
+      Result:='image/'+E
+    else if Pos(LowerCase(E),';htm;html;')>0 then
+      Result:='text/html'
+    else if Pos(LowerCase(E),';txt;lpr;pas;pp;')>0 then
+      Result:='text/text'
+    else if Pos(LowerCase(E),';js;')>0 then
+      Result:='application/javascript'
+    else if Pos(LowerCase(E),';json;')>0 then
+      Result:='application/javascript'
+    else
+      Result:='application/octet-stream';
+    end;
+end;
+
+constructor TPas2jsResourceHandler.Create(aFS: TPas2JSFS);
+begin
+  FFS:=aFS;
+end;
+
+
+class function TPas2jsResourceHandler.OutputFileExtension: String;
+begin
+  Result:='';
+end;
+
+
+function TPas2jsResourceHandler.LoadFile(aFileName: string): TPas2jsFile;
+begin
+  Result:=FS.LoadFile(aFileName,True);
+end;
+
+function TPas2jsResourceHandler.GetFileAsBase64(aFileName: string): string;
+
+Var
+  F : TPas2JSFile;
+
+begin
+  F:=LoadFile(aFileName);
+  Result:=EncodeStringBase64(F.Source);
+  // Do not release, FS will release all files
+end;
+
+procedure TPas2jsResourceHandler.ClearUnit;
+begin
+  FCurrentUnitName:='';
+end;
+
+procedure TPas2jsResourceHandler.StartUnit(const aUnitName: String);
+begin
+  FCurrentUnitName:=aUnitName;
+end;
+
+procedure TPas2jsResourceHandler.DoneUnit(isMainFile: Boolean);
+begin
+  if not isMainFile then
+    ClearUnit;
+end;
+
+function TPas2jsResourceHandler.WriteJS(const aUnitName: String; aModule: TJSElement): TJSElement;
+begin
+  Result:=aModule;
+  if aUnitName='' then ;
+end;
+
+
+end.
+

+ 763 - 8
packages/pastojs/tests/tcgenerics.pas

@@ -16,14 +16,23 @@ type
   Published
     // generic record
     Procedure TestGen_RecordEmpty;
+    Procedure TestGen_Record_ClassProc_ObjFPC;
+    //Procedure TestGen_Record_ClassProc_Delphi;
+    //Procedure TestGen_Record_ReferGenClass_DelphiFail;
 
     // generic class
     Procedure TestGen_ClassEmpty;
     Procedure TestGen_Class_EmptyMethod;
     Procedure TestGen_Class_TList;
+    Procedure TestGen_Class_TCustomList;
     Procedure TestGen_ClassAncestor;
-    Procedure TestGen_TypeInfo;
-    // ToDo: TBird, TBird<T>, TBird<S,T>
+    Procedure TestGen_Class_TypeInfo;
+    Procedure TestGen_Class_TypeOverload; // ToDo TBird, TBird<T>, TBird<S,T>
+    Procedure TestGen_Class_ClassProperty;
+    Procedure TestGen_Class_ClassProc_ObjFPC;
+    //Procedure TestGen_Class_ClassProc_Delphi;
+    //Procedure TestGen_Class_ReferGenClass_DelphiFail;
+    Procedure TestGen_Class_ClassConstructor;
     // ToDo: rename local const T
 
     // generic external class
@@ -33,15 +42,24 @@ type
     Procedure TestGen_InlineSpec_Constructor;
     Procedure TestGen_CallUnitImplProc;
     Procedure TestGen_IntAssignTemplVar;
-    // ToDo: TBird<word>(o).field:=3;
+    Procedure TestGen_TypeCastDotField;
 
     // generic helper
-    // ToDo: helper for gen array: TArray<word>.Fly(aword);
+    procedure TestGen_HelperForArray;
 
     // generic functions
-    // ToDo: Fly<word>(3);
-    // ToDo: TestGenProc_ProcT
-    // ToDo: inference Fly(3);
+    procedure TestGenProc_Function_ObjFPC;
+    procedure TestGenProc_Function_Delphi;
+    procedure TestGenProc_Overload;
+    procedure TestGenProc_Forward;
+    procedure TestGenProc_Infer_OverloadForward;
+    procedure TestGenProc_TypeInfo;
+    procedure TestGenProc_Infer_Widen;
+    procedure TestGenProc_Infer_PassAsArg;
+    // ToDo: FuncName:=
+
+    // generic methods
+    procedure TestGenMethod_ObjFPC;
   end;
 
 implementation
@@ -77,6 +95,56 @@ begin
     ]));
 end;
 
+procedure TTestGenerics.TestGen_Record_ClassProc_ObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch AdvancedRecords}',
+  'type',
+  '  generic TPoint<T> = record',
+  '    class var x: T;',
+  '    class procedure Fly; static;',
+  '  end;',
+  'class procedure Tpoint.Fly;',
+  'begin',
+  '  x:=x+3;',
+  '  tpoint.x:=tpoint.x+4;',
+  '  Fly;',
+  '  tpoint.Fly;',
+  'end;',
+  'var p: specialize TPoint<word>;',
+  'begin',
+  '  p.x:=p.x+10;',
+  '  p.Fly;',
+  '  p.Fly();',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_Record_ClassProc',
+    LinesToStr([ // statements
+    'rtl.recNewT($mod, "TPoint$G1", function () {',
+    '  this.x = 0;',
+    '  this.$eq = function (b) {',
+    '    return true;',
+    '  };',
+    '  this.$assign = function (s) {',
+    '    return this;',
+    '  };',
+    '  this.Fly = function () {',
+    '    $mod.TPoint$G1.x = $mod.TPoint$G1.x + 3;',
+    '    $mod.TPoint$G1.x = $mod.TPoint$G1.x + 4;',
+    '    $mod.TPoint$G1.Fly();',
+    '    $mod.TPoint$G1.Fly();',
+    '  };',
+    '}, true);',
+    'this.p = $mod.TPoint$G1.$new();',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.TPoint$G1.x = $mod.p.x + 10;',
+    '$mod.p.Fly();',
+    '$mod.p.Fly();',
+    '']));
+end;
+
 procedure TTestGenerics.TestGen_ClassEmpty;
 begin
   StartProgram(false);
@@ -222,6 +290,62 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_Class_TCustomList;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TObject = class end;',
+  '  TCustomList<T> = class',
+  '  public',
+  '    function PrepareAddingItem: word; virtual;',
+  '  end;',
+  '  TList<T> = class(TCustomList<T>)',
+  '  public',
+  '    function Add: word;',
+  '  end;',
+  '  TWordList = TList<word>;',
+  'function TCustomList<T>.PrepareAddingItem: word;',
+  'begin',
+  'end;',
+  'function TList<T>.Add: word;',
+  'begin',
+  '  Result:=PrepareAddingItem;',
+  //'  Result:=Self.PrepareAddingItem;',
+  //'  with Self do Result:=PrepareAddingItem;',
+  'end;',
+  'var l: TWordList;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_Class_TCustomList',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TCustomList$G2", $mod.TObject, function () {',
+    '  this.PrepareAddingItem = function () {',
+    '    var Result = 0;',
+    '    return Result;',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TList$G1", $mod.TCustomList$G2, function () {',
+    '  this.Add = function () {',
+    '    var Result = 0;',
+    '    Result = this.PrepareAddingItem();',
+    '    return Result;',
+    '  };',
+    '});',
+    'this.l = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestGenerics.TestGen_ClassAncestor;
 begin
   StartProgram(false);
@@ -254,7 +378,7 @@ begin
     '']));
 end;
 
-procedure TTestGenerics.TestGen_TypeInfo;
+procedure TTestGenerics.TestGen_Class_TypeInfo;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
   StartProgram(false);
@@ -299,6 +423,211 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_Class_TypeOverload;
+begin
+  exit;// ToDo
+
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TObject = class end;',
+  '  TBird = word;',
+  '  TBird<T> = class',
+  '    m: T;',
+  '  end;',
+  '  TEagle = TBird<word>;',
+  'var',
+  '  b: TBird<word>;',
+  '  e: TEagle;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_Class_TypeOverload',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
+procedure TTestGenerics.TestGen_Class_ClassProperty;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TObject = class end;',
+  '  TBird<T> = class',
+  '  private',
+  '    class var fSize: T;',
+  '  public',
+  '    class property Size: T read fSize write fSize;',
+  '  end;',
+  '  TEagle = TBird<word>;',
+  'begin',
+  '  TBird<word>.Size:=3+TBird<word>.Size;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_Class_ClassProperty',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TBird$G1", $mod.TObject, function () {',
+    '  this.fSize = 0;',
+    '});',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.TBird$G1.fSize = 3 + $mod.TBird$G1.fSize;',
+    '']));
+end;
+
+procedure TTestGenerics.TestGen_Class_ClassProc_ObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  generic TPoint<T> = class',
+  '    class var x: T;',
+  '    class procedure Fly; static;',
+  '    class procedure Run;',
+  '  end;',
+  'class procedure Tpoint.Fly;',
+  'begin',
+  '  x:=x+3;',
+  '  tpoint.x:=tpoint.x+4;',
+  '  Fly;',
+  '  tpoint.Fly;',
+  '  Run;',
+  '  tpoint.Run;',
+  'end;',
+  'class procedure TPoint.Run;',
+  'begin',
+  '  x:=x+5;',
+  '  tpoint.x:=tpoint.x+6;',
+  '  Fly;',
+  '  tpoint.Fly;',
+  '  Run;',
+  '  tpoint.Run;',
+  'end;',
+  'var p: specialize TPoint<word>;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_Class_ClassProc',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TPoint$G1", $mod.TObject, function () {',
+    '  this.x = 0;',
+    '  this.Fly = function () {',
+    '    $mod.TPoint$G1.x = $mod.TPoint$G1.x + 3;',
+    '    $mod.TPoint$G1.x = $mod.TPoint$G1.x + 4;',
+    '    $mod.TPoint$G1.Fly();',
+    '    $mod.TPoint$G1.Fly();',
+    '    $mod.TPoint$G1.Run();',
+    '    $mod.TPoint$G1.Run();',
+    '  };',
+    '  this.Run = function () {',
+    '    $mod.TPoint$G1.x = this.x + 5;',
+    '    $mod.TPoint$G1.x = $mod.TPoint$G1.x + 6;',
+    '    this.Fly();',
+    '    $mod.TPoint$G1.Fly();',
+    '    this.Run();',
+    '    $mod.TPoint$G1.Run();',
+    '  };',
+    '});',
+    'this.p = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
+procedure TTestGenerics.TestGen_Class_ClassConstructor;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  generic TPoint<T> = class',
+  '    class var x: T;',
+  '    class procedure Fly; static;',
+  '    class constructor Init;',
+  '  end;',
+  'var count: word;',
+  'class procedure Tpoint.Fly;',
+  'begin',
+  'end;',
+  'class constructor tpoint.init;',
+  'begin',
+  '  count:=count+1;',
+  '  x:=3;',
+  '  tpoint.x:=4;',
+  '  fly;',
+  '  tpoint.fly;',
+  'end;',
+  'var',
+  '  r: specialize TPoint<word>;',
+  '  s: specialize TPoint<smallint>;',
+  'begin',
+  '  r.x:=10;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_Class_ClassConstructor',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TPoint$G1", $mod.TObject, function () {',
+    '  this.x = 0;',
+    '  this.Fly = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TPoint$G2", $mod.TObject, function () {',
+    '  this.x = 0;',
+    '  this.Fly = function () {',
+    '  };',
+    '});',
+    'this.count = 0;',
+    'this.r = null;',
+    'this.s = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '(function () {',
+    '  $mod.count = $mod.count + 1;',
+    '  $mod.TPoint$G1.x = 3;',
+    '  $mod.TPoint$G1.x = 4;',
+    '  $mod.TPoint$G1.Fly();',
+    '  $mod.TPoint$G1.Fly();',
+    '})();',
+    '(function () {',
+    '  $mod.count = $mod.count + 1;',
+    '  $mod.TPoint$G2.x = 3;',
+    '  $mod.TPoint$G2.x = 4;',
+    '  $mod.TPoint$G2.Fly();',
+    '  $mod.TPoint$G2.Fly();',
+    '})();',
+    '$mod.TPoint$G1.x = 10;',
+    '']));
+end;
+
 procedure TTestGenerics.TestGen_ExtClass_Array;
 begin
   StartProgram(false);
@@ -493,6 +822,432 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_TypeCastDotField;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  generic TBird<T> = class',
+  '    Field: T;',
+  '    procedure Fly;',
+  '  end;',
+  'var',
+  '  o: TObject;',
+  '  b: specialize TBird<word>;',
+  'procedure TBird.Fly;',
+  'begin',
+  '  specialize TBird<word>(o).Field:=3;',
+  '  if 4=specialize TBird<word>(o).Field then ;',
+  'end;',
+  'begin',
+  '  specialize TBird<word>(o).Field:=5;',
+  '  if 6=specialize TBird<word>(o).Field then ;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_TypeCastDotField',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TBird$G1", $mod.TObject, function () {',
+    '  this.$init = function () {',
+    '    $mod.TObject.$init.call(this);',
+    '    this.Field = 0;',
+    '  };',
+    '  this.Fly = function () {',
+    '    $mod.o.Field = 3;',
+    '    if (4 === $mod.o.Field) ;',
+    '  };',
+    '});',
+    'this.o = null;',
+    'this.b = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.o.Field = 5;',
+    'if (6 === $mod.o.Field) ;',
+    '']));
+end;
+
+procedure TTestGenerics.TestGen_HelperForArray;
+begin
+  StartProgram(false);
+  Add([
+  '{$ModeSwitch typehelpers}',
+  'type',
+  '  generic TArr<T> = array[1..2] of T;',
+  '  TWordArrHelper = type helper for specialize TArr<word>',
+  '    procedure Fly(w: word);',
+  '  end;',
+  'procedure TWordArrHelper.Fly(w: word);',
+  'begin',
+  'end;',
+  'var',
+  '  a: specialize TArr<word>;',
+  'begin',
+  '  a.Fly(3);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_HelperForArray',
+    LinesToStr([ // statements
+    'rtl.createHelper($mod, "TWordArrHelper", null, function () {',
+    '  this.Fly = function (w) {',
+    '  };',
+    '});',
+    'this.a = rtl.arraySetLength(null, 0, 2);',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.TWordArrHelper.Fly.call({',
+    '  p: $mod,',
+    '  get: function () {',
+    '      return this.p.a;',
+    '    },',
+    '  set: function (v) {',
+    '      this.p.a = v;',
+    '    }',
+    '}, 3);',
+    '']));
+end;
+
+procedure TTestGenerics.TestGenProc_Function_ObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  'generic function Run<T>(a: T): T;',
+  'var i: T;',
+  'begin',
+  '  a:=i;',
+  '  Result:=a;',
+  'end;',
+  'var w: word;',
+  'begin',
+  '  w:=specialize Run<word>(3);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGenProc_Function_ObjFPC',
+    LinesToStr([ // statements
+    'this.Run$s0 = function (a) {',
+    '  var Result = 0;',
+    '  var i = 0;',
+    '  a = i;',
+    '  Result = a;',
+    '  return Result;',
+    '};',
+    'this.w = 0;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.w = $mod.Run$s0(3);',
+    '']));
+end;
+
+procedure TTestGenerics.TestGenProc_Function_Delphi;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'function Run<T>(a: T): T;',
+  'var i: T;',
+  'begin',
+  '  a:=i;',
+  '  Result:=a;',
+  'end;',
+  'var w: word;',
+  'begin',
+  '  w:=Run<word>(3);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGenProc_Function_Delphi',
+    LinesToStr([ // statements
+    'this.Run$s0 = function (a) {',
+    '  var Result = 0;',
+    '  var i = 0;',
+    '  a = i;',
+    '  Result = a;',
+    '  return Result;',
+    '};',
+    'this.w = 0;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.w = $mod.Run$s0(3);',
+    '']));
+end;
+
+procedure TTestGenerics.TestGenProc_Overload;
+begin
+  StartProgram(false);
+  Add([
+  'generic procedure DoIt<T>(a: T; w: word); overload;',
+  'begin',
+  'end;',
+  'generic procedure DoIt<T>(a: T; b: boolean); overload;',
+  'begin',
+  'end;',
+  'begin',
+  '  specialize DoIt<word>(3,4);',
+  '  specialize DoIt<boolean>(false,5);',
+  '  specialize DoIt<word>(6,true);',
+  '  specialize DoIt<double>(7.3,true);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGenProc_Overload',
+    LinesToStr([ // statements
+    'this.DoIt$s0 = function (a, w) {',
+    '};',
+    'this.DoIt$s1 = function (a, w) {',
+    '};',
+    'this.DoIt$1s0 = function (a, b) {',
+    '};',
+    'this.DoIt$1s1 = function (a, b) {',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.DoIt$s0(3, 4);',
+    '$mod.DoIt$s1(false, 5);',
+    '$mod.DoIt$1s0(6, true);',
+    '$mod.DoIt$1s1(7.3, true);',
+    '']));
+end;
+
+procedure TTestGenerics.TestGenProc_Forward;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'procedure Run<S>(a: S; b: boolean); forward;',
+  'procedure Run<S>(a: S; b: boolean);',
+  'begin',
+  '  Run<word>(1,true);',
+  'end;',
+  'begin',
+  '  Run(1.3,true);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGenProc_infer_OverloadForward',
+    LinesToStr([ // statements
+    'this.Run$s0 = function (a, b) {',
+    '  $mod.Run$s0(1, true);',
+    '};',
+    'this.Run$s1 = function (a, b) {',
+    '  $mod.Run$s0(1, true);',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.Run$s1(1.3, true);',
+    '']));
+end;
+
+procedure TTestGenerics.TestGenProc_Infer_OverloadForward;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'procedure {#A}Run<S>(a: S; b: boolean); forward; overload;',
+  'procedure {#B}Run<T>(a: T; w: word); forward; overload;',
+  'procedure {#C}Run<U>(a: U; b: U); forward; overload;',
+  'procedure {#A2}Run<S>(a: S; b: boolean); overload;',
+  'begin',
+  '  {@A}Run(1,true);', // non generic take precedence
+  '  {@B}Run(2,word(3));', // non generic take precedence
+  '  {@C}Run(''foo'',''bar'');',
+  'end;',
+  'procedure {#B2}Run<T>(a: T; w: word); overload;',
+  'begin',
+  'end;',
+  'procedure {#C2}Run<U>(a: U; b: U); overload;',
+  'begin',
+  'end;',
+  'begin',
+  '  {@A}Run(1,true);', // non generic take precedence
+  '  {@B}Run(2,word(3));', // non generic take precedence
+  '  {@C}Run(''foo'',''bar'');',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGenProc_infer_OverloadForward',
+    LinesToStr([ // statements
+    'this.Run$s0 = function (a, b) {',
+    '  $mod.Run$s0(1, true);',
+    '  $mod.Run$1s0(2, 3);',
+    '  $mod.Run$2s0("foo", "bar");',
+    '};',
+    'this.Run$1s0 = function (a, w) {',
+    '};',
+    'this.Run$2s0 = function (a, b) {',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.Run$s0(1, true);',
+    '$mod.Run$1s0(2, 3);',
+    '$mod.Run$2s0("foo", "bar");',
+    '']));
+end;
+
+procedure TTestGenerics.TestGenProc_TypeInfo;
+begin
+  Converter.Options:=Converter.Options-[coNoTypeInfo];
+  StartProgram(true,[supTypeInfo]);
+  Add([
+  '{$modeswitch implicitfunctionspecialization}',
+  'generic procedure Run<S>(a: S);',
+  'var',
+  '  p: TTypeInfo;',
+  'begin',
+  '  p:=TypeInfo(S);',
+  '  p:=TypeInfo(a);',
+  'end;',
+  'begin',
+  '  Run(word(3));',
+  '  Run(''foo'');',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGenProc_TypeInfo',
+    LinesToStr([ // statements
+    'this.Run$s0 = function (a) {',
+    '  var p = null;',
+    '  p = rtl.word;',
+    '  p = rtl.word;',
+    '};',
+    'this.Run$s1 = function (a) {',
+    '  var p = null;',
+    '  p = rtl.string;',
+    '  p = rtl.string;',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.Run$s0(3);',
+    '$mod.Run$s1("foo");',
+    '']));
+end;
+
+procedure TTestGenerics.TestGenProc_Infer_Widen;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'procedure Run<S>(a: S; b: S);',
+  'begin',
+  'end;',
+  'begin',
+  '  Run(word(1),longint(2));',
+  '  Run(byte(2),smallint(2));',
+  '  Run(longword(3),longint(2));',
+  '  Run(nativeint(4),longint(2));',
+  '  Run(nativeint(5),nativeuint(2));',
+  '  Run(''a'',''foo'');',
+  '  Run(''bar'',''c'');',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGenProc_Infer_Widen',
+    LinesToStr([ // statements
+    'this.Run$s0 = function (a, b) {',
+    '};',
+    'this.Run$s1 = function (a, b) {',
+    '};',
+    'this.Run$s2 = function (a, b) {',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.Run$s0(1, 2);',
+    '$mod.Run$s0(2, 2);',
+    '$mod.Run$s1(3, 2);',
+    '$mod.Run$s1(4, 2);',
+    '$mod.Run$s1(5, 2);',
+    '$mod.Run$s2("a", "foo");',
+    '$mod.Run$s2("bar", "c");',
+    '']));
+end;
+
+procedure TTestGenerics.TestGenProc_Infer_PassAsArg;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'function Run<T>(a: T): T;',
+  'var b: T;',
+  'begin',
+  '  Run(Run<word>(3));',
+  '  Run(Run(word(4)));',
+  'end;',
+  'begin',
+  '  Run(Run<word>(5));',
+  '  Run(Run(word(6)));',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGenProc_Infer_PassAsArg',
+    LinesToStr([ // statements
+    'this.Run$s0 = function (a) {',
+    '  var Result = 0;',
+    '  var b = 0;',
+    '  $mod.Run$s0($mod.Run$s0(3));',
+    '  $mod.Run$s0($mod.Run$s0(4));',
+    '  return Result;',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.Run$s0($mod.Run$s0(5));',
+    '$mod.Run$s0($mod.Run$s0(6));',
+    '']));
+end;
+
+procedure TTestGenerics.TestGenMethod_ObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  '{$ModeSwitch implicitfunctionspecialization}',
+  'type',
+  '  TObject = class',
+  '    generic procedure {#A}Run<S>(a: S; b: boolean); overload;',
+  '    generic procedure {#B}Run<T>(a: T; w: word); overload;',
+  '    generic procedure {#C}Run<U>(a: U; b: U); overload;',
+  '  end; ',
+  'generic procedure {#A2}TObject.Run<S>(a: S; b: boolean); overload;',
+  'begin',
+  '  {@A}Run(1,true);', // non generic take precedence
+  '  {@B}Run(2,word(3));', // non generic take precedence
+  '  {@C}Run(''foo'',''bar'');',
+  'end;',
+  'generic procedure {#B2}TObject.Run<T>(a: T; w: word); overload;',
+  'begin',
+  'end;',
+  'generic procedure {#C2}TObject.Run<U>(a: U; b: U); overload;',
+  'begin',
+  'end;',
+  'var o: TObject;',
+  'begin',
+  '  o.{@A}Run(1,true);', // non generic take precedence
+  '  o.{@B}Run(2,word(3));', // non generic take precedence
+  '  o.{@C}Run(''foo'',''bar'');',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGenMethod_ObjFPC',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.Run$s0 = function (a, b) {',
+    '    this.Run$s0(1, true);',
+    '    this.Run$1s0(2, 3);',
+    '    this.Run$2s0("foo", "bar");',
+    '  };',
+    '  this.Run$1s0 = function (a, w) {',
+    '  };',
+    '  this.Run$2s0 = function (a, b) {',
+    '  };',
+    '});',
+    'this.o = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.o.Run$s0(1, true);',
+    '$mod.o.Run$1s0(2, 3);',
+    '$mod.o.Run$2s0("foo", "bar");',
+    '']));
+end;
+
 Initialization
   RegisterTests([TTestGenerics]);
 end.

+ 136 - 56
packages/pastojs/tests/tcmodules.pas

@@ -51,7 +51,8 @@ type
 
   TSystemUnitPart = (
     supTObject,
-    supTVarRec
+    supTVarRec,
+    supTypeInfo
     );
   TSystemUnitParts = set of TSystemUnitPart;
 
@@ -588,6 +589,7 @@ type
     Procedure TestExternalClass_FuncClassOf_New;
     Procedure TestExternalClass_New_PasClassFail;
     Procedure TestExternalClass_New_PasClassBracketsFail;
+    Procedure TestExternalClass_NewExtName;
     Procedure TestExternalClass_Constructor;
     Procedure TestExternalClass_ConstructorBrackets;
     Procedure TestExternalClass_LocalConstSameName;
@@ -815,6 +817,7 @@ type
     Procedure TestRTTI_Interface_Corba;
     Procedure TestRTTI_Interface_COM;
     Procedure TestRTTI_ClassHelper;
+    Procedure TestRTTI_ExternalClass;
 
     // Resourcestring
     Procedure TestResourcestringProgram;
@@ -1556,7 +1559,7 @@ var
 begin
   Intf:=TStringList.Create;
   // interface
-  if supTVarRec in Parts then
+  if [supTVarRec,supTypeInfo]*Parts<>[] then
     Intf.Add('{$modeswitch externalclass}');
   Intf.Add('type');
   Intf.Add('  integer=longint;');
@@ -1602,6 +1605,28 @@ begin
     '  TVarRecArray = array of TVarRec;',
     'function VarRecs: TVarRecArray; varargs;',
     '']);
+  if supTypeInfo in Parts then
+    begin
+    Intf.AddStrings([
+    'type',
+    '  TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
+    '  TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo)',
+    '  end;',
+    '  TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;',
+    '  TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;',
+    '  TTypeInfoStaticArray = class external name ''rtl.tTypeInfoStaticArray''(TTypeInfo) end;',
+    '  TTypeInfoDynArray = class external name ''rtl.tTypeInfoDynArray''(TTypeInfo) end;',
+    '  TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;',
+    '  TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;',
+    '  TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;',
+    '  TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;',
+    '  TTypeInfoExtClass = class external name ''rtl.tTypeInfoExtClass''(TTypeInfo) end;',
+    '  TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;',
+    '  TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;',
+    '  TTypeInfoHelper = class external name ''rtl.tTypeInfoHelper''(TTypeInfo) end;',
+    '  TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
+    '']);
+    end;
   Intf.Add('var');
   Intf.Add('  ExitCode: Longint = 0;');
 
@@ -2442,8 +2467,9 @@ begin
   StartProgram(false);
   Add('{$modeswitch cblocks-}');
   Add('begin');
-  SetExpectedScannerError('Invalid mode switch: "cblocks-"',nErrInvalidModeSwitch);
   ConvertProgram;
+  CheckHint(mtWarning,nErrInvalidModeSwitch,'Warning: test1.pp(3,23) : Invalid mode switch: "cblocks"');
+  CheckResolverUnexpectedHints();
 end;
 
 procedure TTestModule.TestUnit_UseSystem;
@@ -11081,14 +11107,14 @@ begin
     '  };',
     '  this.GetInt = function () {',
     '    var Result = 0;',
-    '    Result = this.Fx;',
+    '    Result = $mod.TRec.Fx;',
     '    return Result;',
     '  };',
     '  this.SetInt = function (Value) {',
     '  };',
     '  this.DoIt = function () {',
-    '    $mod.TRec.Fy = this.Fx + 1;',
-    '    this.SetInt(this.GetInt() + 1);',
+    '    $mod.TRec.Fy = $mod.TRec.Fx + 1;',
+    '    $mod.TRec.SetInt($mod.TRec.GetInt() + 1);',
     '  };',
     '}, true);',
     'this.r = $mod.TRec.$new();',
@@ -11318,7 +11344,7 @@ begin
     '      $mod.TRec.TPoint.Count = this.Count + 3;',
     '    };',
     '    this.DoThat = function () {',
-    '      $mod.TRec.TPoint.Count = this.Count + 4;',
+    '      $mod.TRec.TPoint.Count = $mod.TRec.TPoint.Count + 4;',
     '    };',
     '  }, true);',
     '  this.i = 0;',
@@ -11514,14 +11540,16 @@ begin
   'class constructor tpoint.init;',
   'begin',
   '  count:=count+1;',
-  '  x:=3;',
-  '  tpoint.x:=4;',
+  '  x:=x+3;',
+  '  tpoint.x:=tpoint.x+4;',
   '  fly;',
   '  tpoint.fly;',
   'end;',
   'var r: TPoint;',
   'begin',
-  '  r.x:=10;',
+  '  r.x:=r.x+10;',
+  '  r.Fly;',
+  '  r.Fly();',
   '']);
   ConvertProgram;
   CheckSource('TestAdvRecord_ClassConstructor_Program',
@@ -11543,12 +11571,14 @@ begin
     LinesToStr([ // $mod.$main
     '(function () {',
     '  $mod.count = $mod.count + 1;',
-    '  $mod.TPoint.x = 3;',
-    '  $mod.TPoint.x = 4;',
+    '  $mod.TPoint.x = $mod.TPoint.x + 3;',
+    '  $mod.TPoint.x = $mod.TPoint.x + 4;',
     '  $mod.TPoint.Fly();',
     '  $mod.TPoint.Fly();',
     '})();',
-    '$mod.TPoint.x = 10;',
+    '$mod.TPoint.x = $mod.r.x + 10;',
+    '$mod.r.Fly();',
+    '$mod.r.Fly();',
     '']));
 end;
 
@@ -16536,6 +16566,51 @@ begin
   ConvertProgram;
 end;
 
+procedure TTestModule.TestExternalClass_NewExtName;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch externalclass}',
+  'type',
+  '  TExtA = class external name ''ExtA''',
+  '    constructor New; external name ''Other'';',
+  '    constructor New(i: longint; j: longint = 2); external name ''A.B'';',
+  '  end;',
+  'var',
+  '  A: texta;',
+  'begin',
+  '  a:=texta.new;',
+  '  a:=texta(texta.new);',
+  '  a:=texta.new();',
+  '  a:=texta.new(1);',
+  '  with texta do begin',
+  '    a:=new;',
+  '    a:=new();',
+  '    a:=new(2);',
+  '  end;',
+  '  a:=test1.texta.new;',
+  '  a:=test1.texta.new();',
+  '  a:=test1.texta.new(3);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestExternalClass_NewExtName',
+    LinesToStr([ // statements
+    'this.A = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.A = new Other();',
+    '$mod.A = new Other();',
+    '$mod.A = new Other();',
+    '$mod.A = new A.B(1,2);',
+    '$mod.A = new Other();',
+    '$mod.A = new Other();',
+    '$mod.A = new A.B(2,2);',
+    '$mod.A = new Other();',
+    '$mod.A = new Other();',
+    '$mod.A = new A.B(3,2);',
+    '']));
+end;
+
 procedure TTestModule.TestExternalClass_Constructor;
 begin
   StartProgram(false);
@@ -18192,13 +18267,13 @@ begin
     '        return this.FBirdIntf;',
     '      },',
     '    "{489289DE-FDE2-34A6-8288-39119022B1B4}": function () {',
-    '        return this.$class.GetEagleIntf();',
+    '        return this.GetEagleIntf();',
     '      },',
     '    "{489289DE-FDE2-34A6-8288-39118EF16074}": function () {',
     '        return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
     '      },',
     '    "{B89289DE-FDE2-34A6-8288-3911CBDCB359}": function () {',
-    '        return rtl.getIntfT(this.$class.GetSwallowObj(), $mod.ISwallow);',
+    '        return rtl.getIntfT(this.GetSwallowObj(), $mod.ISwallow);',
     '      }',
     '  };',
     '});',
@@ -21178,7 +21253,7 @@ begin
     '  };',
     '  this.GetSpeed = function () {',
     '    var Result = 0;',
-    '    this.SetSpeed(this.GetSpeed() + 12);',
+    '    $mod.TObject.SetSpeed($mod.TObject.GetSpeed() + 12);',
     '    $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
     '    return Result;',
     '  };',
@@ -21188,7 +21263,7 @@ begin
     'rtl.createHelper($mod, "TObjHelper", null, function () {',
     '  this.GetLeft = function () {',
     '    var Result = 0;',
-    '    this.SetSpeed(this.GetSpeed() + 12);',
+    '    $mod.TObject.SetSpeed($mod.TObject.GetSpeed() + 12);',
     '    $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
     '    return Result;',
     '  };',
@@ -22968,7 +23043,7 @@ begin
     '  this.GetField = function () {',
     '    var Result = 0;',
     '    $mod.THelper.Fly.call({',
-    '      p: this.GetField(),',
+    '      p: $mod.TObject.GetField(),',
     '      get: function () {',
     '          return this.p;',
     '        },',
@@ -27235,14 +27310,10 @@ end;
 procedure TTestModule.TestRTTI_IntRange;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
-  StartProgram(false);
+  StartProgram(true,[supTypeInfo]);
   Add([
   '{$modeswitch externalclass}',
   'type',
-  '  TTypeInfo = class external name ''rtl.tTypeInfo''',
-  '  end;',
-  '  TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo)',
-  '  end;',
   '  TGraphicsColor = -$7FFFFFFF-1..$7FFFFFFF;',
   '  TColor = type TGraphicsColor;',
   'var',
@@ -27271,12 +27342,10 @@ end;
 procedure TTestModule.TestRTTI_Double;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
-  StartProgram(false);
+  StartProgram(true,[supTypeInfo]);
   Add([
   '{$modeswitch externalclass}',
   'type',
-  '  TTypeInfo = class external name ''rtl.tTypeInfo''',
-  '  end;',
   '  TFloat = type double;',
   'var',
   '  p: TTypeInfo;',
@@ -28981,16 +29050,12 @@ end;
 procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses1;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
-  StartProgram(false);
+  StartProgram(true,[supTypeInfo]);
   Add([
   '{$modeswitch externalclass}',
   'type',
-  '  TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
-  '  TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;',
   '  TFlag = (up,down);',
-  '  TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;',
   '  TFlags = set of TFlag;',
-  '  TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;',
   'var',
   '  ti: TTypeInfo;',
   '  tiInt: TTypeInfoInteger;',
@@ -29053,18 +29118,13 @@ end;
 procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses2;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
-  StartProgram(false);
+  StartProgram(true,[supTypeInfo]);
   Add('{$modeswitch externalclass}');
   Add('type');
-  Add('  TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
   Add('  TStaticArr = array[boolean] of string;');
-  Add('  TTypeInfoStaticArray = class external name ''rtl.tTypeInfoStaticArray''(TTypeInfo) end;');
   Add('  TDynArr = array of string;');
-  Add('  TTypeInfoDynArray = class external name ''rtl.tTypeInfoDynArray''(TTypeInfo) end;');
   Add('  TProc = procedure;');
-  Add('  TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;');
   Add('  TMethod = procedure of object;');
-  Add('  TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;');
   Add('var');
   Add('  StaticArray: TStaticArr;');
   Add('  tiStaticArray: TTypeInfoStaticArray;');
@@ -29124,18 +29184,13 @@ end;
 procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses3;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
-  StartProgram(false);
+  StartProgram(true,[supTypeInfo]);
   Add('{$modeswitch externalclass}');
   Add('type');
-  Add('  TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
   Add('  TRec = record end;');
-  Add('  TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;');
   // ToDo: ^PRec
   Add('  TObject = class end;');
-  Add('  TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;');
   Add('  TClass = class of tobject;');
-  Add('  TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;');
-  Add('  TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;');
   Add('var');
   Add('  Rec: trec;');
   Add('  tiRecord: ttypeinforecord;');
@@ -29194,7 +29249,7 @@ end;
 procedure TTestModule.TestRTTI_TypeInfo_FunctionClassType;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
-  StartProgram(false);
+  StartProgram(true,[supTypeInfo]);
   Add([
   '{$modeswitch externalclass}',
   'type',
@@ -29203,8 +29258,6 @@ begin
   '    function MyClass: TClass;',
   '    class function ClassType: TClass;',
   '  end;',
-  '  TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
-  '  TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;',
   'function TObject.MyClass: TClass;',
   'var t: TTypeInfoClass;',
   'begin',
@@ -29347,7 +29400,7 @@ end;
 procedure TTestModule.TestRTTI_Interface_Corba;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
-  StartProgram(false);
+  StartProgram(true,[supTypeInfo]);
   Add([
   '{$interfaces corba}',
   '{$modeswitch externalclass}',
@@ -29359,8 +29412,6 @@ begin
   '    procedure SetItem(Value: longint);',
   '    property Item: longint read GetItem write SetItem;',
   '  end;',
-  '  TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
-  '  TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
   'procedure DoIt(t: TTypeInfoInterface); begin end;',
   'var',
   '  i: IBird;',
@@ -29412,7 +29463,7 @@ end;
 procedure TTestModule.TestRTTI_Interface_COM;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
-  StartProgram(false);
+  StartProgram(true,[supTypeInfo]);
   Add([
   '{$interfaces com}',
   '{$modeswitch externalclass}',
@@ -29429,8 +29480,6 @@ begin
   '    procedure SetItem(Value: longint);',
   '    property Item: longint read GetItem write SetItem;',
   '  end;',
-  '  TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
-  '  TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
   'var',
   '  i: IBird;',
   '  t: TTypeInfoInterface;',
@@ -29489,7 +29538,7 @@ end;
 procedure TTestModule.TestRTTI_ClassHelper;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
-  StartProgram(false);
+  StartProgram(true,[supTypeInfo]);
   Add([
   '{$interfaces com}',
   '{$modeswitch externalclass}',
@@ -29501,8 +29550,6 @@ begin
   '    function GetItem: longint;',
   '    property Item: longint read GetItem;',
   '  end;',
-  '  TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
-  '  TTypeInfoHelper = class external name ''rtl.tTypeInfoHelper''(TTypeInfo) end;',
   'function THelper.GetItem: longint;',
   'begin',
   'end;',
@@ -29536,6 +29583,40 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestRTTI_ExternalClass;
+begin
+  Converter.Options:=Converter.Options-[coNoTypeInfo];
+  StartProgram(true,[supTypeInfo]);
+  Add([
+  '{$modeswitch externalclass}',
+  'type',
+  '  TJSObject = class external name ''Object''',
+  '  end;',
+  '  TJSArray = class external name ''Array'' (TJSObject)',
+  '  end;',
+  'var',
+  '  p: Pointer;',
+  '  tc: TTypeInfoExtClass;',
+  'begin',
+  '  p:=typeinfo(TJSArray);']);
+  ConvertProgram;
+  CheckSource('TestRTTI_ExternalClass',
+    LinesToStr([ // statements
+    '$mod.$rtti.$ExtClass("TJSObject", {',
+    '  jsclass: "Object"',
+    '});',
+    '$mod.$rtti.$ExtClass("TJSArray", {',
+    '  ancestor: $mod.$rtti["TJSObject"],',
+    '  jsclass: "Array"',
+    '});',
+    'this.p = null;',
+    'this.tc = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.p = $mod.$rtti["TJSArray"];',
+    '']));
+end;
+
 procedure TTestModule.TestResourcestringProgram;
 begin
   StartProgram(false);
@@ -29829,7 +29910,6 @@ begin
   'constructor THelper.Create(Id: word); begin end;',
   'begin',
   '  if typeinfo(TMyInt)=nil then ;']);
-  //SetExpectedConverterError('aaa',123);
   ConvertProgram;
 end;
 

+ 23 - 1
utils/pas2js/dist/rtl.js

@@ -8,6 +8,8 @@ var rtl = {
   debug_load_units: false,
   debug_rtti: false,
 
+  $res : {},
+
   debug: function(){
     if (rtl.quiet || !console || !console.log) return;
     console.log(arguments);
@@ -1314,6 +1316,7 @@ var rtl = {
     newBaseTI("tTypeInfoClassRef",14 /* tkClassRef */);
     newBaseTI("tTypeInfoInterface",18 /* tkInterface */,rtl.tTypeInfoStruct);
     newBaseTI("tTypeInfoHelper",19 /* tkHelper */,rtl.tTypeInfoStruct);
+    newBaseTI("tTypeInfoExtClass",20 /* tkExtClass */,rtl.tTypeInfoClass);
   },
 
   tSectionRTTI: {
@@ -1364,7 +1367,8 @@ var rtl = {
     $ClassRef: function(name,o){ return this.$inherited(name,rtl.tTypeInfoClassRef,o); },
     $Pointer: function(name,o){ return this.$inherited(name,rtl.tTypeInfoPointer,o); },
     $Interface: function(name,o){ return this.$Scope(name,rtl.tTypeInfoInterface,o); },
-    $Helper: function(name,o){ return this.$Scope(name,rtl.tTypeInfoHelper,o); }
+    $Helper: function(name,o){ return this.$Scope(name,rtl.tTypeInfoHelper,o); },
+    $ExtClass: function(name,o){ return this.$Scope(name,rtl.tTypeInfoExtClass,o); }
   },
 
   newTIParam: function(param){
@@ -1393,5 +1397,23 @@ var rtl = {
       flags: flags
     };
     return s;
+  },
+
+  addResource: function(aRes){
+    rtl.$res[aRes.name]=aRes;
+  },
+
+  getResource: function(aName){
+    var res = rtl.$res[aName];
+    if (res !== undefined) {
+      return res;
+    } else {
+      return null;
+    }
+  },
+
+  getResourceList: function(){
+    return Object.keys(rtl.$res);
   }
 }
+

+ 8 - 4
utils/pas2js/docs/translation.html

@@ -2506,7 +2506,10 @@ function(){
     <div class="section">
     <h2 id="varargs">The procedure modifier varargs</h2>
     Appending the <b>varargs</b> modifier to a procedure allows to pass arbitrary
-    more parameters to a function. To access these non typed arguments use
+    more parameters to a function. By default these parameters are untyped, i.e.
+    any type fits. Alternatively you can use <b>varargs of aType</b> to allow
+    only specific types.<br>
+    To access these arguments use
     either <i>JSArguments</i> from unit JS or an <i>asm..end</i> block.
     <table class="sample">
       <tbody>
@@ -2693,10 +2696,11 @@ function(){
     external name is the member name. Keep in mind that JS is case sensitive.<br>
     Properties work the same as with Pascal classes, i.e. are replaced by Getter/Setter.<br>
     Destructors are not allowed.<br>
-    Constructors are supported in three ways:
+    Constructors are supported in four ways:
     <ul>
-      <li>With name <i>New</i> it is translated to <i>new ExtClass(params)</i>.</li>
-      <li>With external name <i>'{}'</i> it is translated to <i>{}</i>.</li>
+      <li><i>constructor New</i> is translated to <i>new ExtClass(params)</i>.</li>
+      <li><i>constructor New; external name ''GlobalFunc''</i> is translated to <i>new GlobalFunc(params)</i>.</li>
+      <li><i>constructor SomeName; external name <i>'{}'</i> is translated to <i>{}</i>.</li>
       <li>Otherwise it is translated to <i>new ExtClass.FuncName(params)</i>.</li>
     </ul>
 

Some files were not shown because too many files changed in this diff