mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-11 20:29:14 +02:00
resolver: case string of range
git-svn-id: trunk@38887 -
This commit is contained in:
Mattias Gaertner
parent
790e1e6007
commit
c2af7a4d3d
@ -6656,11 +6656,15 @@ type
|
||||
TRangeItem = record
|
||||
RangeStart, RangeEnd: MaxPrecInt;
|
||||
Expr: TPasExpr;
|
||||
aString: UnicodeString;
|
||||
// Note: for case-of-string:
|
||||
// single values are stored in aString and RangeStart=1, RangeEnd=0
|
||||
// ranges are stored as aString='', RangeStart, RangeEnd
|
||||
end;
|
||||
PRangeItem = ^TRangeItem;
|
||||
|
||||
function CreateValues(const ResolvedEl: TPasResolverResult;
|
||||
var ValueSet: TResEvalSet; var ValueStrings: TStringList): boolean;
|
||||
var ValueSet: TResEvalSet): boolean;
|
||||
var
|
||||
CaseExprType: TPasType;
|
||||
begin
|
||||
@ -6681,10 +6685,7 @@ type
|
||||
Result:=true;
|
||||
end
|
||||
else if ResolvedEl.BaseType in btAllStrings then
|
||||
begin
|
||||
ValueStrings:=TStringList.Create;
|
||||
Result:=true;
|
||||
end
|
||||
Result:=true
|
||||
else if ResolvedEl.BaseType=btContext then
|
||||
begin
|
||||
CaseExprType:=ResolvedEl.LoTypeEl;
|
||||
@ -6721,27 +6722,74 @@ type
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function AddRangeItem(Values: TFPList; const RangeStart, RangeEnd: MaxPrecInt;
|
||||
Expr: TPasExpr): PRangeItem;
|
||||
begin
|
||||
New(Result);
|
||||
Result^.RangeStart:=RangeStart;
|
||||
Result^.RangeEnd:=RangeEnd;
|
||||
Result^.Expr:=Expr;
|
||||
Values.Add(Result);
|
||||
end;
|
||||
|
||||
function AddValue(Value: TResEvalValue; Values: TFPList; ValueSet: TResEvalSet;
|
||||
ValueStrings: TStrings; Expr: TPasExpr): boolean;
|
||||
Expr: TPasExpr): boolean;
|
||||
|
||||
procedure AddString(const s: string);
|
||||
function AddString(const s: UnicodeString): boolean;
|
||||
var
|
||||
Dupl: TPasExpr;
|
||||
i: Integer;
|
||||
i, o: Integer;
|
||||
Item: PRangeItem;
|
||||
begin
|
||||
if ValueStrings=nil then
|
||||
RaiseNotYetImplemented(20180424215755,Expr,Value.AsDebugString);
|
||||
for i:=0 to ValueStrings.Count-1 do
|
||||
if ValueStrings[i]=s then
|
||||
if length(s)=1 then
|
||||
o:=ord(s[1])
|
||||
else
|
||||
o:=-1;
|
||||
for i:=0 to Values.Count-1 do
|
||||
begin
|
||||
Item:=PRangeItem(Values[i]);
|
||||
if (Item^.aString=s)
|
||||
or ((o>=Item^.RangeStart) and (o<=Item^.RangeEnd)) then
|
||||
begin
|
||||
Dupl:=TPasExpr(ValueStrings.Objects[i]);
|
||||
Dupl:=PRangeItem(Values[i])^.Expr;
|
||||
RaiseMsg(20180424220139,nDuplicateCaseValueXatY,sDuplicateCaseValueXatY,
|
||||
['string',GetElementSourcePosStr(Dupl)],Expr);
|
||||
end;
|
||||
ValueStrings.AddObject(s,Expr);
|
||||
end;
|
||||
Item:=AddRangeItem(Values,1,0,Expr);
|
||||
Item^.aString:=s;
|
||||
Result:=true;
|
||||
end;
|
||||
|
||||
function AddStringRange(CharStart, CharEnd: MaxPrecInt): boolean;
|
||||
var
|
||||
i, o: Integer;
|
||||
s: UnicodeString;
|
||||
Item: PRangeItem;
|
||||
Dupl: TPasExpr;
|
||||
begin
|
||||
if CharEnd>$ffff then
|
||||
RaiseNotYetImplemented(20180501221359,Expr,Value.AsDebugString);
|
||||
for i:=0 to Values.Count-1 do
|
||||
begin
|
||||
Item:=PRangeItem(Values[i]);
|
||||
s:=Item^.aString;
|
||||
if length(s)=1 then
|
||||
o:=ord(s[1])
|
||||
else
|
||||
o:=-1;
|
||||
if ((o>=CharStart) and (o<=CharEnd))
|
||||
or ((Item^.RangeStart<=CharEnd) and (Item^.RangeEnd>=CharStart)) then
|
||||
begin
|
||||
Dupl:=PRangeItem(Values[i])^.Expr;
|
||||
RaiseMsg(20180501223914,nDuplicateCaseValueXatY,sDuplicateCaseValueXatY,
|
||||
['string',GetElementSourcePosStr(Dupl)],Expr);
|
||||
end;
|
||||
end;
|
||||
AddRangeItem(Values,CharStart,CharEnd,Expr);
|
||||
Result:=true;
|
||||
end;
|
||||
|
||||
var
|
||||
@ -6774,11 +6822,8 @@ type
|
||||
RangeEnd:=RangeStart;
|
||||
end;
|
||||
revkString:
|
||||
if ValueStrings<>nil then
|
||||
begin
|
||||
AddString(TResEvalString(Value).S);
|
||||
exit(true);
|
||||
end
|
||||
if ValueSet=nil then
|
||||
exit(AddString(ExprEvaluator.GetUnicodeStr(TResEvalString(Value).S,Expr)))
|
||||
else
|
||||
begin
|
||||
if length(TResEvalString(Value).S)<>1 then
|
||||
@ -6787,11 +6832,8 @@ type
|
||||
RangeEnd:=RangeStart;
|
||||
end;
|
||||
revkUnicodeString:
|
||||
if ValueStrings<>nil then
|
||||
begin
|
||||
AddString(UTF8Encode(TResEvalUTF16(Value).S));
|
||||
exit(true);
|
||||
end
|
||||
if ValueSet=nil then
|
||||
exit(AddString(TResEvalUTF16(Value).S))
|
||||
else
|
||||
begin
|
||||
if length(TResEvalUTF16(Value).S)<>1 then
|
||||
@ -6805,10 +6847,13 @@ type
|
||||
RangeEnd:=RangeStart;
|
||||
end;
|
||||
revkRangeInt:
|
||||
begin
|
||||
RangeStart:=TResEvalRangeInt(Value).RangeStart;
|
||||
RangeEnd:=TResEvalRangeInt(Value).RangeEnd;
|
||||
end;
|
||||
if ValueSet=nil then
|
||||
exit(AddStringRange(TResEvalRangeInt(Value).RangeStart,TResEvalRangeInt(Value).RangeEnd))
|
||||
else
|
||||
begin
|
||||
RangeStart:=TResEvalRangeInt(Value).RangeStart;
|
||||
RangeEnd:=TResEvalRangeInt(Value).RangeEnd;
|
||||
end;
|
||||
revkRangeUInt:
|
||||
begin
|
||||
// Note: when FPC compares int64 with qword it converts the qword to an int64
|
||||
@ -6828,11 +6873,7 @@ type
|
||||
if i<0 then
|
||||
begin
|
||||
ValueSet.Add(RangeStart,RangeEnd);
|
||||
New(Item);
|
||||
Item^.RangeStart:=RangeStart;
|
||||
Item^.RangeEnd:=RangeEnd;
|
||||
Item^.Expr:=Expr;
|
||||
Values.Add(Item);
|
||||
AddRangeItem(Values,RangeStart,RangeEnd,Expr);
|
||||
exit(true);
|
||||
end;
|
||||
// duplicate value -> show where
|
||||
@ -6855,7 +6896,6 @@ var
|
||||
ok: Boolean;
|
||||
Values: TFPList; // list of PRangeItem
|
||||
ValueSet: TResEvalSet;
|
||||
ValueStrings: TStringList;
|
||||
Value: TResEvalValue;
|
||||
Item: PRangeItem;
|
||||
begin
|
||||
@ -6864,11 +6904,10 @@ begin
|
||||
ok:=false;
|
||||
Values:=TFPList.Create;
|
||||
ValueSet:=nil;
|
||||
ValueStrings:=nil;
|
||||
Value:=nil;
|
||||
try
|
||||
if (rrfReadable in CaseExprResolved.Flags) then
|
||||
ok:=CreateValues(CaseExprResolved,ValueSet,ValueStrings);
|
||||
ok:=CreateValues(CaseExprResolved,ValueSet);
|
||||
if not ok then
|
||||
RaiseXExpectedButYFound(20170216151952,'ordinal expression',
|
||||
GetTypeDescription(CaseExprResolved.LoTypeEl),CaseOf.CaseExpr);
|
||||
@ -6891,7 +6930,7 @@ begin
|
||||
|
||||
Value:=Eval(OfExpr,[refConst]);
|
||||
if Value<>nil then
|
||||
if not AddValue(Value,Values,ValueSet,ValueStrings,OfExpr) then
|
||||
if not AddValue(Value,Values,ValueSet,OfExpr) then
|
||||
RaiseIncompatibleTypeRes(20180424210815,nIncompatibleTypesGotExpected,
|
||||
[],OfExprResolved,CaseExprResolved,OfExpr);
|
||||
ReleaseEvalValue(Value);
|
||||
@ -6907,7 +6946,6 @@ begin
|
||||
finally
|
||||
ReleaseEvalValue(Value);
|
||||
ValueSet.Free;
|
||||
ValueStrings.Free;
|
||||
for i:=0 to Values.Count-1 do
|
||||
begin
|
||||
Item:=PRangeItem(Values[i]);
|
||||
|
||||
@ -316,12 +316,13 @@ type
|
||||
Procedure TestForLoop_AssignVarFail;
|
||||
Procedure TestForLoop_PassVarFail;
|
||||
Procedure TestStatements;
|
||||
Procedure TestCaseStatement;
|
||||
Procedure TestCaseStatementDuplicateIntFail;
|
||||
Procedure TestCaseStatementDuplicateStringFail;
|
||||
Procedure TestCaseOf;
|
||||
Procedure TestCaseExprNonOrdFail;
|
||||
Procedure TestCaseIncompatibleValueFail;
|
||||
Procedure TestCaseOfInt;
|
||||
Procedure TestCaseIntDuplicateFail;
|
||||
Procedure TestCaseOfStringDuplicateFail;
|
||||
Procedure TestCaseOfStringRangeDuplicateFail;
|
||||
Procedure TestCaseOfBaseType;
|
||||
Procedure TestCaseOfExprNonOrdFail;
|
||||
Procedure TestCaseOfIncompatibleValueFail;
|
||||
Procedure TestTryStatement;
|
||||
Procedure TestTryExceptOnNonTypeFail;
|
||||
Procedure TestTryExceptOnNonClassFail;
|
||||
@ -4553,7 +4554,7 @@ begin
|
||||
AssertEquals('3 declarations',3,PasProgram.ProgramSection.Declarations.Count);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestCaseStatement;
|
||||
procedure TTestResolver.TestCaseOfInt;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('const');
|
||||
@ -4578,7 +4579,7 @@ begin
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestCaseStatementDuplicateIntFail;
|
||||
procedure TTestResolver.TestCaseIntDuplicateFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
@ -4592,7 +4593,7 @@ begin
|
||||
CheckResolverException('Duplicate case value "1..3", other at afile.pp(5,3)',nDuplicateCaseValueXatY);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestCaseStatementDuplicateStringFail;
|
||||
procedure TTestResolver.TestCaseOfStringDuplicateFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
@ -4607,45 +4608,61 @@ begin
|
||||
CheckResolverException('Duplicate case value "string", other at afile.pp(5,3)',nDuplicateCaseValueXatY);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestCaseOf;
|
||||
procedure TTestResolver.TestCaseOfStringRangeDuplicateFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('type');
|
||||
Add(' TFlag = (red,green,blue);');
|
||||
Add('var');
|
||||
Add(' i: longint;');
|
||||
Add(' f: TFlag;');
|
||||
Add(' b: boolean;');
|
||||
Add(' c: char;');
|
||||
Add(' s: string;');
|
||||
Add('begin');
|
||||
Add(' case i of');
|
||||
Add(' 1: ;');
|
||||
Add(' 2..3: ;');
|
||||
Add(' 4,5..6,7: ;');
|
||||
Add(' else');
|
||||
Add(' end;');
|
||||
Add(' case f of');
|
||||
Add(' red: ;');
|
||||
Add(' green..blue: ;');
|
||||
Add(' end;');
|
||||
Add(' case b of');
|
||||
Add(' true: ;');
|
||||
Add(' false: ;');
|
||||
Add(' end;');
|
||||
Add(' case c of');
|
||||
Add(' #0: ;');
|
||||
Add(' #10,#13: ;');
|
||||
Add(' ''0''..''9'',''a''..''z'': ;');
|
||||
Add(' end;');
|
||||
Add(' case s of');
|
||||
Add(' #10: ;');
|
||||
Add(' ''abc'': ;');
|
||||
Add(' end;');
|
||||
Add([
|
||||
'var s: string;',
|
||||
'begin',
|
||||
' case s of',
|
||||
' ''c'': ;',
|
||||
' ''a''..''z'': ;',
|
||||
' end;',
|
||||
'']);
|
||||
CheckResolverException('Duplicate case value "string", other at afile.pp(5,3)',nDuplicateCaseValueXatY);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestCaseOfBaseType;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'type',
|
||||
' TFlag = (red,green,blue);',
|
||||
'var',
|
||||
' i: longint;',
|
||||
' f: TFlag;',
|
||||
' b: boolean;',
|
||||
' c: char;',
|
||||
' s: string;',
|
||||
'begin',
|
||||
' case i of',
|
||||
' 1: ;',
|
||||
' 2..3: ;',
|
||||
' 4,5..6,7: ;',
|
||||
' else',
|
||||
' end;',
|
||||
' case f of',
|
||||
' red: ;',
|
||||
' green..blue: ;',
|
||||
' end;',
|
||||
' case b of',
|
||||
' true: ;',
|
||||
' false: ;',
|
||||
' end;',
|
||||
' case c of',
|
||||
' #0: ;',
|
||||
' #10,#13: ;',
|
||||
' ''0''..''9'',''a''..''z'': ;',
|
||||
' end;',
|
||||
' case s of',
|
||||
' #10: ;',
|
||||
' ''abc'': ;',
|
||||
' ''a''..''z'': ;',
|
||||
' end;']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestCaseExprNonOrdFail;
|
||||
procedure TTestResolver.TestCaseOfExprNonOrdFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('begin');
|
||||
@ -4656,7 +4673,7 @@ begin
|
||||
nXExpectedButYFound);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestCaseIncompatibleValueFail;
|
||||
procedure TTestResolver.TestCaseOfIncompatibleValueFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('var i: longint;');
|
||||
|
||||
Loading…
Reference in New Issue
Block a user