mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-07 23:07:55 +02:00
Merge branch 'class_label_classref' into 'main'
Fix #39535 Case statement for class introspection Closes #39535 See merge request freepascal.org/fpc/source!233
This commit is contained in:
Ryan Joseph
commit
69785c22bd
compiler
@ -28,10 +28,10 @@ interface
|
||||
uses
|
||||
cclasses,constexp,
|
||||
node,globtype,globals,
|
||||
aasmbase,ncon,nflw,symtype;
|
||||
aasmbase,ncon,nmem,nflw,symtype;
|
||||
|
||||
type
|
||||
TLabelType = (ltOrdinal, ltConstString);
|
||||
TLabelType = (ltOrdinal, ltConstString, ltClassRef);
|
||||
|
||||
pcaselabel = ^tcaselabel;
|
||||
tcaselabel = record
|
||||
@ -55,6 +55,10 @@ interface
|
||||
_low_str,
|
||||
_high_str : tstringconstnode;
|
||||
);
|
||||
ltClassRef:
|
||||
(
|
||||
_class : tloadvmtaddrnode;
|
||||
);
|
||||
end;
|
||||
|
||||
pcaseblock = ^tcaseblock;
|
||||
@ -108,6 +112,7 @@ interface
|
||||
function getlabelcoverage: qword;
|
||||
procedure updatecoverage;
|
||||
procedure checkordinalcoverage;
|
||||
function insert_if_block_label(hcaselabel:pcaselabel; var p:pcaselabel): pcaselabel;
|
||||
public
|
||||
blocks : TFPList;
|
||||
elseblock : tnode;
|
||||
@ -130,6 +135,7 @@ interface
|
||||
function docompare(p: tnode): boolean; override;
|
||||
procedure addlabel(blockid:longint;const l,h : TConstExprInt); overload;
|
||||
procedure addlabel(blockid:longint;l,h : tstringconstnode); overload;
|
||||
procedure addlabel(blockid:longint;n : tloadvmtaddrnode); overload;
|
||||
procedure addblock(blockid:longint;instr:tnode);
|
||||
procedure addelseblock(instr:tnode);
|
||||
|
||||
@ -626,6 +632,49 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
function get_case_label_low_node(lab:pcaselabel): tnode;
|
||||
begin
|
||||
case lab^.label_type of
|
||||
ltConstString:
|
||||
result:=lab^._low_str;
|
||||
ltClassRef:
|
||||
result:=lab^._class;
|
||||
otherwise
|
||||
internalerror(2022011603);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function get_case_label_high_node(lab:pcaselabel): tnode;
|
||||
begin
|
||||
case lab^.label_type of
|
||||
ltConstString:
|
||||
result:=lab^._high_str;
|
||||
ltClassRef:
|
||||
result:=lab^._class;
|
||||
otherwise
|
||||
internalerror(2022011604);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function compare_case_labels(left,right:pcaselabel): integer;
|
||||
begin
|
||||
if left^.label_type<>right^.label_type then
|
||||
internalerror(2022011601);
|
||||
case left^.label_type of
|
||||
ltConstString:
|
||||
result:=left^._low_str.fullcompare(right^._high_str);
|
||||
ltClassRef:
|
||||
if equal_defs(left^._class.left.resultdef,right^._class.left.resultdef) then
|
||||
result:=0
|
||||
else
|
||||
result:=1;
|
||||
otherwise
|
||||
internalerror(2022011602);
|
||||
end;
|
||||
end;
|
||||
|
||||
{*****************************************************************************
|
||||
TCASENODE
|
||||
*****************************************************************************}
|
||||
@ -729,7 +778,6 @@ implementation
|
||||
result:=simplify(false);
|
||||
end;
|
||||
|
||||
|
||||
type
|
||||
TLinkedListCaseLabelItem = class(TLinkedListItem)
|
||||
casenode: pcaselabel;
|
||||
@ -796,13 +844,13 @@ implementation
|
||||
else
|
||||
newcheck:=@check;
|
||||
labitem:=TLinkedListCaseLabelItem(lablist[j]).casenode;
|
||||
newcheck^:=caddnode.create(equaln,left.getcopy,labitem^._low_str.getcopy);
|
||||
if (labitem^._low_str.fullcompare(labitem^._high_str)<>0) then
|
||||
newcheck^:=caddnode.create(equaln,left.getcopy,get_case_label_low_node(labitem).getcopy);
|
||||
if compare_case_labels(labitem,labitem)<>0 then
|
||||
begin
|
||||
newcheck^.nodetype:=gten;
|
||||
newcheck^:=caddnode.create(
|
||||
andn,newcheck^,caddnode.create(
|
||||
lten,left.getcopy,labitem^._high_str.getcopy));
|
||||
lten,left.getcopy,get_case_label_high_node(labitem).getcopy));
|
||||
end;
|
||||
end;
|
||||
result:=cifnode.create(check,
|
||||
@ -845,7 +893,7 @@ implementation
|
||||
{ Load caseexpr into temp var if complex. }
|
||||
{ No need to do this for ordinal, because }
|
||||
{ in that case caseexpr is generated once }
|
||||
if (flabels^.label_type = ltConstString) and (not valid_for_addr(left, false)) and
|
||||
if ((flabels^.label_type = ltConstString) or (flabels^.label_type = ltClassRef)) and (not valid_for_addr(left, false)) and
|
||||
(blocks.count > 0) then
|
||||
begin
|
||||
init_block := internalstatements(stmt);
|
||||
@ -888,7 +936,8 @@ implementation
|
||||
exit;
|
||||
end;
|
||||
|
||||
if (flabels^.label_type = ltConstString) then
|
||||
{ if-block case statements }
|
||||
if (flabels^.label_type = ltConstString) or (flabels^.label_type = ltClassRef) then
|
||||
begin
|
||||
if_node:=makeifblock(elseblock);
|
||||
|
||||
@ -1338,6 +1387,45 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
function tcasenode.insert_if_block_label(hcaselabel: pcaselabel; var p : pcaselabel) : pcaselabel;
|
||||
var
|
||||
duplicate_label: boolean;
|
||||
begin
|
||||
if not assigned(p) then
|
||||
begin
|
||||
p := hcaselabel;
|
||||
result := p;
|
||||
end
|
||||
else if compare_case_labels(p,hcaselabel)>0 then
|
||||
result := insert_if_block_label(hcaselabel,p^.less)
|
||||
else if compare_case_labels(p,hcaselabel)<0 then
|
||||
result := insert_if_block_label(hcaselabel,p^.greater)
|
||||
else
|
||||
begin
|
||||
duplicate_label:=true;
|
||||
if hcaselabel^.label_type=ltClassRef then
|
||||
begin
|
||||
{ class case labels with mismatched types use nil nodes as placeholder
|
||||
but we don't need to give an error the label is duplicate. }
|
||||
if hcaselabel^._class.left.nodetype=niln then
|
||||
duplicate_label := false;
|
||||
|
||||
hcaselabel^._class.free;
|
||||
end
|
||||
else
|
||||
begin
|
||||
get_case_label_low_node(hcaselabel).free;
|
||||
get_case_label_high_node(hcaselabel).free;
|
||||
end;
|
||||
|
||||
dispose(hcaselabel);
|
||||
if duplicate_label then
|
||||
Message(parser_e_double_caselabel);
|
||||
result:=nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure tcasenode.addlabel(blockid:longint;const l,h : TConstExprInt);
|
||||
var
|
||||
hcaselabel : pcaselabel;
|
||||
@ -1400,30 +1488,6 @@ implementation
|
||||
|
||||
var
|
||||
hcaselabel : pcaselabel;
|
||||
|
||||
function insertlabel(var p : pcaselabel) : pcaselabel;
|
||||
begin
|
||||
if not assigned(p) then
|
||||
begin
|
||||
p := hcaselabel;
|
||||
result := p;
|
||||
end
|
||||
else
|
||||
if (p^._low_str.fullcompare(hcaselabel^._high_str) > 0) then
|
||||
result := insertlabel(p^.less)
|
||||
else
|
||||
if (p^._high_str.fullcompare(hcaselabel^._low_str) < 0) then
|
||||
result := insertlabel(p^.greater)
|
||||
else
|
||||
begin
|
||||
hcaselabel^._low_str.free;
|
||||
hcaselabel^._high_str.free;
|
||||
dispose(hcaselabel);
|
||||
Message(parser_e_double_caselabel);
|
||||
result:=nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
new(hcaselabel);
|
||||
fillchar(hcaselabel^, sizeof(tcaselabel), 0);
|
||||
@ -1433,7 +1497,20 @@ implementation
|
||||
hcaselabel^._low_str := tstringconstnode(l.getcopy);
|
||||
hcaselabel^._high_str := tstringconstnode(h.getcopy);
|
||||
|
||||
insertlabel(flabels);
|
||||
insert_if_block_label(hcaselabel,flabels);
|
||||
end;
|
||||
|
||||
procedure tcasenode.addlabel(blockid: longint; n: tloadvmtaddrnode);
|
||||
var
|
||||
hcaselabel : pcaselabel;
|
||||
begin
|
||||
new(hcaselabel);
|
||||
fillchar(hcaselabel^, sizeof(tcaselabel), 0);
|
||||
hcaselabel^.blockid := blockid;
|
||||
hcaselabel^.label_type := ltClassRef;
|
||||
|
||||
hcaselabel^._class := tloadvmtaddrnode(n.getcopy);
|
||||
|
||||
insert_if_block_label(hcaselabel,flabels);
|
||||
end;
|
||||
end.
|
||||
|
||||
@ -123,7 +123,11 @@ implementation
|
||||
blockid : longint;
|
||||
hl1,hl2 : TConstExprInt;
|
||||
sl1,sl2 : tstringconstnode;
|
||||
casedeferror, caseofstring : boolean;
|
||||
casedeferror,
|
||||
caseofstring,
|
||||
caseofclass,
|
||||
case_mismatch : boolean;
|
||||
vmtnode : tloadvmtaddrnode;
|
||||
casenode : tcasenode;
|
||||
begin
|
||||
consume(_CASE);
|
||||
@ -144,10 +148,15 @@ implementation
|
||||
caseofstring :=
|
||||
([m_delphi, m_mac, m_tp7] * current_settings.modeswitches = []) and
|
||||
is_string(casedef);
|
||||
caseofclass :=
|
||||
([m_delphi, m_mac, m_tp7] * current_settings.modeswitches = []) and
|
||||
is_classref(casedef);
|
||||
|
||||
if (not assigned(casedef)) or
|
||||
( not(is_ordinal(casedef)) and (not caseofstring) ) then
|
||||
(not(is_ordinal(casedef)) and (not caseofstring and not caseofclass)) then
|
||||
begin
|
||||
// TODO: new message for class case types?
|
||||
// type_e_valid_case_label_expected
|
||||
CGMessage(type_e_ordinal_or_string_expr_expected);
|
||||
{ create a correct tree }
|
||||
caseexpr.free;
|
||||
@ -234,22 +243,56 @@ implementation
|
||||
|
||||
if caseofstring then
|
||||
casenode.addlabel(blockid,sl1,sl2)
|
||||
else if caseofclass then
|
||||
begin
|
||||
{ ranges of class are not supported but need a placeholder node anyways }
|
||||
vmtnode:=cloadvmtaddrnode.create(cnilnode.create);
|
||||
typecheckpass(tnode(vmtnode));
|
||||
casenode.addlabel(blockid,vmtnode);
|
||||
vmtnode.free;
|
||||
end
|
||||
else
|
||||
casenode.addlabel(blockid,hl1,hl2);
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ type check for string case statements }
|
||||
if (caseofstring and (not is_conststring_or_constcharnode(p))) or
|
||||
if (caseofstring and not is_conststring_or_constcharnode(p)) or
|
||||
{ type check for class case statements }
|
||||
(caseofclass and not is_classref(p.resultdef)) or
|
||||
{ type checking for ordinal case statements }
|
||||
((not caseofstring) and (not is_subequal(casedef, p.resultdef))) then
|
||||
CGMessage(parser_e_case_mismatch);
|
||||
((not caseofstring and not caseofclass) and (not is_subequal(casedef, p.resultdef))) then
|
||||
begin
|
||||
CGMessage(parser_e_case_mismatch);
|
||||
case_mismatch:=true;
|
||||
end
|
||||
else
|
||||
case_mismatch:=false;
|
||||
|
||||
if caseofstring then
|
||||
if case_mismatch then
|
||||
begin
|
||||
{ create placeholder labels for mismatched types }
|
||||
if caseofstring then
|
||||
begin
|
||||
sl1:=get_string_value(p, tstringdef(casedef));
|
||||
casenode.addlabel(blockid,sl1,sl1);
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ create a dummy vmt node for the mismatched label }
|
||||
vmtnode:=cloadvmtaddrnode.create(cnilnode.create);
|
||||
typecheckpass(tnode(vmtnode));
|
||||
casenode.addlabel(blockid,vmtnode);
|
||||
vmtnode.free;
|
||||
end;
|
||||
end
|
||||
else if caseofstring then
|
||||
begin
|
||||
sl1:=get_string_value(p, tstringdef(casedef));
|
||||
casenode.addlabel(blockid,sl1,sl1);
|
||||
end
|
||||
else if caseofclass then
|
||||
casenode.addlabel(blockid,tloadvmtaddrnode(p))
|
||||
else
|
||||
begin
|
||||
hl1:=get_ordinal_value(p);
|
||||
|
||||
@ -1349,6 +1349,7 @@ interface
|
||||
function is_dispinterface(def: tdef): boolean;
|
||||
function is_object(def: tdef): boolean;
|
||||
function is_class(def: tdef): boolean;
|
||||
function is_classref(def: tdef): boolean;
|
||||
function is_cppclass(def: tdef): boolean;
|
||||
function is_objectpascal_helper(def: tdef): boolean;
|
||||
function is_objcclass(def: tdef): boolean;
|
||||
@ -9317,6 +9318,13 @@ implementation
|
||||
(tobjectdef(def).objecttype=odt_class);
|
||||
end;
|
||||
|
||||
function is_classref(def: tdef): boolean;
|
||||
begin
|
||||
is_classref:=
|
||||
assigned(def) and
|
||||
(def.typ=classrefdef) and
|
||||
is_class(tclassrefdef(def).pointeddef);
|
||||
end;
|
||||
|
||||
function is_object(def: tdef): boolean;
|
||||
begin
|
||||
|
||||
Loading…
Reference in New Issue
Block a user