mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-22 11:49:23 +02:00
* Patch from Mattias Gaertner:
pastree: changed TPasVariable.LibraryName and ExportName to TPasExpr.
It can be constants instead of string literals.
pscanner: fixed parsing floats 1.2, 1.2E3, 1.E2, 1E2, 1.2E-3, 1E+2
pparser: var modifier external with optional lib and symbol
pasresolver:
- untyped parameter
- added option proAllowPropertyAsVarParam allows to pass a property as a var/out argument
- varargs
git-svn-id: trunk@35503 -
This commit is contained in:
michael
parent
2fbe76532f
commit
487d7ca141
@ -109,9 +109,11 @@ Works:
|
||||
- function without params: mark if call or address, rrfImplicitCallWithoutParams
|
||||
- procedure break, procedure continue
|
||||
- built-in functions pred, succ for range type and enums
|
||||
- untyped parameters
|
||||
|
||||
ToDo:
|
||||
- fail to write a loop var inside the loop
|
||||
- Note: (5025) Local variable "i" not used
|
||||
- classes - TPasClassType
|
||||
- nested var, const
|
||||
- nested types
|
||||
@ -124,7 +126,6 @@ ToDo:
|
||||
- function default(record type): record
|
||||
- proc: check if forward and impl default values match
|
||||
- call array of proc without ()
|
||||
- untyped parameters
|
||||
- pointer type, ^type, @ operator, [] operator
|
||||
- object
|
||||
- interfaces
|
||||
@ -866,7 +867,8 @@ type
|
||||
|
||||
TPasResolverOption = (
|
||||
proFixCaseOfOverrides, // fix Name of overriding procs to the overriden proc
|
||||
proClassPropertyNonStatic // class property accessor must be non static
|
||||
proClassPropertyNonStatic, // class property accessor must be non static
|
||||
proAllowPropertyAsVarParam // allows to pass a property as a var/out argument
|
||||
);
|
||||
TPasResolverOptions = set of TPasResolverOption;
|
||||
|
||||
@ -1120,7 +1122,7 @@ type
|
||||
procedure ComputeElement(El: TPasElement; out ResolvedEl: TPasResolverResult;
|
||||
Flags: TPasResolverComputeFlags);
|
||||
// checking compatibilility
|
||||
function CheckCallProcCompatibility(Proc: TPasProcedureType;
|
||||
function CheckCallProcCompatibility(ProcType: TPasProcedureType;
|
||||
Params: TParamsExpr; RaiseOnError: boolean): integer;
|
||||
function CheckCallPropertyCompatibility(PropEl: TPasProperty;
|
||||
Params: TParamsExpr; RaiseOnError: boolean): integer;
|
||||
@ -1146,6 +1148,7 @@ type
|
||||
function CheckOverloadProcCompatibility(Proc1, Proc2: TPasProcedure): boolean;
|
||||
function CheckProcAssignCompatibility(Proc1, Proc2: TPasProcedureType): boolean;
|
||||
function CheckProcArgCompatibility(Arg1, Arg2: TPasArgument): boolean;
|
||||
function CheckProcArgTypeCompatibility(Arg1, Arg2: TPasType): boolean;
|
||||
function CheckCanBeLHS(const ResolvedEl: TPasResolverResult;
|
||||
ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean;
|
||||
function CheckAssignCompatibility(const LHS, RHS: TPasElement;
|
||||
@ -1173,6 +1176,7 @@ type
|
||||
function IsDynArray(TypeEl: TPasType): boolean;
|
||||
function IsClassMethod(El: TPasElement): boolean;
|
||||
function IsProcedureType(const ResolvedEl: TPasResolverResult): boolean;
|
||||
function IsArrayType(const ResolvedEl: TPasResolverResult): boolean;
|
||||
function GetRangeLength(RangeResolved: TPasResolverResult): integer;
|
||||
public
|
||||
property BaseType[bt: TResolverBaseType]: TPasUnresolvedSymbolRef read GetBaseType;
|
||||
@ -2953,7 +2957,7 @@ begin
|
||||
|
||||
if Proc.IsForward and Proc.IsExternal then
|
||||
RaiseMsg(20170216151616,nInvalidProcModifiers,
|
||||
sInvalidProcModifiers,[Proc.ElementTypeName,'forward, external'],Proc);
|
||||
sInvalidProcModifiers,[Proc.ElementTypeName,'external, forward'],Proc);
|
||||
|
||||
if Proc.IsDynamic then
|
||||
// 'dynamic' is not supported
|
||||
@ -3697,8 +3701,8 @@ begin
|
||||
// check result type
|
||||
ImplResult:=TPasFunction(ImplProc).FuncType.ResultEl.ResultType;
|
||||
DeclResult:=TPasFunction(DeclProc).FuncType.ResultEl.ResultType;
|
||||
if (ImplResult=nil)
|
||||
or (ImplResult<>DeclResult) then
|
||||
|
||||
if not CheckProcArgTypeCompatibility(ImplResult,DeclResult) then
|
||||
RaiseMsg(20170216151734,nResultTypeMismatchExpectedButFound,
|
||||
sResultTypeMismatchExpectedButFound,[GetTypeDesc(DeclResult),GetTypeDesc(ImplResult)],
|
||||
ImplProc);
|
||||
@ -7275,15 +7279,16 @@ begin
|
||||
CurrentParser.OnLog(Self,Format(Fmt,Args));
|
||||
end;
|
||||
|
||||
function TPasResolver.CheckCallProcCompatibility(Proc: TPasProcedureType;
|
||||
function TPasResolver.CheckCallProcCompatibility(ProcType: TPasProcedureType;
|
||||
Params: TParamsExpr; RaiseOnError: boolean): integer;
|
||||
var
|
||||
ProcArgs: TFPList;
|
||||
i, ParamCnt, ParamCompatibility: Integer;
|
||||
Param: TPasExpr;
|
||||
Proc: TPasProcedure;
|
||||
begin
|
||||
Result:=cExact;
|
||||
ProcArgs:=Proc.Args;
|
||||
ProcArgs:=ProcType.Args;
|
||||
// check args
|
||||
ParamCnt:=length(Params.Params);
|
||||
i:=0;
|
||||
@ -7292,10 +7297,16 @@ begin
|
||||
Param:=Params.Params[i];
|
||||
if i>=ProcArgs.Count then
|
||||
begin
|
||||
if ProcType.Parent is TPasProcedure then
|
||||
begin
|
||||
Proc:=TPasProcedure(ProcType.Parent);
|
||||
if pmVarargs in Proc.Modifiers then
|
||||
exit;
|
||||
end;
|
||||
// too many arguments
|
||||
if RaiseOnError then
|
||||
RaiseMsg(20170216152408,nWrongNumberOfParametersForCallTo,
|
||||
sWrongNumberOfParametersForCallTo,[GetProcDesc(Proc)],Param);
|
||||
sWrongNumberOfParametersForCallTo,[GetProcDesc(ProcType)],Param);
|
||||
exit(cIncompatible);
|
||||
end;
|
||||
{$IFDEF VerbosePasResolver}
|
||||
@ -7313,7 +7324,7 @@ begin
|
||||
if RaiseOnError then
|
||||
// ToDo: position cursor on identifier
|
||||
RaiseMsg(20170216152410,nWrongNumberOfParametersForCallTo,
|
||||
sWrongNumberOfParametersForCallTo,[GetProcDesc(Proc)],Params.Value);
|
||||
sWrongNumberOfParametersForCallTo,[GetProcDesc(ProcType)],Params.Value);
|
||||
exit(cIncompatible);
|
||||
end;
|
||||
end;
|
||||
@ -7444,6 +7455,8 @@ end;
|
||||
|
||||
function TPasResolver.CheckOverloadProcCompatibility(Proc1, Proc2: TPasProcedure
|
||||
): boolean;
|
||||
// returns if number and type of arguments fit
|
||||
// does not check calling convention
|
||||
var
|
||||
ProcArgs1, ProcArgs2: TFPList;
|
||||
i: Integer;
|
||||
@ -7504,8 +7517,6 @@ begin
|
||||
end;
|
||||
|
||||
function TPasResolver.CheckProcArgCompatibility(Arg1, Arg2: TPasArgument): boolean;
|
||||
var
|
||||
Arg1Resolved, Arg2Resolved: TPasResolverResult;
|
||||
begin
|
||||
Result:=false;
|
||||
|
||||
@ -7517,15 +7528,28 @@ begin
|
||||
exit(Arg2.ArgType=nil);
|
||||
if Arg2.ArgType=nil then exit;
|
||||
|
||||
ComputeElement(Arg1,Arg1Resolved,[]);
|
||||
ComputeElement(Arg2,Arg2Resolved,[]);
|
||||
Result:=CheckProcArgTypeCompatibility(Arg1.ArgType,Arg2.ArgType);
|
||||
end;
|
||||
|
||||
function TPasResolver.CheckProcArgTypeCompatibility(Arg1, Arg2: TPasType
|
||||
): boolean;
|
||||
var
|
||||
Arg1Resolved, Arg2Resolved: TPasResolverResult;
|
||||
begin
|
||||
ComputeElement(Arg1,Arg1Resolved,[rcType]);
|
||||
ComputeElement(Arg2,Arg2Resolved,[rcType]);
|
||||
|
||||
if (Arg1Resolved.BaseType<>Arg2Resolved.BaseType)
|
||||
or (Arg1Resolved.TypeEl=nil)
|
||||
or (Arg1Resolved.TypeEl<>Arg2Resolved.TypeEl) then
|
||||
exit;
|
||||
or (Arg2Resolved.TypeEl=nil) then
|
||||
exit(false);
|
||||
if Arg1Resolved.TypeEl=Arg2Resolved.TypeEl then
|
||||
exit(true);
|
||||
if (Arg1Resolved.TypeEl.ClassType=TPasUnresolvedSymbolRef)
|
||||
and (IsBaseType(Arg2Resolved.TypeEl,Arg1Resolved.BaseType)) then
|
||||
exit(true);
|
||||
|
||||
Result:=true;
|
||||
Result:=false;
|
||||
end;
|
||||
|
||||
function TPasResolver.CheckCanBeLHS(const ResolvedEl: TPasResolverResult;
|
||||
@ -7591,7 +7615,11 @@ begin
|
||||
{$ENDIF}
|
||||
if LHS.TypeEl=nil then
|
||||
begin
|
||||
// ToDo: untyped parameter
|
||||
if LHS.BaseType=btUntyped then
|
||||
begin
|
||||
// untyped parameter
|
||||
exit(cExact+1);
|
||||
end;
|
||||
RaiseNotYetImplemented(20160922163631,LHS.IdentEl);
|
||||
end
|
||||
else if LHS.BaseType=RHS.BaseType then
|
||||
@ -7631,18 +7659,18 @@ begin
|
||||
end
|
||||
else if RHS.BaseType=btNil then
|
||||
begin
|
||||
if LHS.BaseType=btPointer then
|
||||
exit(cExact)
|
||||
else if LHS.BaseType=btContext then
|
||||
begin
|
||||
TypeEl:=LHS.TypeEl;
|
||||
if (TypeEl.ClassType=TPasClassType)
|
||||
or (TypeEl.ClassType=TPasClassOfType)
|
||||
or (TypeEl.ClassType=TPasPointerType)
|
||||
or (TypeEl is TPasProcedureType)
|
||||
or IsDynArray(TypeEl) then
|
||||
exit(cExact);
|
||||
end;
|
||||
if LHS.BaseType=btPointer then
|
||||
exit(cExact)
|
||||
else if LHS.BaseType=btContext then
|
||||
begin
|
||||
TypeEl:=LHS.TypeEl;
|
||||
if (TypeEl.ClassType=TPasClassType)
|
||||
or (TypeEl.ClassType=TPasClassOfType)
|
||||
or (TypeEl.ClassType=TPasPointerType)
|
||||
or (TypeEl is TPasProcedureType)
|
||||
or IsDynArray(TypeEl) then
|
||||
exit(cExact);
|
||||
end;
|
||||
end
|
||||
else if RHS.BaseType=btSet then
|
||||
begin
|
||||
@ -7685,15 +7713,27 @@ begin
|
||||
Actual:=GetResolverResultDescription(RHS);
|
||||
if LHS.BaseType<>RHS.BaseType then
|
||||
begin
|
||||
if (LHS.BaseType=btContext) and (LHS.TypeEl<>nil) and (LHS.TypeEl.Name<>'') then
|
||||
Expected:=LHS.TypeEl.Name
|
||||
else
|
||||
Expected:=BaseTypeNames[LHS.BaseType];
|
||||
if (RHS.BaseType=btContext)
|
||||
and (RHS.TypeEl<>nil) then
|
||||
Actual:=RHS.TypeEl.ElementTypeName
|
||||
else
|
||||
Actual:=BaseTypeNames[RHS.BaseType];
|
||||
Expected:=BaseTypeNames[LHS.BaseType];
|
||||
if (LHS.BaseType=btContext) then
|
||||
begin
|
||||
if (LHS.TypeEl<>nil) then
|
||||
begin
|
||||
if (LHS.TypeEl.Name<>'') then
|
||||
Expected:=LHS.TypeEl.Name
|
||||
else
|
||||
Expected:=LHS.TypeEl.ElementTypeName;
|
||||
end;
|
||||
end;
|
||||
if (RHS.BaseType=btContext) then
|
||||
begin
|
||||
if (RHS.TypeEl<>nil) then
|
||||
begin
|
||||
if (RHS.TypeEl.Name<>'') then
|
||||
Actual:=RHS.TypeEl.Name
|
||||
else
|
||||
Actual:=RHS.TypeEl.ElementTypeName;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else if (LHS.TypeEl<>nil) and (RHS.TypeEl<>nil) then
|
||||
begin
|
||||
@ -7875,6 +7915,9 @@ begin
|
||||
Result:=(TPasConst(ResolvedEl.IdentEl).VarType<>nil);
|
||||
exit;
|
||||
end;
|
||||
if (proAllowPropertyAsVarParam in Options)
|
||||
and (ResolvedEl.IdentEl.ClassType=TPasProperty) then
|
||||
exit(true);
|
||||
end;
|
||||
|
||||
function TPasResolver.ResolvedElIsClassInstance(
|
||||
@ -7992,6 +8035,8 @@ begin
|
||||
if (ParamResolved.TypeEl<>nil) and (ParamResolved.TypeEl=ExprResolved.TypeEl) then
|
||||
exit(cExact);
|
||||
end;
|
||||
if (Param.ArgType=nil) then
|
||||
exit(cExact); // untyped argument
|
||||
if RaiseOnError then
|
||||
RaiseMsg(20170216152452,nIncompatibleTypeArgNoVarParamMustMatchExactly,
|
||||
sIncompatibleTypeArgNoVarParamMustMatchExactly,
|
||||
@ -8374,7 +8419,12 @@ begin
|
||||
if (ResTypeEl<>nil)
|
||||
and (rrfReadable in ParamResolved.Flags) then
|
||||
begin
|
||||
if ResTypeEl.ClassType=TPasUnresolvedSymbolRef then
|
||||
if ParamResolved.BaseType=btUntyped then
|
||||
begin
|
||||
// typecast an untyped parameter
|
||||
Result:=cExact+1;
|
||||
end
|
||||
else if ResTypeEl.ClassType=TPasUnresolvedSymbolRef then
|
||||
begin
|
||||
if ResTypeEl.CustomData.ClassType=TResElDataBaseType then
|
||||
begin
|
||||
@ -8955,6 +9005,12 @@ begin
|
||||
Result:=(ResolvedEl.BaseType=btContext) and (ResolvedEl.TypeEl is TPasProcedureType);
|
||||
end;
|
||||
|
||||
function TPasResolver.IsArrayType(const ResolvedEl: TPasResolverResult
|
||||
): boolean;
|
||||
begin
|
||||
Result:=(ResolvedEl.BaseType=btContext) and (ResolvedEl.TypeEl is TPasArrayType);
|
||||
end;
|
||||
|
||||
function TPasResolver.GetRangeLength(RangeResolved: TPasResolverResult
|
||||
): integer;
|
||||
begin
|
||||
|
||||
@ -74,6 +74,7 @@ end;
|
||||
|
||||
function TSrcContainer.FindElement(const AName: String): TPasElement;
|
||||
begin
|
||||
if AName='' then ;
|
||||
Result:=Nil;
|
||||
end;
|
||||
|
||||
|
||||
@ -632,7 +632,7 @@ type
|
||||
const Arg: Pointer); override;
|
||||
public
|
||||
Access: TArgumentAccess;
|
||||
ArgType: TPasType;
|
||||
ArgType: TPasType; // can be nil, when Access<>argDefault
|
||||
ValueExpr: TPasExpr; // the default value
|
||||
Function Value : String;
|
||||
end;
|
||||
@ -733,7 +733,8 @@ type
|
||||
public
|
||||
VarType: TPasType;
|
||||
VarModifiers : TVariableModifiers;
|
||||
LibraryName,ExportName : string;
|
||||
LibraryName : TPasExpr; // libname of modifier external
|
||||
ExportName : TPasExpr; // symbol name of modifier external, export and public
|
||||
Modifiers : string;
|
||||
AbsoluteLocation : String;
|
||||
Expr: TPasExpr;
|
||||
@ -820,7 +821,7 @@ type
|
||||
TProcedureModifier = (pmVirtual, pmDynamic, pmAbstract, pmOverride,
|
||||
pmExport, pmOverload, pmMessage, pmReintroduce,
|
||||
pmStatic,pmInline,pmAssembler,pmVarargs, pmPublic,
|
||||
pmCompilerProc,pmExternal,pmForward, pmdispid, pmnoreturn);
|
||||
pmCompilerProc,pmExternal,pmForward, pmDispId, pmNoReturn);
|
||||
TProcedureModifiers = Set of TProcedureModifier;
|
||||
TProcedureMessageType = (pmtNone,pmtInteger,pmtString);
|
||||
|
||||
@ -2474,6 +2475,8 @@ begin
|
||||
(e.g. in Constants) }
|
||||
ReleaseAndNil(TPasElement(VarType));
|
||||
ReleaseAndNil(TPasElement(Expr));
|
||||
ReleaseAndNil(TPasElement(LibraryName));
|
||||
ReleaseAndNil(TPasElement(ExportName));
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
||||
@ -239,7 +239,7 @@ type
|
||||
function CheckOverloadList(AList: TFPList; AName: String; out OldMember: TPasElement): TPasOverloadedProc;
|
||||
procedure DumpCurToken(Const Msg : String; IndentAction : TIndentAction = iaNone);
|
||||
function GetCurrentModeSwitches: TModeSwitches;
|
||||
function GetVariableModifiers(Out VarMods : TVariableModifiers; Out Libname,ExportName : string): string;
|
||||
function GetVariableModifiers(Parent: TPasElement; Out VarMods: TVariableModifiers; Out LibName, ExportName: TPasExpr): string;
|
||||
function GetVariableValueAndLocation(Parent : TPasElement; Out Value : TPasExpr; Out Location: String): Boolean;
|
||||
procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
|
||||
procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility);
|
||||
@ -886,7 +886,7 @@ end;
|
||||
|
||||
function TPasParser.CurTokenIsIdentifier(const S: String): Boolean;
|
||||
begin
|
||||
Result:=(Curtoken=tkidentifier) and (CompareText(S,CurtokenText)=0);
|
||||
Result:=(Curtoken=tkIdentifier) and (CompareText(S,CurtokenText)=0);
|
||||
end;
|
||||
|
||||
|
||||
@ -2976,13 +2976,16 @@ begin
|
||||
UngetToken;
|
||||
end;
|
||||
|
||||
function TPasParser.GetVariableModifiers(out VarMods: TVariableModifiers; out
|
||||
Libname, ExportName: string): string;
|
||||
function TPasParser.GetVariableModifiers(Parent: TPasElement; out
|
||||
VarMods: TVariableModifiers; out LibName, ExportName: TPasExpr): string;
|
||||
|
||||
Var
|
||||
S : String;
|
||||
ExtMod: TVariableModifier;
|
||||
begin
|
||||
Result := '';
|
||||
LibName := nil;
|
||||
ExportName := nil;
|
||||
VarMods := [];
|
||||
NextToken;
|
||||
If CurTokenIsIdentifier('cvar') then
|
||||
@ -2993,46 +2996,47 @@ begin
|
||||
NextToken;
|
||||
end;
|
||||
s:=LowerCase(CurTokenText);
|
||||
if Not ((s='external') or (s='public') or (s='export')) then
|
||||
UngetToken
|
||||
if s='external' then
|
||||
ExtMod:=vmExternal
|
||||
else if (s='public') then
|
||||
ExtMod:=vmPublic
|
||||
else if (s='export') then
|
||||
ExtMod:=vmExport
|
||||
else
|
||||
begin
|
||||
if s='external' then
|
||||
Include(VarMods,vmexternal)
|
||||
else if (s='public') then
|
||||
Include(varMods,vmpublic)
|
||||
else if (s='export') then
|
||||
Include(varMods,vmexport);
|
||||
Result:=Result+';'+CurTokenText;
|
||||
NextToken;
|
||||
if (Curtoken<>tksemicolon) then
|
||||
begin
|
||||
if (s='external') then
|
||||
begin
|
||||
Include(VarMods,vmexternal);
|
||||
if (CurToken in [tkString,tkIdentifier])
|
||||
and Not (CurTokenIsIdentifier('name')) then
|
||||
begin
|
||||
Result := Result + ' ' + CurTokenText;
|
||||
LibName:=CurTokenText;
|
||||
NextToken;
|
||||
end;
|
||||
end;
|
||||
if CurTokenIsIdentifier('name') then
|
||||
begin
|
||||
Result := Result + ' name ';
|
||||
NextToken;
|
||||
if (CurToken in [tkString,tkIdentifier]) then
|
||||
Result := Result + CurTokenText
|
||||
else
|
||||
ParseExcSyntaxError;
|
||||
ExportName:=CurTokenText;
|
||||
NextToken;
|
||||
end
|
||||
else
|
||||
ParseExcSyntaxError;
|
||||
end;
|
||||
UngetToken;
|
||||
exit;
|
||||
end;
|
||||
Include(varMods,ExtMod);
|
||||
Result:=Result+';'+CurTokenText;
|
||||
|
||||
NextToken;
|
||||
if not (CurToken in [tkString,tkIdentifier]) then
|
||||
begin
|
||||
if (CurToken=tkSemicolon) and (ExtMod in [vmExternal,vmPublic]) then
|
||||
exit;
|
||||
ParseExcSyntaxError;
|
||||
end;
|
||||
// export name exportname;
|
||||
// public;
|
||||
// public name exportname;
|
||||
// external;
|
||||
// external libname;
|
||||
// external libname name exportname;
|
||||
// external name exportname;
|
||||
if (ExtMod=vmExternal) and (CurToken in [tkString,tkIdentifier])
|
||||
and Not (CurTokenIsIdentifier('name')) then
|
||||
begin
|
||||
Result := Result + ' ' + CurTokenText;
|
||||
LibName:=DoParseExpression(Parent);
|
||||
end;
|
||||
if not CurTokenIsIdentifier('name') then
|
||||
ParseExcSyntaxError;
|
||||
NextToken;
|
||||
if not (CurToken in [tkString,tkIdentifier]) then
|
||||
ParseExcTokenError(TokenInfos[tkString]);
|
||||
Result := Result + ' ' + CurTokenText;
|
||||
ExportName:=DoParseExpression(Parent);
|
||||
end;
|
||||
|
||||
|
||||
@ -3042,15 +3046,18 @@ procedure TPasParser.ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibi
|
||||
|
||||
var
|
||||
i, OldListCount: Integer;
|
||||
Value : TPasExpr;
|
||||
Value , aLibName, aExpName: TPasExpr;
|
||||
VarType: TPasType;
|
||||
VarEl: TPasVariable;
|
||||
H : TPasMemberHints;
|
||||
VarMods: TVariableModifiers;
|
||||
D,Mods,Loc,aLibName,aExpName : string;
|
||||
D,Mods,Loc: string;
|
||||
OldForceCaret,ok: Boolean;
|
||||
|
||||
begin
|
||||
Value:=Nil;
|
||||
aLibName:=nil;
|
||||
aExpName:=nil;
|
||||
OldListCount:=VarList.Count;
|
||||
ok:=false;
|
||||
try
|
||||
@ -3083,20 +3090,17 @@ begin
|
||||
VarType.AddRef;
|
||||
end;
|
||||
|
||||
Value:=Nil;
|
||||
H:=CheckHint(Nil,False);
|
||||
If Full then
|
||||
GetVariableValueAndLocation(Parent,Value,Loc);
|
||||
if (Value<>nil) and (VarList.Count>OldListCount+1) then
|
||||
begin
|
||||
Value.Release;
|
||||
ParseExc(nParserOnlyOneVariableCanBeInitialized,SParserOnlyOneVariableCanBeInitialized);
|
||||
end;
|
||||
TPasVariable(VarList[OldListCount]).Expr:=Value;
|
||||
Value:=nil;
|
||||
|
||||
H:=H+CheckHint(Nil,Full);
|
||||
if Full then
|
||||
Mods:=GetVariableModifiers(VarMods,aLibName,aExpName)
|
||||
Mods:=GetVariableModifiers(Parent,VarMods,aLibName,aExpName)
|
||||
else
|
||||
begin
|
||||
NextToken;
|
||||
@ -3117,15 +3121,26 @@ begin
|
||||
VarEl.Modifiers:=Mods;
|
||||
VarEl.VarModifiers:=VarMods;
|
||||
VarEl.AbsoluteLocation:=Loc;
|
||||
VarEl.LibraryName:=aLibName;
|
||||
VarEl.ExportName:=aExpName;
|
||||
if aLibName<>nil then
|
||||
begin
|
||||
VarEl.LibraryName:=aLibName;
|
||||
aLibName.AddRef;
|
||||
end;
|
||||
if aExpName<>nil then
|
||||
begin
|
||||
VarEl.ExportName:=aExpName;
|
||||
aExpName.AddRef;
|
||||
end;
|
||||
end;
|
||||
for i := OldListCount to VarList.Count - 1 do
|
||||
Engine.FinishScope(stDeclaration,TPasVariable(VarList[i]));
|
||||
ok:=true;
|
||||
finally
|
||||
if aLibName<>nil then aLibName.Release;
|
||||
if aExpName<>nil then aExpName.Release;
|
||||
if not ok then
|
||||
begin
|
||||
if Value<>nil then Value.Release;
|
||||
for i:=OldListCount to VarList.Count-1 do
|
||||
TPasElement(VarList[i]).Release;
|
||||
VarList.Count:=OldListCount;
|
||||
|
||||
@ -2074,35 +2074,25 @@ begin
|
||||
end;
|
||||
'0'..'9':
|
||||
begin
|
||||
// 1, 12, 1.2, 1.2E3, 1.E2, 1E2, 1.2E-3, 1E+2
|
||||
// beware of 1..2
|
||||
TokenStart := TokenStr;
|
||||
while true do
|
||||
repeat
|
||||
Inc(TokenStr);
|
||||
until not (TokenStr[0] in ['0'..'9']);
|
||||
if (TokenStr[0]='.') and (TokenStr[1]<>'.') then
|
||||
begin
|
||||
inc(TokenStr);
|
||||
while TokenStr[0] in ['0'..'9'] do
|
||||
Inc(TokenStr);
|
||||
end;
|
||||
if TokenStr[0] in ['e', 'E'] then
|
||||
begin
|
||||
Inc(TokenStr);
|
||||
case TokenStr[0] of
|
||||
'.':
|
||||
begin
|
||||
if TokenStr[1] in ['0'..'9', 'e', 'E'] then
|
||||
begin
|
||||
Inc(TokenStr);
|
||||
repeat
|
||||
Inc(TokenStr);
|
||||
until not (TokenStr[0] in ['0'..'9', 'e', 'E']);
|
||||
end;
|
||||
break;
|
||||
end;
|
||||
'0'..'9': ;
|
||||
'e', 'E':
|
||||
begin
|
||||
Inc(TokenStr);
|
||||
if TokenStr[0] = '-' then
|
||||
Inc(TokenStr);
|
||||
while TokenStr[0] in ['0'..'9'] do
|
||||
Inc(TokenStr);
|
||||
break;
|
||||
end;
|
||||
else
|
||||
break;
|
||||
end;
|
||||
if TokenStr[0] in ['-','+'] then
|
||||
inc(TokenStr);
|
||||
while TokenStr[0] in ['0'..'9'] do
|
||||
Inc(TokenStr);
|
||||
end;
|
||||
SectionLength := TokenStr - TokenStart;
|
||||
SetLength(FCurTokenString, SectionLength);
|
||||
|
||||
@ -45,6 +45,16 @@ type
|
||||
procedure TestPrimitiveIntegerOctal;
|
||||
procedure TestPrimitiveIntegerBinary;
|
||||
procedure TestPrimitiveDouble;
|
||||
procedure TestPrimitiveDouble2;
|
||||
procedure TestPrimitiveDouble3;
|
||||
procedure TestPrimitiveDouble4;
|
||||
procedure TestPrimitiveDouble5;
|
||||
procedure TestPrimitiveDouble6;
|
||||
procedure TestPrimitiveDouble7;
|
||||
procedure TestPrimitiveDouble8;
|
||||
procedure TestPrimitiveDouble9;
|
||||
procedure TestPrimitiveDouble10;
|
||||
procedure TestPrimitiveDouble11;
|
||||
procedure TestPrimitiveString;
|
||||
procedure TestPrimitiveIdent;
|
||||
procedure TestPrimitiveBooleanFalse;
|
||||
@ -164,6 +174,66 @@ begin
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'1.2');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveDouble2;
|
||||
begin
|
||||
ParseExpression('1.200');
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'1.200');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveDouble3;
|
||||
begin
|
||||
ParseExpression('01.2');
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'01.2');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveDouble4;
|
||||
begin
|
||||
ParseExpression('1.2e10');
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'1.2e10');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveDouble5;
|
||||
begin
|
||||
ParseExpression('1.2e-10');
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'1.2e-10');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveDouble6;
|
||||
begin
|
||||
ParseExpression('12e10');
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'12e10');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveDouble7;
|
||||
begin
|
||||
ParseExpression('12e-10');
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'12e-10');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveDouble8;
|
||||
begin
|
||||
ParseExpression('8.5');
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'8.5');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveDouble9;
|
||||
begin
|
||||
ParseExpression('8.E5');
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'8.E5');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveDouble10;
|
||||
begin
|
||||
ParseExpression('8.E-5');
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'8.E-5');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveDouble11;
|
||||
begin
|
||||
ParseExpression('8E+5');
|
||||
AssertExpression('Simple double',theExpr,pekNumber,'8E+5');
|
||||
end;
|
||||
|
||||
procedure TTestExpressions.TestPrimitiveString;
|
||||
begin
|
||||
DeclareVar('string');
|
||||
|
||||
@ -150,6 +150,7 @@ type
|
||||
Procedure TestArgWrongExprFail;
|
||||
Procedure TestIncDec;
|
||||
Procedure TestIncStringFail;
|
||||
Procedure TestVarExternal;
|
||||
|
||||
// strings
|
||||
Procedure TestString_SetLength;
|
||||
@ -249,6 +250,8 @@ type
|
||||
Procedure TestBreak;
|
||||
Procedure TestContinue;
|
||||
Procedure TestProcedureExternal;
|
||||
Procedure TestProc_UntypedParam_Forward;
|
||||
Procedure TestProc_Varargs;
|
||||
// ToDo: fail builtin functions in constant with non const param
|
||||
|
||||
// record
|
||||
@ -275,6 +278,8 @@ type
|
||||
Procedure TestClass_MethodOverride;
|
||||
Procedure TestClass_MethodOverride2;
|
||||
Procedure TestClass_MethodOverrideFixCase;
|
||||
Procedure TestClass_MethodOverrideSameResultType;
|
||||
Procedure TestClass_MethodOverrideDiffResultTypeFail;
|
||||
Procedure TestClass_MethodOverloadAncestor;
|
||||
Procedure TestClass_MethodScope;
|
||||
Procedure TestClass_IdentifierSelf;
|
||||
@ -315,6 +320,7 @@ type
|
||||
Procedure TestClass_ReintroducePublicVarFail;
|
||||
Procedure TestClass_ReintroducePrivateVar;
|
||||
Procedure TestClass_ReintroduceProc;
|
||||
Procedure TestClass_UntypedParam_TypeCast;
|
||||
// Todo: Fail to use class.method in constant or type, e.g. const p = @o.doit;
|
||||
// ToDo: typecast multiple params fail
|
||||
// ToDo: use Self in non method as local var, requires changes in pparser
|
||||
@ -392,6 +398,9 @@ type
|
||||
Procedure TestArrayEnumTypeConstWrongTypeFail;
|
||||
Procedure TestArrayEnumTypeConstNonConstFail;
|
||||
Procedure TestArrayEnumTypeSetLengthFail;
|
||||
Procedure TestArray_AssignNilToStaticArrayFail1;
|
||||
Procedure TestArray_SetLengthProperty;
|
||||
Procedure TestArray_PassArrayElementToVarParam;
|
||||
|
||||
// procedure types
|
||||
Procedure TestProcTypesAssignObjFPC;
|
||||
@ -1627,6 +1636,15 @@ begin
|
||||
CheckResolverException('Incompatible type arg no. 1: Got "String", expected "Longint"',PasResolver.nIncompatibleTypeArgNo);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestVarExternal;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('var');
|
||||
Add(' NaN: double; external name ''Global.Nan'';');
|
||||
Add('begin');
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestString_SetLength;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -3257,6 +3275,59 @@ begin
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestProc_UntypedParam_Forward;
|
||||
begin
|
||||
StartProgram(false);
|
||||
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 ProcA(var A);');
|
||||
Add('begin');
|
||||
Add('end;');
|
||||
Add('procedure ProcB(const B);');
|
||||
Add('begin');
|
||||
Add('end;');
|
||||
Add('procedure ProcC(out C);');
|
||||
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);');
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestProc_Varargs;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('procedure ProcA(i:longint); varargs; external;');
|
||||
Add('procedure ProcB; varargs; external;');
|
||||
Add('procedure ProcC(i: longint = 17); varargs; external;');
|
||||
Add('begin');
|
||||
Add(' ProcA(1);');
|
||||
Add(' ProcA(1,2);');
|
||||
Add(' ProcA(1,2.0);');
|
||||
Add(' ProcA(1,2,3);');
|
||||
Add(' ProcA(1,''2'');');
|
||||
Add(' ProcA(2,'''');');
|
||||
Add(' ProcA(3,false);');
|
||||
Add(' ProcB;');
|
||||
Add(' ProcB();');
|
||||
Add(' ProcB(4);');
|
||||
Add(' ProcB(''foo'');');
|
||||
Add(' ProcC;');
|
||||
Add(' ProcC();');
|
||||
Add(' ProcC(4);');
|
||||
Add(' ProcC(5,''foo'');');
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestRecord;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -3672,6 +3743,50 @@ begin
|
||||
CheckOverrideName('B_ProcA');
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestClass_MethodOverrideSameResultType;
|
||||
begin
|
||||
AddModuleWithIntfImplSrc('unit2.pp',
|
||||
LinesToStr([
|
||||
'type',
|
||||
' TObject = class',
|
||||
' public',
|
||||
' function ProcA(const s: string): string; virtual; abstract;',
|
||||
' end;',
|
||||
'']),
|
||||
LinesToStr([
|
||||
''])
|
||||
);
|
||||
|
||||
StartProgram(true);
|
||||
Add('uses unit2;');
|
||||
Add('type');
|
||||
Add(' TCar = class');
|
||||
Add(' public');
|
||||
Add(' function ProcA(const s: string): string; override;');
|
||||
Add(' end;');
|
||||
Add('function TCar.ProcA(const s: string): string; begin end;');
|
||||
Add('begin');
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestClass_MethodOverrideDiffResultTypeFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('type');
|
||||
Add(' TObject = class');
|
||||
Add(' public');
|
||||
Add(' function ProcA(const s: string): string; virtual; abstract;');
|
||||
Add(' end;');
|
||||
Add(' TCar = class');
|
||||
Add(' public');
|
||||
Add(' function ProcA(const s: string): longint; override;');
|
||||
Add(' end;');
|
||||
Add('function TCar.ProcA(const s: string): longint; begin end;');
|
||||
Add('begin');
|
||||
CheckResolverException('Result type mismatch, expected String, but found Longint',
|
||||
nResultTypeMismatchExpectedButFound);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestClass_MethodOverloadAncestor;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -4729,6 +4844,29 @@ begin
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestClass_UntypedParam_TypeCast;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('type');
|
||||
Add(' TObject = class end;');
|
||||
Add('procedure {#ProcA}ProcA(var {#A}A);');
|
||||
Add('begin');
|
||||
Add(' TObject({@A}A):=TObject({@A}A);');
|
||||
Add(' if TObject({@A}A)=nil then ;');
|
||||
Add(' if nil=TObject({@A}A) then ;');
|
||||
Add('end;');
|
||||
Add('procedure {#ProcB}ProcB(const {#B}B);');
|
||||
Add('begin');
|
||||
Add(' if TObject({@B}B)=nil then ;');
|
||||
Add(' if nil=TObject({@B}B) then ;');
|
||||
Add('end;');
|
||||
Add('var o: TObject;');
|
||||
Add('begin');
|
||||
Add(' {@ProcA}ProcA(o);');
|
||||
Add(' {@ProcB}ProcB(o);');
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestClassOf;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -6040,10 +6178,54 @@ begin
|
||||
Add(' a: array[TEnum] of longint;');
|
||||
Add('begin');
|
||||
Add(' SetLength(a,1);');
|
||||
CheckResolverException(' Incompatible type arg no. 1: Got "array[] of Longint", expected "string or dynamic array variable',
|
||||
CheckResolverException('Incompatible type arg no. 1: Got "array[] of Longint", expected "string or dynamic array variable',
|
||||
nIncompatibleTypeArgNo);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestArray_AssignNilToStaticArrayFail1;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('type');
|
||||
Add(' TEnum = (red,blue);');
|
||||
Add('var');
|
||||
Add(' a: array[TEnum] of longint;');
|
||||
Add('begin');
|
||||
Add(' a:=nil;');
|
||||
CheckResolverException('Incompatible types: got "nil" expected "array type"',
|
||||
nIncompatibleTypesGotExpected);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestArray_SetLengthProperty;
|
||||
begin
|
||||
ResolverEngine.Options:=ResolverEngine.Options+[proAllowPropertyAsVarParam];
|
||||
StartProgram(false);
|
||||
Add('type');
|
||||
Add(' TArrInt = array of longint;');
|
||||
Add(' TObject = class');
|
||||
Add(' function GetColors: TArrInt; external name ''GetColors'';');
|
||||
Add(' procedure SetColors(const Value: TArrInt); external name ''SetColors'';');
|
||||
Add(' property Colors: TArrInt read GetColors write SetColors;');
|
||||
Add(' end;');
|
||||
Add('procedure DoIt(var i: longint; out j: longint; const k: longint); begin end;');
|
||||
Add('var Obj: TObject;');
|
||||
Add('begin');
|
||||
Add(' SetLength(Obj.Colors,2);');
|
||||
Add(' DoIt(Obj.Colors[1],Obj.Colors[2],Obj.Colors[3]);');
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestArray_PassArrayElementToVarParam;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('type');
|
||||
Add(' TArrInt = array of longint;');
|
||||
Add('procedure DoIt(var i: longint; out j: longint; const k: longint); begin end;');
|
||||
Add('var a: TArrInt;');
|
||||
Add('begin');
|
||||
Add(' DoIt(a[1],a[2],a[3]);');
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestProcTypesAssignObjFPC;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
||||
@ -273,16 +273,16 @@ procedure TTestVarParser.TestVarExternalLib;
|
||||
begin
|
||||
ParseVar('integer; external name ''mylib''','');
|
||||
AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
|
||||
AssertEquals('Library name','',TheVar.LibraryName);
|
||||
AssertEquals('Library name','''mylib''',TheVar.ExportName);
|
||||
AssertNull('Library name',TheVar.LibraryName);
|
||||
AssertNotNull('Library symbol',TheVar.ExportName);
|
||||
end;
|
||||
|
||||
procedure TTestVarParser.TestVarExternalLibName;
|
||||
begin
|
||||
ParseVar('integer; external ''mylib'' name ''de''','');
|
||||
AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
|
||||
AssertEquals('Library name','''mylib''',TheVar.LibraryName);
|
||||
AssertEquals('Library name','''de''',TheVar.ExportName);
|
||||
AssertNotNull('Library name',TheVar.LibraryName);
|
||||
AssertNotNull('Library symbol',TheVar.ExportName);
|
||||
end;
|
||||
|
||||
procedure TTestVarParser.TestVarCVar;
|
||||
@ -307,7 +307,7 @@ procedure TTestVarParser.TestVarPublicName;
|
||||
begin
|
||||
ParseVar('integer; public name ''ce''','');
|
||||
AssertEquals('Variable modifiers',[vmpublic],TheVar.VarModifiers);
|
||||
AssertEquals('Public export name','''ce''',TheVar.ExportName);
|
||||
AssertNotNull('Public export name',TheVar.ExportName);
|
||||
end;
|
||||
|
||||
procedure TTestVarParser.TestVarDeprecatedExternalName;
|
||||
@ -315,7 +315,8 @@ begin
|
||||
ParseVar('integer deprecated; external name ''me''','');
|
||||
CheckHint(TPasMemberHint(Getenumvalue(typeinfo(TPasMemberHint),'hdeprecated')));
|
||||
AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
|
||||
AssertEquals('Library name','''me''',TheVar.ExportName);
|
||||
AssertNull('Library name',TheVar.LibraryName);
|
||||
AssertNotNull('Library symbol',TheVar.ExportName);
|
||||
end;
|
||||
|
||||
procedure TTestVarParser.TestVarHintPriorToInit;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user