From 7173349689bafb1c78d6f09b84a483bec2a24881 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Sat, 10 Aug 2019 21:02:09 +0000 Subject: [PATCH] fcl-passrc: specialize external class git-svn-id: trunk@42644 - --- packages/fcl-passrc/src/pasresolver.pp | 2 + packages/fcl-passrc/src/pparser.pp | 82 ++++++++++++------- .../fcl-passrc/tests/tcresolvegenerics.pas | 46 +++++++++++ 3 files changed, 100 insertions(+), 30 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index f84ae54641..33fcbb175c 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -10890,6 +10890,8 @@ begin exit; if TPasClassType(aClassOrRec).IsForward then exit; + if TPasClassType(aClassOrRec).IsExternal then + exit; end; ClassOrRecScope:=aClassOrRec.CustomData as TPasClassOrRecordScope; if ClassOrRecScope.SpecializedFrom<>nil then diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 1d08a862ed..a17b15686f 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -369,6 +369,8 @@ type function ParseExprOperand(AParent : TPasElement): TPasExpr; function ParseExpIdent(AParent : TPasElement): TPasExpr; deprecated 'use ParseExprOperand instead'; // since fpc 3.3.1 procedure DoParseClassType(AType: TPasClassType); + procedure DoParseClassExternalHeader(AObjKind: TPasObjKind; + out AExternalNameSpace, AExternalName: string); procedure DoParseArrayType(ArrType: TPasArrayType); function DoParseExpression(AParent: TPaselement;InitExpr: TPasExpr=nil; AllowEqual : Boolean = True): TPasExpr; function DoParseConstValueExpression(AParent: TPasElement): TPasExpr; @@ -1702,8 +1704,12 @@ begin ParseExcTokenError('[20190801112729]'); ST:=TPasSpecializeType(CreateElement(TPasSpecializeType,TypeName,Parent)); try - ST.Expr:=GenNameExpr; - GenNameExpr:=nil; // ownership transferred to ST + if GenNameExpr<>nil then + begin + ST.Expr:=GenNameExpr; + GenNameExpr.Parent:=ST; + GenNameExpr:=nil; // ownership transferred to ST + end; // read nested specialize arguments ReadSpecializeArguments(ST); // Important: resolve type reference AFTER args, because arg count is needed @@ -4265,7 +4271,7 @@ function TPasParser.ParseGenericTypeDecl(Parent: TPasElement; end; var - TypeName: String; + TypeName, AExternalNameSpace, AExternalName: String; NamePos: TPasSourcePos; TypeParams: TFPList; ClassEl: TPasClassType; @@ -4274,6 +4280,7 @@ var ProcTypeEl: TPasProcedureType; ProcType: TProcType; i: Integer; + AObjKind: TPasObjKind; begin Result:=nil; TypeName := CurTokenString; @@ -4287,16 +4294,25 @@ begin tkObject, tkClass : begin + if CurToken=tkobject then + AObjKind:=okObject + else + AObjKind:=okClass; + NextToken; + if (AObjKind = okClass) and (CurToken = tkOf) then + ParseExcExpectedIdentifier; + DoParseClassExternalHeader(AObjKind,AExternalNameSpace,AExternalName); ClassEl := TPasClassType(CreateElement(TPasClassType, TypeName, Parent, visDefault, NamePos, TypeParams)); - if CurToken=tkobject then - ClassEl.ObjKind:=okObject - else - ClassEl.ObjKind:=okClass; + ClassEl.ObjKind:=AObjKind; if AddToParent and (Parent is TPasDeclarations) then TPasDeclarations(Parent).Classes.Add(ClassEl); + ClassEl.IsExternal:=(AExternalName<>''); + if AExternalName<>'' then + ClassEl.ExternalName:={$ifdef pas2js}DeQuoteString{$else}AnsiDequotedStr{$endif}(AExternalName,''''); + if AExternalNameSpace<>'' then + ClassEl.ExternalNameSpace:={$ifdef pas2js}DeQuoteString{$else}AnsiDequotedStr{$endif}(AExternalNameSpace,''''); InitGenericType(ClassEl,TypeParams); - NextToken; DoParseClassType(ClassEl); CheckHint(ClassEl,True); Engine.FinishScope(stTypeDef,ClassEl); @@ -7125,6 +7141,33 @@ begin end; end; +procedure TPasParser.DoParseClassExternalHeader(AObjKind: TPasObjKind; out + AExternalNameSpace, AExternalName: string); +begin + if ((AObjKind in [okClass,okInterface]) and (msExternalClass in CurrentModeswitches) + and CurTokenIsIdentifier('external')) then + begin + NextToken; + if CurToken<>tkString then + UnGetToken + else + AExternalNameSpace:=CurTokenString; + ExpectIdentifier; + If Not CurTokenIsIdentifier('Name') then + ParseExc(nParserExpectedExternalClassName,SParserExpectedExternalClassName); + NextToken; + if not (CurToken in [tkChar,tkString]) then + CheckToken(tkString); + AExternalName:=CurTokenString; + NextToken; + end + else + begin + AExternalNameSpace:=''; + AExternalName:=''; + end; +end; + procedure TPasParser.DoParseArrayType(ArrType: TPasArrayType); var S: String; @@ -7211,28 +7254,7 @@ begin end; exit; end; - if ((AObjKind in [okClass,okInterface]) and (msExternalClass in CurrentModeswitches) - and CurTokenIsIdentifier('external')) then - begin - NextToken; - if CurToken<>tkString then - UnGetToken - else - AExternalNameSpace:=CurTokenString; - ExpectIdentifier; - If Not CurTokenIsIdentifier('Name') then - ParseExc(nParserExpectedExternalClassName,SParserExpectedExternalClassName); - NextToken; - if not (CurToken in [tkChar,tkString]) then - CheckToken(tkString); - AExternalName:=CurTokenString; - NextToken; - end - else - begin - AExternalNameSpace:=''; - AExternalName:=''; - end; + DoParseClassExternalHeader(AObjKind,AExternalNameSpace,AExternalName); if AObjKind in okAllHelpers then begin if not CurTokenIsIdentifier('Helper') then diff --git a/packages/fcl-passrc/tests/tcresolvegenerics.pas b/packages/fcl-passrc/tests/tcresolvegenerics.pas index 8c44df8dd3..4306a7c5e9 100644 --- a/packages/fcl-passrc/tests/tcresolvegenerics.pas +++ b/packages/fcl-passrc/tests/tcresolvegenerics.pas @@ -58,6 +58,9 @@ type // ToDo: class-of // ToDo: UnitA.impl uses UnitB.intf uses UnitA.intf, UnitB has specialize of UnitA + // generic external class + procedure TestGen_ExtClass_Array; + // ToDo: generic interface // ToDo: generic array @@ -499,6 +502,49 @@ begin CheckResolverException('type "TBird" is not yet completely defined',nTypeXIsNotYetCompletelyDefined); end; +procedure TTestResolveGenerics.TestGen_ExtClass_Array; +begin + StartProgram(false); + Add([ + '{$mode delphi}', + '{$ModeSwitch externalclass}', + 'type', + ' NativeInt = longint;', + ' TJSGenArray = Class external name ''Array''', + ' private', + ' function GetElements(Index: NativeInt): T; external name ''[]'';', + ' procedure SetElements(Index: NativeInt; const AValue: T); external name ''[]'';', + ' public', + ' type TSelfType = TJSGenArray;', + ' public', + ' FLength : NativeInt; external name ''length'';', + ' constructor new; overload;', + ' constructor new(aLength : NativeInt); overload;', + ' class function _of() : TSelfType; varargs; external name ''of'';', + ' function fill(aValue : T) : TSelfType; overload;', + ' function fill(aValue : T; aStartIndex : NativeInt) : TSelfType; overload;', + ' function fill(aValue : T; aStartIndex,aEndIndex : NativeInt) : TSelfType; overload;', + ' property Length : NativeInt Read FLength Write FLength;', + ' property Elements[Index: NativeInt]: T read GetElements write SetElements; default;', + ' end;', + ' TJSWordArray = TJSGenArray;', + 'var', + ' wa: TJSWordArray;', + ' w: word;', + 'begin', + ' wa:=TJSWordArray.new;', + ' wa:=TJSWordArray.new(3);', + ' wa:=TJSWordArray._of(4,5);', + ' wa:=wa.fill(7);', + ' wa:=wa.fill(7,8,9);', + ' w:=wa.length;', + ' wa.length:=10;', + ' wa[11]:=w;', + ' w:=wa[12];', + '']); + ParseProgram; +end; + procedure TTestResolveGenerics.TestGen_GenericFunction; begin StartProgram(false);