From 07cf3717c95d3e3b01b1602feb48eaef8c6c2ea3 Mon Sep 17 00:00:00 2001 From: Ryan Joseph Date: Sun, 16 Jan 2022 20:07:00 +0700 Subject: [PATCH 1/5] initial commit --- compiler/nset.pas | 123 +++++++++++++++++++++++++++++++----------- compiler/pstatmnt.pas | 18 +++++-- compiler/symdef.pas | 8 +++ 3 files changed, 113 insertions(+), 36 deletions(-) diff --git a/compiler/nset.pas b/compiler/nset.pas index 3ac18aecf3..58f6e649a0 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -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,11 @@ interface _low_str, _high_str : tstringconstnode; ); + ltClassRef: + ( + _low_class, + _high_class : tloadvmtaddrnode; + ); end; pcaseblock = ^tcaseblock; @@ -108,6 +113,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 +136,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;l,h : tloadvmtaddrnode); overload; procedure addblock(blockid:longint;instr:tnode); procedure addelseblock(instr:tnode); @@ -616,6 +623,46 @@ 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^._low_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^._high_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: + result:=comparetext(left^._low_class.left.resultdef.typename, right^._high_class.left.resultdef.typename); + otherwise + internalerror(2022011602); + end; + end; + {***************************************************************************** TCASENODE *****************************************************************************} @@ -719,7 +766,6 @@ implementation result:=simplify(false); end; - type TLinkedListCaseLabelItem = class(TLinkedListItem) casenode: pcaselabel; @@ -786,13 +832,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, @@ -878,7 +924,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); @@ -1300,6 +1347,28 @@ implementation end; + function tcasenode.insert_if_block_label(hcaselabel: pcaselabel; var p : pcaselabel) : pcaselabel; + 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 + get_case_label_low_node(hcaselabel).free; + get_case_label_high_node(hcaselabel).free; + dispose(hcaselabel); + Message(parser_e_double_caselabel); + result:=nil; + end; + end; + + procedure tcasenode.addlabel(blockid:longint;const l,h : TConstExprInt); var hcaselabel : pcaselabel; @@ -1362,30 +1431,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); @@ -1395,7 +1440,21 @@ 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; l, h: tloadvmtaddrnode); + var + hcaselabel : pcaselabel; + begin + new(hcaselabel); + fillchar(hcaselabel^, sizeof(tcaselabel), 0); + hcaselabel^.blockid := blockid; + hcaselabel^.label_type := ltClassRef; + + hcaselabel^._low_class := tloadvmtaddrnode(l.getcopy); + hcaselabel^._high_class := tloadvmtaddrnode(h.getcopy); + + insert_if_block_label(hcaselabel,flabels); + end; end. diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index caf8c0da42..ad2cf85e54 100644 --- a/compiler/pstatmnt.pas +++ b/compiler/pstatmnt.pas @@ -121,7 +121,9 @@ implementation blockid : longint; hl1,hl2 : TConstExprInt; sl1,sl2 : tstringconstnode; - casedeferror, caseofstring : boolean; + casedeferror, + caseofstring, + caseofclass : boolean; casenode : tcasenode; begin consume(_CASE); @@ -142,10 +144,14 @@ 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 all case types CGMessage(type_e_ordinal_or_string_expr_expected); { create a correct tree } caseexpr.free; @@ -238,9 +244,11 @@ implementation 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 + ((not caseofstring and not caseofclass) and (not is_subequal(casedef, p.resultdef))) then CGMessage(parser_e_case_mismatch); if caseofstring then @@ -248,6 +256,8 @@ implementation sl1:=get_string_value(p, tstringdef(casedef)); casenode.addlabel(blockid,sl1,sl1); end + else if caseofclass then + casenode.addlabel(blockid,tloadvmtaddrnode(p),tloadvmtaddrnode(p)) else begin hl1:=get_ordinal_value(p); diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 79cee23c64..10d6e0499d 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -1282,6 +1282,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; @@ -8805,6 +8806,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 From f0a7f0a83323da51ca17eafd247183faf2b5c65c Mon Sep 17 00:00:00 2001 From: Ryan Joseph Date: Tue, 18 Jan 2022 20:24:28 +0700 Subject: [PATCH 2/5] handling of cases with label mismatches --- compiler/nset.pas | 14 +++++++++++--- compiler/pstatmnt.pas | 35 +++++++++++++++++++++++++++++++---- 2 files changed, 42 insertions(+), 7 deletions(-) diff --git a/compiler/nset.pas b/compiler/nset.pas index 58f6e649a0..73e6e0f43c 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -657,7 +657,7 @@ implementation ltConstString: result:=left^._low_str.fullcompare(right^._high_str); ltClassRef: - result:=comparetext(left^._low_class.left.resultdef.typename, right^._high_class.left.resultdef.typename); + result:=comparetext(left^._low_class.left.resultdef.typename,right^._high_class.left.resultdef.typename); otherwise internalerror(2022011602); end; @@ -881,7 +881,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); @@ -1348,6 +1348,8 @@ implementation function tcasenode.insert_if_block_label(hcaselabel: pcaselabel; var p : pcaselabel) : pcaselabel; + var + duplicate_label: boolean; begin if not assigned(p) then begin @@ -1360,10 +1362,16 @@ implementation result := insert_if_block_label(hcaselabel,p^.greater) else begin + duplicate_label:=true; + { 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^.label_type=ltClassRef) and (hcaselabel^._low_class.left.nodetype=niln) then + duplicate_label := false; get_case_label_low_node(hcaselabel).free; get_case_label_high_node(hcaselabel).free; dispose(hcaselabel); - Message(parser_e_double_caselabel); + if duplicate_label then + Message(parser_e_double_caselabel); result:=nil; end; end; diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index ad2cf85e54..aba799ea93 100644 --- a/compiler/pstatmnt.pas +++ b/compiler/pstatmnt.pas @@ -123,7 +123,9 @@ implementation sl1,sl2 : tstringconstnode; casedeferror, caseofstring, - caseofclass : boolean; + caseofclass, + case_mismatch : boolean; + vmtnode : tloadvmtaddrnode; casenode : tcasenode; begin consume(_CASE); @@ -151,7 +153,8 @@ implementation if (not assigned(casedef)) or (not(is_ordinal(casedef)) and (not caseofstring and not caseofclass)) then begin - // TODO: new message for all case types + // 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; @@ -238,6 +241,8 @@ implementation if caseofstring then casenode.addlabel(blockid,sl1,sl2) + else if caseofclass then + casenode.addlabel(blockid,tloadvmtaddrnode(trangenode(p).left),tloadvmtaddrnode(trangenode(p).right)) else casenode.addlabel(blockid,hl1,hl2); end @@ -249,9 +254,31 @@ implementation (caseofclass and not is_classref(p.resultdef)) or { type checking for ordinal case statements } ((not caseofstring and not caseofclass) and (not is_subequal(casedef, p.resultdef))) then - CGMessage(parser_e_case_mismatch); + 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); + vmtnode.free; + end; + end + else if caseofstring then begin sl1:=get_string_value(p, tstringdef(casedef)); casenode.addlabel(blockid,sl1,sl1); From 399110cc97d4b538c45334cc88ace8a112eac91b Mon Sep 17 00:00:00 2001 From: Ryan Joseph Date: Tue, 18 Jan 2022 20:30:21 +0700 Subject: [PATCH 3/5] added placeholder node for ranges --- compiler/pstatmnt.pas | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index aba799ea93..144190b223 100644 --- a/compiler/pstatmnt.pas +++ b/compiler/pstatmnt.pas @@ -242,7 +242,13 @@ implementation if caseofstring then casenode.addlabel(blockid,sl1,sl2) else if caseofclass then - casenode.addlabel(blockid,tloadvmtaddrnode(trangenode(p).left),tloadvmtaddrnode(trangenode(p).right)) + 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); + vmtnode.free; + end else casenode.addlabel(blockid,hl1,hl2); end From 654a06ff3fefacc67ed3a976c9de705068363c62 Mon Sep 17 00:00:00 2001 From: Ryan Joseph Date: Tue, 18 Jan 2022 20:45:05 +0700 Subject: [PATCH 4/5] simplified label record --- compiler/nset.pas | 37 ++++++++++++++++++++++--------------- compiler/pstatmnt.pas | 6 +++--- 2 files changed, 25 insertions(+), 18 deletions(-) diff --git a/compiler/nset.pas b/compiler/nset.pas index 73e6e0f43c..211971e4b2 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -57,8 +57,7 @@ interface ); ltClassRef: ( - _low_class, - _high_class : tloadvmtaddrnode; + _class : tloadvmtaddrnode; ); end; @@ -136,7 +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;l,h : tloadvmtaddrnode); overload; + procedure addlabel(blockid:longint;n : tloadvmtaddrnode); overload; procedure addblock(blockid:longint;instr:tnode); procedure addelseblock(instr:tnode); @@ -629,7 +628,7 @@ implementation ltConstString: result:=lab^._low_str; ltClassRef: - result:=lab^._low_class; + result:=lab^._class; otherwise internalerror(2022011603); end; @@ -642,7 +641,7 @@ implementation ltConstString: result:=lab^._high_str; ltClassRef: - result:=lab^._high_class; + result:=lab^._class; otherwise internalerror(2022011604); end; @@ -657,7 +656,7 @@ implementation ltConstString: result:=left^._low_str.fullcompare(right^._high_str); ltClassRef: - result:=comparetext(left^._low_class.left.resultdef.typename,right^._high_class.left.resultdef.typename); + result:=comparetext(left^._class.left.resultdef.typename,right^._class.left.resultdef.typename); otherwise internalerror(2022011602); end; @@ -1363,12 +1362,21 @@ implementation else begin duplicate_label:=true; - { 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^.label_type=ltClassRef) and (hcaselabel^._low_class.left.nodetype=niln) then - duplicate_label := false; - get_case_label_low_node(hcaselabel).free; - get_case_label_high_node(hcaselabel).free; + 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); @@ -1451,7 +1459,7 @@ implementation insert_if_block_label(hcaselabel,flabels); end; - procedure tcasenode.addlabel(blockid: longint; l, h: tloadvmtaddrnode); + procedure tcasenode.addlabel(blockid: longint; n: tloadvmtaddrnode); var hcaselabel : pcaselabel; begin @@ -1460,8 +1468,7 @@ implementation hcaselabel^.blockid := blockid; hcaselabel^.label_type := ltClassRef; - hcaselabel^._low_class := tloadvmtaddrnode(l.getcopy); - hcaselabel^._high_class := tloadvmtaddrnode(h.getcopy); + hcaselabel^._class := tloadvmtaddrnode(n.getcopy); insert_if_block_label(hcaselabel,flabels); end; diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index 144190b223..204c121b5a 100644 --- a/compiler/pstatmnt.pas +++ b/compiler/pstatmnt.pas @@ -246,7 +246,7 @@ implementation { 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); + casenode.addlabel(blockid,vmtnode); vmtnode.free; end else @@ -280,7 +280,7 @@ implementation { create a dummy vmt node for the mismatched label } vmtnode:=cloadvmtaddrnode.create(cnilnode.create); typecheckpass(tnode(vmtnode)); - casenode.addlabel(blockid,vmtnode,vmtnode); + casenode.addlabel(blockid,vmtnode); vmtnode.free; end; end @@ -290,7 +290,7 @@ implementation casenode.addlabel(blockid,sl1,sl1); end else if caseofclass then - casenode.addlabel(blockid,tloadvmtaddrnode(p),tloadvmtaddrnode(p)) + casenode.addlabel(blockid,tloadvmtaddrnode(p)) else begin hl1:=get_ordinal_value(p); From 13ae5569ce478801e817c74d71b3e9b7a9c11146 Mon Sep 17 00:00:00 2001 From: Ryan Joseph Date: Tue, 18 Jan 2022 20:45:15 +0700 Subject: [PATCH 5/5] better class label compare --- compiler/nset.pas | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/compiler/nset.pas b/compiler/nset.pas index 211971e4b2..b890388afb 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -656,7 +656,10 @@ implementation ltConstString: result:=left^._low_str.fullcompare(right^._high_str); ltClassRef: - result:=comparetext(left^._class.left.resultdef.typename,right^._class.left.resultdef.typename); + if equal_defs(left^._class.left.resultdef,right^._class.left.resultdef) then + result:=0 + else + result:=1; otherwise internalerror(2022011602); end;