diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index e467bf0afc..2a90102a95 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -1570,7 +1570,8 @@ begin ParseExcSyntaxError; UnGetToken; end - else if (CurToken = tkLessThan) then // A = B; + else if (CurToken = tkLessThan) + and (MustBeSpecialize or (msDelphi in CurrentModeswitches)) then // A = B; begin Result:=ParseSpecializeType(Parent,TypeName,Name,Expr); ok:=true; diff --git a/packages/fcl-passrc/tests/tcgenerics.pp b/packages/fcl-passrc/tests/tcgenerics.pp index baad6b3710..cb8b73cfb5 100644 --- a/packages/fcl-passrc/tests/tcgenerics.pp +++ b/packages/fcl-passrc/tests/tcgenerics.pp @@ -97,7 +97,7 @@ begin ' b : T;', 'end;', 'Generic TBird = class', - ' c : TBird;', + ' c : specialize TBird;', 'end;', 'Generic TEagle = class', 'end;', @@ -116,11 +116,11 @@ begin 'TBird = class(TInterfacedObject,TIntfA,TIntfB) end;', 'Generic TAnt = class', ' b: T;', - ' c: TAnt;', + ' c: specialize TAnt;', 'end;', 'Generic TFly = class', ' b: S;', - ' c: TFly;', + ' c: specialize TFly;', 'end;', '']); ParseDeclarations; @@ -148,6 +148,7 @@ end; procedure TTestGenerics.TestSpecializationDelphi; begin + Add('{$mode delphi}'); ParseType('TFPGList',TPasSpecializeType,''); end; diff --git a/packages/fcl-passrc/tests/tcresolvegenerics.pas b/packages/fcl-passrc/tests/tcresolvegenerics.pas index 06ad1d2a90..28543aec1c 100644 --- a/packages/fcl-passrc/tests/tcresolvegenerics.pas +++ b/packages/fcl-passrc/tests/tcresolvegenerics.pas @@ -147,7 +147,7 @@ begin StartProgram(false); Add([ 'type generic TBird = record end;', - 'var b: TBird;', + 'var b: specialize TBird;', 'begin', '']); CheckResolverException('identifier not found "TBird<,>"', @@ -523,9 +523,9 @@ begin ' for i in m do ;', 'end;', 'var', - ' a: TAnt;', + ' a: specialize TAnt;', ' w: word;', - ' b: TBird>;', + ' b: specialize TBird>;', 'begin', ' for w in a do ;', ' for w in b.m do ;', @@ -800,12 +800,12 @@ begin ' generic TAnt = class;', ' generic TFish = class', ' private type AliasU = U;', - ' var a: TAnt;', + ' var a: specialize TAnt;', ' Size: AliasU;', ' end;', ' generic TAnt = class', ' private type AliasT = T;', - ' var f: TFish;', + ' var f: specialize TFish;', ' Speed: AliasT;', ' end;', 'var', @@ -991,7 +991,7 @@ begin ' TObject = class end;', ' generic TBird = class', ' e: T;', - ' v: TBird;', + ' v: specialize TBird;', ' end;', 'var', ' b: specialize TBird;', @@ -1606,8 +1606,8 @@ begin ' except', ' on Exception do ;', ' on E: Exception do ;', - ' on E: EMsg do E.Msg:=true;', - ' on E: EMsg do E.Msg:=1;', + ' on E: specialize EMsg do E.Msg:=true;', + ' on E: specialize EMsg do E.Msg:=1;', ' end;', 'end;', 'var', diff --git a/packages/pastojs/tests/tcgenerics.pas b/packages/pastojs/tests/tcgenerics.pas index 1663a73427..af797fd272 100644 --- a/packages/pastojs/tests/tcgenerics.pas +++ b/packages/pastojs/tests/tcgenerics.pas @@ -6,7 +6,7 @@ interface uses Classes, SysUtils, fpcunit, testregistry, - TCModules; + TCModules, FPPas2Js; type @@ -22,6 +22,7 @@ type Procedure TestGen_Class_EmptyMethod; Procedure TestGen_Class_TList; Procedure TestGen_ClassAncestor; + Procedure TestGen_TypeInfo; // generic external class procedure TestGen_ExtClass_Array; @@ -242,6 +243,51 @@ begin ''])); end; +procedure TTestGenerics.TestGen_TypeInfo; +begin + Converter.Options:=Converter.Options-[coNoTypeInfo]; + StartProgram(false); + Add([ + 'type', + ' TObject = class end;', + ' generic TBird = class', + ' published', + ' m: T;', + ' end;', + ' TEagle = specialize TBird;', + 'var', + ' b: specialize TBird;', + ' p: pointer;', + 'begin', + ' p:=typeinfo(TEagle);', + ' p:=typeinfo(b);', + '']); + ConvertProgram; + CheckSource('TestGen_TypeInfo', + 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.m = 0;', + ' };', + ' var $r = this.$rtti;', + ' $r.addField("m", rtl.word);', + '});', + 'this.b = null;', + 'this.p = null;', + '']), + LinesToStr([ // $mod.$main + '$mod.p = $mod.$rtti["TBird$G1"];', + '$mod.p = $mod.b.$rtti;', + ''])); +end; + procedure TTestGenerics.TestGen_ExtClass_Array; begin StartProgram(false); @@ -314,7 +360,7 @@ begin ' generic TBird = class', ' end;', 'constructor TObject.Create; begin end;', - 'var b: TBird;', + 'var b: specialize TBird;', 'begin', ' b:=specialize TBird.Create;', '']);