mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-20 09:09:41 +01:00
fcl-passrc: added modeswitch ignoreinterfaces, typecast enum to integer
git-svn-id: trunk@37335 -
This commit is contained in:
Mattias Gaertner
parent
a52b675779
commit
b69ffccb44
@ -1387,6 +1387,7 @@ type
|
||||
function GetSmallestIntegerBaseType(MinVal, MaxVal: MaxPrecInt): TResolverBaseType;
|
||||
function GetCombinedChar(const Char1, Char2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
|
||||
function GetCombinedString(const Str1, Str2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
|
||||
function IsElementSkipped(El: TPasElement): boolean; virtual;
|
||||
public
|
||||
// options
|
||||
property Options: TPasResolverOptions read FOptions write FOptions;
|
||||
@ -3457,7 +3458,10 @@ procedure TPasResolver.FinishConstDef(El: TPasConst);
|
||||
begin
|
||||
ResolveExpr(El.Expr,rraRead);
|
||||
if El.VarType<>nil then
|
||||
CheckAssignCompatibility(El,El.Expr,true)
|
||||
begin
|
||||
CheckAssignCompatibility(El,El.Expr,true);
|
||||
EmitTypeHints(El,El.VarType);
|
||||
end
|
||||
else
|
||||
Eval(El.Expr,[refConst])
|
||||
end;
|
||||
@ -3610,6 +3614,9 @@ begin
|
||||
if not IsValidIdent(ProcName) then
|
||||
RaiseNotYetImplemented(20160922163407,El);
|
||||
|
||||
if El is TPasFunctionType then
|
||||
EmitTypeHints(TPasFunctionType(El).ResultEl,TPasFunctionType(El).ResultEl.ResultType);
|
||||
|
||||
if Proc.LibraryExpr<>nil then
|
||||
ResolveExpr(Proc.LibraryExpr,rraRead);
|
||||
if Proc.LibrarySymbolName<>nil then
|
||||
@ -4405,7 +4412,12 @@ begin
|
||||
if aClass.IsForward then
|
||||
exit;
|
||||
if aClass.ObjKind<>okClass then
|
||||
begin
|
||||
if (aClass.ObjKind=okInterface)
|
||||
and (msIgnoreInterfaces in CurrentParser.CurrentModeswitches) then
|
||||
exit;
|
||||
RaiseNotYetImplemented(20161010174638,aClass,'Kind='+ObjKindNames[aClass.ObjKind]);
|
||||
end;
|
||||
|
||||
IsSealed:=false;
|
||||
for i:=0 to aClass.Modifiers.Count-1 do
|
||||
@ -4443,7 +4455,10 @@ begin
|
||||
else
|
||||
begin
|
||||
AncestorEl:=TPasClassType(AncestorType);
|
||||
EmitTypeHints(aClass,AncestorEl);
|
||||
if AncestorEl.ObjKind<>okClass then
|
||||
AncestorEl:=nil
|
||||
else
|
||||
EmitTypeHints(aClass,AncestorEl);
|
||||
end;
|
||||
|
||||
AncestorClassScope:=nil;
|
||||
@ -4502,6 +4517,8 @@ begin
|
||||
CanonicalSelf.Visibility:=visStrictPrivate;
|
||||
CanonicalSelf.SourceFilename:=aClass.SourceFilename;
|
||||
CanonicalSelf.SourceLinenumber:=aClass.SourceLinenumber;
|
||||
|
||||
// ToDo: interfaces
|
||||
end;
|
||||
|
||||
procedure TPasResolver.FinishPropertyParamAccess(Params: TParamsExpr;
|
||||
@ -4542,6 +4559,8 @@ end;
|
||||
|
||||
function TPasResolver.EmitElementHints(PosEl, El: TPasElement): boolean;
|
||||
begin
|
||||
if IsElementSkipped(El) then
|
||||
RaiseMsg(20170927160030,nNotYetImplemented,sNotYetImplemented,[GetObjName(El)],PosEl);
|
||||
if El.Hints=[] then exit(false);
|
||||
Result:=true;
|
||||
if hDeprecated in El.Hints then
|
||||
@ -5923,6 +5942,7 @@ var
|
||||
Proc: TPasProcedure;
|
||||
aClassType: TPasClassType;
|
||||
begin
|
||||
if IsElementSkipped(El) then exit;
|
||||
if El is TPasDeclarations then
|
||||
begin
|
||||
for i:=0 to TPasDeclarations(El).Declarations.Count-1 do
|
||||
@ -9262,6 +9282,8 @@ begin
|
||||
if FRootElement=nil then
|
||||
FRootElement:=Result as TPasModule;
|
||||
|
||||
if IsElementSkipped(El) then exit;
|
||||
|
||||
// create scope
|
||||
if (AClass=TPasVariable)
|
||||
or (AClass=TPasConst) then
|
||||
@ -9797,6 +9819,7 @@ end;
|
||||
|
||||
procedure TPasResolver.FinishScope(ScopeType: TPasScopeType; El: TPasElement);
|
||||
begin
|
||||
if IsElementSkipped(El) then exit;
|
||||
case ScopeType of
|
||||
stModule: FinishModule(El as TPasModule);
|
||||
stUsesClause: FinishUsesClause;
|
||||
@ -11654,11 +11677,15 @@ end;
|
||||
|
||||
function TPasResolver.ResolvedElIsClassInstance(
|
||||
const ResolvedEl: TPasResolverResult): boolean;
|
||||
var
|
||||
TypeEl: TPasType;
|
||||
begin
|
||||
Result:=false;
|
||||
if ResolvedEl.BaseType<>btContext then exit;
|
||||
if ResolvedEl.TypeEl=nil then exit;
|
||||
if ResolvedEl.TypeEl.ClassType<>TPasClassType then exit;
|
||||
TypeEl:=ResolvedEl.TypeEl;
|
||||
if TypeEl=nil then exit;
|
||||
if TypeEl.ClassType<>TPasClassType then exit;
|
||||
if TPasClassType(TypeEl).ObjKind<>okClass then exit;
|
||||
if (ResolvedEl.IdentEl is TPasVariable)
|
||||
or (ResolvedEl.IdentEl.ClassType=TPasArgument)
|
||||
or (ResolvedEl.IdentEl.ClassType=TPasResultElement) then
|
||||
@ -12571,7 +12598,13 @@ begin
|
||||
if FromResolved.BaseType in btAllInteger then
|
||||
Result:=cCompatible
|
||||
else if FromResolved.BaseType in btAllBooleans then
|
||||
Result:=cCompatible;
|
||||
Result:=cCompatible
|
||||
else if FromResolved.BaseType=btContext then
|
||||
begin
|
||||
if FromResolved.TypeEl.ClassType=TPasEnumType then
|
||||
// e.g. longint(TEnum)
|
||||
Result:=cCompatible;
|
||||
end;
|
||||
end
|
||||
else if ToTypeBaseType in btAllFloats then
|
||||
begin
|
||||
@ -13987,6 +14020,25 @@ begin
|
||||
Result:=btString;
|
||||
end;
|
||||
|
||||
function TPasResolver.IsElementSkipped(El: TPasElement): boolean;
|
||||
var
|
||||
C: TClass;
|
||||
aClass: TPasClassType;
|
||||
begin
|
||||
while El<>nil do
|
||||
begin
|
||||
C:=El.ClassType;
|
||||
if C.ClassType=TPasClassType then
|
||||
begin
|
||||
aClass:=TPasClassType(El);
|
||||
if aClass.ObjKind=okInterface then
|
||||
exit(true);
|
||||
end;
|
||||
El:=El.Parent;
|
||||
end;
|
||||
Result:=false;
|
||||
end;
|
||||
|
||||
function TPasResolver.CheckSrcIsADstType(const ResolvedSrcType,
|
||||
ResolvedDestType: TPasResolverResult; ErrorEl: TPasElement): integer;
|
||||
// finds distance between classes SrcType and DestType
|
||||
|
||||
@ -1287,6 +1287,9 @@ var
|
||||
ClassScope: TPasClassScope;
|
||||
Ref: TResolvedReference;
|
||||
begin
|
||||
if El.ObjKind=okInterface then
|
||||
exit;
|
||||
|
||||
FirstTime:=true;
|
||||
case Mode of
|
||||
paumAllExports: exit;
|
||||
|
||||
@ -262,7 +262,8 @@ type
|
||||
msISOLikeIO, { I/O as it required by an ISO compatible compiler }
|
||||
msISOLikeProgramsPara, { program parameters as it required by an ISO compatible compiler }
|
||||
msISOLikeMod, { mod operation as it is required by an iso compatible compiler }
|
||||
msExternalClass { Allow external class definitions }
|
||||
msExternalClass, { Allow external class definitions }
|
||||
msIgnoreInterfaces { workaround til resolver/converter supports interfaces }
|
||||
);
|
||||
TModeSwitches = Set of TModeSwitch;
|
||||
|
||||
@ -815,7 +816,8 @@ const
|
||||
'ISOIO',
|
||||
'ISOPROGRAMPARAS',
|
||||
'ISOMOD',
|
||||
'EXTERNALCLASS'
|
||||
'EXTERNALCLASS',
|
||||
'IGNOREINTERFACES'
|
||||
);
|
||||
|
||||
LetterSwitchNames: array['A'..'Z'] of string=(
|
||||
|
||||
@ -520,6 +520,12 @@ type
|
||||
Procedure TestDefaultProperty;
|
||||
Procedure TestMissingDefaultProperty;
|
||||
|
||||
// class interfaces
|
||||
Procedure TestIgnoreInterfaces;
|
||||
Procedure TestInterfaceVarFail;
|
||||
Procedure TestInterfaceArgFail;
|
||||
Procedure TestInterfaceFunctionResultFail;
|
||||
|
||||
// with
|
||||
Procedure TestWithBlock1;
|
||||
Procedure TestWithBlock2;
|
||||
@ -738,9 +744,9 @@ begin
|
||||
aRow:=E.Row;
|
||||
aCol:=E.Column;
|
||||
WriteSources(aFilename,aRow,aCol);
|
||||
writeln('ERROR: TTestResolver.ParseProgram Parser: '+E.ClassName+':'+E.Message
|
||||
+' Scanner at'
|
||||
+' at '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')'
|
||||
writeln('ERROR: TTestResolver.ParseProgram Parser: '+E.ClassName+':'+E.Message,
|
||||
' Scanner at'
|
||||
+' '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')'
|
||||
+' Line="'+Scanner.CurLine+'"');
|
||||
Fail(E.Message);
|
||||
end;
|
||||
@ -2636,6 +2642,7 @@ begin
|
||||
Add('var');
|
||||
Add(' {#f}{=TFlag}f: TFlag;');
|
||||
Add(' {#v}{=TFlag}v: TFlag = Green;');
|
||||
Add(' {#i}i: longint;');
|
||||
Add('begin');
|
||||
Add(' {@f}f:={@Red}Red;');
|
||||
Add(' {@f}f:={@v}v;');
|
||||
@ -2648,6 +2655,8 @@ begin
|
||||
Add(' if {@f}f<>{@v}v then ;');
|
||||
Add(' if ord({@f}f)<>ord({@Red}Red) then ;');
|
||||
Add(' {@f}f:={@TFlag}TFlag.{@Red}Red;');
|
||||
Add(' {@f}f:={@TFlag}TFlag({@i}i);');
|
||||
Add(' {@i}i:=longint({@f}f);');
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
@ -8336,6 +8345,77 @@ begin
|
||||
nIllegalQualifier);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestIgnoreInterfaces;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch ignoreinterfaces}',
|
||||
'type',
|
||||
' TGUID = record end;',
|
||||
' IUnknown = interface;',
|
||||
' IUnknown = interface',
|
||||
' [''{00000000-0000-0000-C000-000000000046}'']',
|
||||
' function QueryInterface(const iid : tguid;out obj) : longint;',
|
||||
' function _AddRef : longint; cdecl;',
|
||||
' function _Release : longint; stdcall;',
|
||||
' end;',
|
||||
' IInterface = IUnknown;',
|
||||
' TObject = class',
|
||||
' ClassName: string;',
|
||||
' end;',
|
||||
' TInterfacedObject = class(TObject,IUnknown)',
|
||||
' RefCount : longint;',
|
||||
' end;',
|
||||
'var i: TInterfacedObject;',
|
||||
'begin',
|
||||
' i.ClassName:=''a'';',
|
||||
' i.RefCount:=3;',
|
||||
'']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestInterfaceVarFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch ignoreinterfaces}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' end;',
|
||||
'var i: IUnknown;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('not yet implemented: IUnknown:TPasClassType',nNotYetImplemented);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestInterfaceArgFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch ignoreinterfaces}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' end;',
|
||||
'procedure DoIt(i: IUnknown); begin end;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('not yet implemented: IUnknown:TPasClassType',nNotYetImplemented);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestInterfaceFunctionResultFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch ignoreinterfaces}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' end;',
|
||||
'function DoIt: IUnknown; begin end;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('not yet implemented: IUnknown:TPasClassType',nNotYetImplemented);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestPropertyAssign;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
||||
@ -72,6 +72,7 @@ type
|
||||
procedure TestM_Class_PropertyOverride;
|
||||
procedure TestM_Class_MethodOverride;
|
||||
procedure TestM_Class_MethodOverride2;
|
||||
procedure TestM_ClassInterface_Ignore;
|
||||
procedure TestM_TryExceptStatement;
|
||||
|
||||
// single module hints
|
||||
@ -828,6 +829,35 @@ begin
|
||||
AnalyzeProgram;
|
||||
end;
|
||||
|
||||
procedure TTestUseAnalyzer.TestM_ClassInterface_Ignore;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch ignoreinterfaces}',
|
||||
'type',
|
||||
' TGUID = record end;',
|
||||
' IUnknown = interface;',
|
||||
' IUnknown = interface',
|
||||
' [''{00000000-0000-0000-C000-000000000046}'']',
|
||||
' function QueryInterface(const iid : tguid;out obj) : longint;',
|
||||
' function _AddRef : longint; cdecl;',
|
||||
' function _Release : longint; stdcall;',
|
||||
' end;',
|
||||
' IInterface = IUnknown;',
|
||||
' TObject = class',
|
||||
' ClassName: string;',
|
||||
' end;',
|
||||
' TInterfacedObject = class(TObject,IUnknown)',
|
||||
' RefCount : longint;',
|
||||
' end;',
|
||||
'var i: TInterfacedObject;',
|
||||
'begin',
|
||||
' i.ClassName:=''a'';',
|
||||
' i.RefCount:=3;',
|
||||
'']);
|
||||
AnalyzeProgram;
|
||||
end;
|
||||
|
||||
procedure TTestUseAnalyzer.TestM_TryExceptStatement;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user