diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas index 9e731c4f18..16c6a5e5ec 100644 --- a/packages/fcl-passrc/src/pasresolveeval.pas +++ b/packages/fcl-passrc/src/pasresolveeval.pas @@ -141,6 +141,7 @@ const nOverflowInArithmeticOperation = 3068; nDivByZero = 3069; nRangeCheckInSetConstructor = 3070; + nIncompatibleTypesGotParametersExpected = 3071; // resourcestring patterns of messages resourcestring @@ -214,6 +215,7 @@ resourcestring sOverflowInArithmeticOperation = 'Overflow in arithmetic operation'; sDivByZero = 'Division by zero'; sRangeCheckInSetConstructor = 'range check error in set constructor or duplicate set element'; + sIncompatibleTypesGotParametersExpected = 'Incompatible types, got %s parameters, expected %s'; type { TResolveData - base class for data stored in TPasElement.CustomData } diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 3ef47f4ce5..27aab4c31d 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -150,13 +150,13 @@ Works: - a:=value ToDo: +- @@ - range checking: - arr[index] - indexedprop[param] - case-of unique - defaultvalue - stored -- @@ - fail to write a loop var inside the loop - warn: create class with abstract methods - classes - TPasClassType @@ -10762,7 +10762,14 @@ begin end; ProcArgs1:=Proc1.Args; ProcArgs2:=Proc2.Args; - if ProcArgs1.Count<>ProcArgs2.Count then exit; + if ProcArgs1.Count<>ProcArgs2.Count then + begin + if RaiseOnIncompatible then + RaiseMsg(20170902142829,nIncompatibleTypesGotParametersExpected, + sIncompatibleTypesGotParametersExpected, + [IntToStr(ProcArgs1.Count),IntToStr(ProcArgs2.Count)],ErrorEl); + exit; + end; for i:=0 to ProcArgs1.Count-1 do begin {$IFDEF VerbosePasResolver} @@ -11279,7 +11286,7 @@ begin // for example ProcVar:=Proc if CheckProcTypeCompatibility(TPasProcedureType(LHS.TypeEl), TPasProcedure(RHS.IdentEl).ProcType,true,ErrorEl,RaiseOnIncompatible) then - Result:=cExact; + exit(cExact); end; end else if LBT=btPointer then @@ -11413,7 +11420,7 @@ begin if RErrorEl=nil then RErrorEl:=LErrorEl; // check if the RHS is type compatible to LHS {$IFDEF VerbosePasResolver} - writeln('TPasResolver.CheckEqualCompatibility LHS=',GetResolverResultDbg(LHS),' RHS=',GetResolverResultDbg(RHS)); + writeln('TPasResolver.CheckEqualResCompatibility LHS=',GetResolverResultDbg(LHS),' RHS=',GetResolverResultDbg(RHS)); {$ENDIF} if not (rrfReadable in LHS.Flags) then begin @@ -12880,7 +12887,7 @@ begin ComputeBinaryExpr(TBinaryExpr(El),ResolvedEl,Flags,StartEl) else if ElClass=TUnaryExpr then begin - if TUnaryExpr(El).OpCode=eopAddress then + if TUnaryExpr(El).OpCode in [eopAddress,eopMemAddress] then ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags+[rcNoImplicitProc],StartEl) else ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags,StartEl); @@ -12906,6 +12913,13 @@ begin end else RaiseMsg(20170216152535,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El); + eopMemAddress: + begin + if (ResolvedEl.BaseType=btContext) and (ResolvedEl.TypeEl is TPasProcedureType) then + exit + else + RaiseMsg(20170902145547,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El); + end; end; RaiseNotYetImplemented(20160926142426,El); end diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index c190da078e..3c3d53ff28 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -175,7 +175,7 @@ type eopEqual, eopNotEqual, // Logical eopLessThan,eopGreaterThan, eopLessthanEqual,eopGreaterThanEqual, // ordering eopIn,eopIs,eopAs, eopSymmetricaldifference, // Specials - eopAddress, eopDeref, // Pointers + eopAddress, eopDeref, eopMemAddress, // Pointers eopSubIdent); // SomeRec.A, A is subIdent of SomeRec { TPasExpr } @@ -1481,7 +1481,7 @@ const '=','<>', '<','>','<=','>=', 'in','is','as','><', - '@','^', + '@','^','@@', '.'); @@ -3582,8 +3582,6 @@ function TPasRecordType.GetDeclaration (full : boolean) : string; Var S : TStringList; temp : string; - i : integer; - begin S:=TStringList.Create; Try diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 3a61995cae..06e023b27f 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -1877,6 +1877,7 @@ begin tkEqual : Result:=eopEqual; tkGreaterThan : Result:=eopGreaterThan; tkAt : Result:=eopAddress; + tkAtAt : Result:=eopMemAddress; tkNotEqual : Result:=eopNotEqual; tkLessEqualThan : Result:=eopLessthanEqual; tkGreaterEqualThan : Result:=eopGreaterThanEqual; @@ -2046,18 +2047,6 @@ begin Last:=CreateSelfExpr(AParent); HandleSelf(Last); end; - tkAt: - begin - // is this still needed? - // P:=@function; - NextToken; - if (length(CurTokenText)=0) or not (CurTokenText[1] in ['A'..'_']) then - begin - UngetToken; - ParseExcExpectedIdentifier; - end; - Last:=CreatePrimitiveExpr(AParent,pekString, '@'+CurTokenText); - end; tkCaret: begin // is this still needed? @@ -2155,7 +2144,7 @@ begin case t of // tkDot: // Result:=5; - tknot,tkAt: + tknot,tkAt,tkAtAt: Result:=4; tkMul, tkDivision, tkdiv, tkmod, tkand, tkShl,tkShr, tkas, tkPower : Result:=3; @@ -2180,7 +2169,7 @@ var NotBinary : Boolean; const - PrefixSym = [tkPlus, tkMinus, tknot, tkAt]; // + - not @ + PrefixSym = [tkPlus, tkMinus, tknot, tkAt, tkAtAt]; // + - not @ BinaryOP = [tkMul, tkDivision, tkdiv, tkmod, tkDotDot, tkand, tkShl,tkShr, tkas, tkPower, tkPlus, tkMinus, tkor, tkxor, tkSymmetricalDifference, @@ -4659,7 +4648,7 @@ Var Function atEndOfAsm : Boolean; begin - Result:=(CurToken=tkEnd) and (LastToken<>tkAt); + Result:=(CurToken=tkEnd) and not (LastToken in [tkAt,tkAtAt]); end; begin @@ -5137,11 +5126,12 @@ begin end; tkEOF: CheckToken(tkend); - tkAt,tkBraceOpen,tkIdentifier,tkNumber,tkSquaredBraceOpen,tkMinus,tkPlus,tkinherited: + tkAt,tkAtAt,tkBraceOpen,tkIdentifier,tkNumber,tkSquaredBraceOpen,tkMinus,tkPlus,tkinherited: begin -// This should in fact not be checked here. -// if (CurToken=tkAt) and not (msDelphi in CurrentModeswitches) then -// ParseExc; + // Do not check this here: + // if (CurToken=tkAt) and not (msDelphi in CurrentModeswitches) then + // ParseExc; + // On is usable as an identifier if lowerCase(CurTokenText)='on' then begin diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index 391b6584c7..f8ac1e224f 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -138,6 +138,7 @@ type tkAssignMinus, // -= tkAssignMul, // *= tkAssignDivision, // /= + tkAtAt, // @@ // Reserved words tkabsolute, tkand, @@ -685,6 +686,7 @@ const '-=', '*=', '/=', + '@@', // Reserved words 'absolute', 'and', @@ -3268,6 +3270,11 @@ begin begin Inc(TokenStr); Result := tkAt; + if TokenStr^='@' then + begin + Inc(TokenStr); + Result:=tkAtAt; + end; end; '[': begin diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 89571f8016..77ff1b9eec 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -565,6 +565,7 @@ type Procedure TestProcTypeCall; Procedure TestProcType_FunctionFPC; Procedure TestProcType_FunctionDelphi; + Procedure TestProcType_ProcedureDelphi; Procedure TestProcType_MethodFPC; Procedure TestProcType_MethodDelphi; Procedure TestAssignProcToMethodFail; @@ -9202,6 +9203,7 @@ begin Add('var'); Add(' b: boolean;'); Add(' vP, vQ: tfuncint;'); + Add(' '); Add('begin'); Add(' vp:=nil;'); Add(' vp:=vp;'); @@ -9231,6 +9233,55 @@ begin ParseProgram; end; +procedure TTestResolver.TestProcType_ProcedureDelphi; +begin + StartProgram(false); + Add('{$mode Delphi}'); + Add('type'); + Add(' TProc = procedure;'); + Add('procedure Doit;'); + Add('begin end;'); + Add('var'); + Add(' b: boolean;'); + Add(' vP, vQ: tproc;'); + Add('begin'); + Add(' vp:=nil;'); + Add(' vp:=vp;'); + Add(' vp:=vq;'); + Add(' vp:=@doit;'); // ok in fpc and delphi, Note that in Delphi type of @F is Pointer, while in FPC it is the proc type + Add(' vp:=doit;'); // illegal in fpc, ok in delphi + //Add(' vp:=@doit;'); // illegal in fpc, ok in delphi (because Delphi treats @F as Pointer), not supported by resolver + Add(' vp;'); // ok in fpc and delphi + Add(' vp();'); + + // equal + //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi + Add(' b:=@@vp=nil;'); // ok in fpc delphi mode, ok in delphi + //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi + Add(' b:=nil=@@vp;'); // ok in fpc delphi mode, ok in delphi + Add(' b:=@@vp=@@vq;'); // ok in fpc delphi mode, ok in Delphi + //Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results + //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi + Add(' b:=@@vp=@doit;'); // ok in fpc delphi mode, ok in delphi + //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi + Add(' b:=@doit=@@vp;'); // ok in fpc delphi mode, ok in delphi + + // unequal + //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi + Add(' b:=@@vp<>nil;'); // ok in fpc mode delphi, ok in delphi + //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi + Add(' b:=nil<>@@vp;'); // ok in fpc mode delphi, ok in delphi + //Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results + Add(' b:=@@vp<>@@vq;'); // ok in fpc mode delphi, ok in delphi + //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi + Add(' b:=@@vp<>@doit;'); // ok in fpc mode delphi, illegal in delphi + //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi + Add(' b:=@doit<>@@vp;'); // ok in fpc mode delphi, illegal in delphi + + Add(' b:=Assigned(vp);'); + ParseProgram; +end; + procedure TTestResolver.TestProcType_MethodFPC; begin StartProgram(false);