From 4e96fe8fac123d6343b2bb059c4e158f38269d01 Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Sat, 20 Jan 2007 20:04:54 +0000 Subject: [PATCH] * fixed with-support for classrefdefs (mantis 8150), with thanks to Thorsten Engler for supplying an initial patch git-svn-id: trunk@6088 - --- .gitattributes | 8 +++ compiler/pexpr.pas | 153 ++++++++++++++++++++++++---------------- compiler/pstatmnt.pas | 23 ++++-- tests/webtbf/tw8150.pp | 31 ++++++++ tests/webtbf/tw8150b.pp | 32 +++++++++ tests/webtbf/tw8150c.pp | 29 ++++++++ tests/webtbf/tw8150e.pp | 68 ++++++++++++++++++ tests/webtbf/tw8150f.pp | 68 ++++++++++++++++++ tests/webtbf/tw8150g.pp | 67 ++++++++++++++++++ tests/webtbs/tw8150a.pp | 37 ++++++++++ tests/webtbs/tw8150d.pp | 67 ++++++++++++++++++ 11 files changed, 517 insertions(+), 66 deletions(-) create mode 100644 tests/webtbf/tw8150.pp create mode 100644 tests/webtbf/tw8150b.pp create mode 100644 tests/webtbf/tw8150c.pp create mode 100644 tests/webtbf/tw8150e.pp create mode 100644 tests/webtbf/tw8150f.pp create mode 100644 tests/webtbf/tw8150g.pp create mode 100644 tests/webtbs/tw8150a.pp create mode 100644 tests/webtbs/tw8150d.pp diff --git a/.gitattributes b/.gitattributes index 29c8872dbb..4b77ec3d78 100644 --- a/.gitattributes +++ b/.gitattributes @@ -7138,6 +7138,12 @@ tests/webtbf/tw8140a.pp svneol=native#text/plain tests/webtbf/tw8140c.pp svneol=native#text/plain tests/webtbf/tw8140d.pp svneol=native#text/plain tests/webtbf/tw8140e.pp svneol=native#text/plain +tests/webtbf/tw8150.pp svneol=native#text/plain +tests/webtbf/tw8150b.pp svneol=native#text/plain +tests/webtbf/tw8150c.pp svneol=native#text/plain +tests/webtbf/tw8150e.pp svneol=native#text/plain +tests/webtbf/tw8150f.pp svneol=native#text/plain +tests/webtbf/tw8150g.pp svneol=native#text/plain tests/webtbf/uw0744.pp svneol=native#text/plain tests/webtbf/uw0840a.pp svneol=native#text/plain tests/webtbf/uw0840b.pp svneol=native#text/plain @@ -7981,6 +7987,8 @@ tests/webtbs/tw8140h.pp svneol=native#text/plain tests/webtbs/tw8141.pp svneol=native#text/plain tests/webtbs/tw8145.pp svneol=native#text/plain tests/webtbs/tw8148.pp svneol=native#text/plain +tests/webtbs/tw8150a.pp svneol=native#text/plain +tests/webtbs/tw8150d.pp svneol=native#text/plain tests/webtbs/ub1873.pp svneol=native#text/plain tests/webtbs/ub1883.pp svneol=native#text/plain tests/webtbs/uw0555.pp svneol=native#text/plain diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 3580402b19..764774e7cc 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -1299,7 +1299,11 @@ implementation else begin if isclassref then - Message(parser_e_only_class_methods_via_class_ref); + if assigned(p1) and + is_self_node(p1) then + Message(parser_e_only_class_methods) + else + Message(parser_e_only_class_methods_via_class_ref); p1:=csubscriptnode.create(sym,p1); end; end; @@ -1323,6 +1327,41 @@ implementation Factor ****************************************************************************} + + function is_member_read(sym: tsym; st: tsymtable; var p1: tnode; + out memberparentdef: tdef): boolean; + var + hdef : tdef; + begin + result:=true; + memberparentdef:=nil; + + case st.symtabletype of + ObjectSymtable: + begin + memberparentdef:=tdef(st.defowner); + exit; + end; + WithSymtable: + begin + if assigned(p1) then + internalerror(2007012002); + + hdef:=tnode(twithsymtable(st).withrefnode).resultdef; + p1:=tnode(twithsymtable(st).withrefnode).getcopy; + + if not(hdef.typ in [objectdef,classrefdef]) then + exit; + + if (hdef.typ=classrefdef) then + hdef:=tclassrefdef(hdef).pointeddef; + memberparentdef:=hdef; + end; + else + result:=false; + end; + end; + {$maxfpuregisters 0} function factor(getaddr : boolean) : tnode; @@ -1434,39 +1473,28 @@ implementation paravarsym, fieldvarsym : begin - if (sp_static in srsym.symoptions) then - begin - static_name:=lower(srsym.owner.name^)+'_'+srsym.name; - searchsym(static_name,srsym,srsymtable); - if assigned(srsym) then - check_hints(srsym,srsym.symoptions); - end + { check if we are reading a field of an object/class/ } + { record. is_member_read() will deal with withsymtables } + { if needed. } + if is_member_read(srsym,srsymtable,p1,hdef) then + begin + { if the field was originally found in an } + { objectsymtable, it means it's part of self } + if (srsymtable.symtabletype=ObjectSymtable) then + p1:=load_self_node; + { now, if the field itself is part of an objectsymtab } + { (it can be even if it was found in a withsymtable, } + { e.g., "with classinstance do field := 5"), then } + { let do_member_read handle it } + if (srsym.owner.symtabletype=ObjectSymtable) then + do_member_read(tobjectdef(hdef),getaddr,srsym,p1,again,[]) + else + { otherwise it's a regular record subscript } + p1:=csubscriptnode.create(srsym,p1); + end else - begin - { are we in a class method, we check here the - srsymtable, because a field in another object - also has ObjectSymtable. And withsymtable is - not possible for self in class methods (PFV) } - if (srsymtable.symtabletype=ObjectSymtable) and - assigned(current_procinfo) and - (po_classmethod in current_procinfo.procdef.procoptions) then - Message(parser_e_only_class_methods); - end; - - case srsymtable.symtabletype of - ObjectSymtable : - begin - p1:=csubscriptnode.create(srsym,load_self_node); - node_tree_set_filepos(p1,current_filepos); - end; - withsymtable : - begin - p1:=csubscriptnode.create(srsym,tnode(twithsymtable(srsymtable).withrefnode).getcopy); - node_tree_set_filepos(p1,current_filepos); - end; - else - p1:=cloadnode.create(srsym,srsymtable); - end; + { regular non-field load } + p1:=cloadnode.create(srsym,srsymtable); end; syssym : @@ -1633,38 +1661,43 @@ implementation procsym : begin - { are we in a class method ? } - possible_error:=(srsymtable.symtabletype<>withsymtable) and - (srsym.owner.symtabletype=ObjectSymtable) and - not(is_interface(tdef(srsym.owner.defowner))) and - assigned(current_procinfo) and - (po_classmethod in current_procinfo.procdef.procoptions); - do_proc_call(srsym,srsymtable,nil, - (getaddr and not(token in [_CARET,_POINT])), - again,p1,[]); - { we need to know which procedure is called } - if possible_error then - begin - do_typecheckpass(p1); - if (p1.nodetype=calln) and - assigned(tcallnode(p1).procdefinition) and - not(tcallnode(p1).procdefinition.proctypeoption=potype_constructor) and - not(po_classmethod in tcallnode(p1).procdefinition.procoptions) then - Message(parser_e_only_class_methods); - end; + { check if it's a method/class method } + if is_member_read(srsym,srsymtable,p1,hdef) then + begin + { not srsymtable.symtabletype since that can be } + { withsymtable as well } + if (srsym.owner.symtabletype=ObjectSymtable) then + do_member_read(tobjectdef(hdef),getaddr,srsym,p1,again,[]) + else + { no procsyms in records (yet) } + internalerror(2007012006); + end + else + { regular procedure/function call } + do_proc_call(srsym,srsymtable,nil, + (getaddr and not(token in [_CARET,_POINT])), + again,p1,[]); end; propertysym : begin - { access to property in a method } - { are we in a class method ? } - if (srsymtable.symtabletype=ObjectSymtable) and - assigned(current_procinfo) and - (po_classmethod in current_procinfo.procdef.procoptions) then - Message(parser_e_only_class_methods); + { property of a class/object? } + if is_member_read(srsym,srsymtable,p1,hdef) then + begin + { not srsymtable.symtabletype since that can be } + { withsymtable as well } + if (srsym.owner.symtabletype=ObjectSymtable) then + do_member_read(tobjectdef(hdef),getaddr,srsym,p1,again,[]) + else + { no propertysyms in records (yet) } + internalerror(2007012006); + end + else { no method pointer } - p1:=nil; - handle_propertysym(tpropertysym(srsym),srsymtable,p1); + begin + p1:=nil; + handle_propertysym(tpropertysym(srsym),srsymtable,p1); + end; end; labelsym : diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index 107f633d27..8ff0b512e2 100644 --- a/compiler/pstatmnt.pas +++ b/compiler/pstatmnt.pas @@ -454,18 +454,19 @@ implementation hasimplicitderef : boolean; withsymtablelist : TFPObjectList; - procedure pushobjchild(obj:tobjectdef); + procedure pushobjchild(withdef,obj:tobjectdef); begin if not assigned(obj) then exit; - pushobjchild(obj.childof); + pushobjchild(withdef,obj.childof); { keep the original tobjectdef as owner, because that is used for visibility of the symtable } - st:=twithsymtable.create(tobjectdef(p.resultdef),obj.symtable.SymList,refnode.getcopy); + st:=twithsymtable.create(withdef,obj.symtable.SymList,refnode.getcopy); symtablestack.push(st); withsymtablelist.add(st); end; + begin p:=comp_expr(true); do_typecheckpass(p); @@ -474,7 +475,7 @@ implementation (nf_memseg in p.flags) then CGMessage(parser_e_no_with_for_variable_in_other_segments); - if (p.resultdef.typ in [objectdef,recorddef]) then + if (p.resultdef.typ in [objectdef,recorddef,classrefdef]) then begin newblock:=nil; valuenode:=nil; @@ -521,7 +522,8 @@ implementation typecheckpass(p); end; { classes and interfaces have implicit dereferencing } - hasimplicitderef:=is_class_or_interface(p.resultdef); + hasimplicitderef:=is_class_or_interface(p.resultdef) or + (p.resultdef.typ = classrefdef); if hasimplicitderef then hdef:=p.resultdef else @@ -552,12 +554,21 @@ implementation objectdef : begin { push symtables of all parents in reverse order } - pushobjchild(tobjectdef(p.resultdef).childof); + pushobjchild(tobjectdef(p.resultdef),tobjectdef(p.resultdef).childof); { push object symtable } st:=twithsymtable.Create(tobjectdef(p.resultdef),tobjectdef(p.resultdef).symtable.SymList,refnode); symtablestack.push(st); withsymtablelist.add(st); end; + classrefdef : + begin + { push symtables of all parents in reverse order } + pushobjchild(tobjectdef(tclassrefdef(p.resultdef).pointeddef),tobjectdef(tclassrefdef(p.resultdef).pointeddef).childof); + { push object symtable } + st:=twithsymtable.Create(tobjectdef(tclassrefdef(p.resultdef).pointeddef),tobjectdef(tclassrefdef(p.resultdef).pointeddef).symtable.SymList,refnode); + symtablestack.push(st); + withsymtablelist.add(st); + end; recorddef : begin st:=twithsymtable.create(trecorddef(p.resultdef),trecorddef(p.resultdef).symtable.SymList,refnode); diff --git a/tests/webtbf/tw8150.pp b/tests/webtbf/tw8150.pp new file mode 100644 index 0000000000..9f89814371 --- /dev/null +++ b/tests/webtbf/tw8150.pp @@ -0,0 +1,31 @@ +{ %fail } +{ %norun } + +{$ifdef fpc} +{$mode delphi} +{$endif} + +type + tc = class + class procedure classmethod; + procedure method; + a : longint; + end; + + ttc = class of tc; + +class procedure tc.classmethod; +begin +end; + +procedure tc.method; +begin +end; + +var + c: ttc; +begin + c := tc; + with c do + a := 5; +end. diff --git a/tests/webtbf/tw8150b.pp b/tests/webtbf/tw8150b.pp new file mode 100644 index 0000000000..0a61267957 --- /dev/null +++ b/tests/webtbf/tw8150b.pp @@ -0,0 +1,32 @@ +{ %fail } +{ %norun } + +{$ifdef fpc} +{$mode delphi} +{$endif} + +type + tc = class + class procedure classmethod; + procedure method; + a : longint; + property x: longint read a; + end; + + ttc = class of tc; + +class procedure tc.classmethod; +begin +end; + +procedure tc.method; +begin +end; + +var + c: ttc; +begin + c := tc; + with c do + writeln(x); +end. diff --git a/tests/webtbf/tw8150c.pp b/tests/webtbf/tw8150c.pp new file mode 100644 index 0000000000..065dc389e0 --- /dev/null +++ b/tests/webtbf/tw8150c.pp @@ -0,0 +1,29 @@ +{ %fail } +{ %norun } + +{$ifdef fpc} +{$mode delphi} +{$endif} + +type + tc = class + class procedure classmethod; + procedure method; + a : longint; + end; + + ttc = class of tc; + +class procedure tc.classmethod; +begin + a:= 5; +end; + +procedure tc.method; +begin +end; + +var + c: ttc; +begin +end. diff --git a/tests/webtbf/tw8150e.pp b/tests/webtbf/tw8150e.pp new file mode 100644 index 0000000000..7b4b285c61 --- /dev/null +++ b/tests/webtbf/tw8150e.pp @@ -0,0 +1,68 @@ +{ %fail } +{ %norun } + +program WithForClassTypes; + +{$IFDEF FPC} + {$mode delphi} +{$ENDIF} + +type + TMyObject = class + x: Integer; + class procedure Foo; virtual; + procedure Bar; virtual; + end; + + TMyObject2 = class(TMyObject) + class procedure Foo; override; + procedure Bar; override; + end; + + TMyClass = class of TMyObject; + +{ TMyObject } + +procedure TMyObject.Bar; +begin + WriteLn('Bar ', Integer(Pointer(Self)),' ', x); +end; + +class procedure TMyObject.Foo; +begin + WriteLn('Foo'); +end; + +{ TMyObject2 } + +procedure TMyObject2.Bar; +begin + WriteLn('2Bar ', Integer(Pointer(Self)),' ', x); +end; + +class procedure TMyObject2.Foo; +begin + WriteLn('2Foo'); +end; + +var + MyClass : TMyClass = TMyObject2; + +begin + with MyClass do begin + Foo; // should work + + with Create do try // should work + x := 3; // should work + Bar; // should work + finally + Free; // should work + end; + + Foo; // should work + + x := 1; // should not be allowed +// Bar; // should not be allowed +// Free; // should not be allowed + end; +end. diff --git a/tests/webtbf/tw8150f.pp b/tests/webtbf/tw8150f.pp new file mode 100644 index 0000000000..3a175e4405 --- /dev/null +++ b/tests/webtbf/tw8150f.pp @@ -0,0 +1,68 @@ +{ %fail } +{ %norun } + +program WithForClassTypes; + +{$IFDEF FPC} + {$mode delphi} +{$ENDIF} + +type + TMyObject = class + x: Integer; + class procedure Foo; virtual; + procedure Bar; virtual; + end; + + TMyObject2 = class(TMyObject) + class procedure Foo; override; + procedure Bar; override; + end; + + TMyClass = class of TMyObject; + +{ TMyObject } + +procedure TMyObject.Bar; +begin + WriteLn('Bar ', Integer(Pointer(Self)),' ', x); +end; + +class procedure TMyObject.Foo; +begin + WriteLn('Foo'); +end; + +{ TMyObject2 } + +procedure TMyObject2.Bar; +begin + WriteLn('2Bar ', Integer(Pointer(Self)),' ', x); +end; + +class procedure TMyObject2.Foo; +begin + WriteLn('2Foo'); +end; + +var + MyClass : TMyClass = TMyObject2; + +begin + with MyClass do begin + Foo; // should work + + with Create do try // should work + x := 3; // should work + Bar; // should work + finally + Free; // should work + end; + + Foo; // should work + +// x := 1; // should not be allowed + Bar; // should not be allowed +// Free; // should not be allowed + end; +end. diff --git a/tests/webtbf/tw8150g.pp b/tests/webtbf/tw8150g.pp new file mode 100644 index 0000000000..4a65b1b1de --- /dev/null +++ b/tests/webtbf/tw8150g.pp @@ -0,0 +1,67 @@ +{ %fail } +{ %norun } +program WithForClassTypes; + +{$IFDEF FPC} + {$mode delphi} +{$ENDIF} + +type + TMyObject = class + x: Integer; + class procedure Foo; virtual; + procedure Bar; virtual; + end; + + TMyObject2 = class(TMyObject) + class procedure Foo; override; + procedure Bar; override; + end; + + TMyClass = class of TMyObject; + +{ TMyObject } + +procedure TMyObject.Bar; +begin + WriteLn('Bar ', Integer(Pointer(Self)),' ', x); +end; + +class procedure TMyObject.Foo; +begin + WriteLn('Foo'); +end; + +{ TMyObject2 } + +procedure TMyObject2.Bar; +begin + WriteLn('2Bar ', Integer(Pointer(Self)),' ', x); +end; + +class procedure TMyObject2.Foo; +begin + WriteLn('2Foo'); +end; + +var + MyClass : TMyClass = TMyObject2; + +begin + with MyClass do begin + Foo; // should work + + with Create do try // should work + x := 3; // should work + Bar; // should work + finally + Free; // should work + end; + + Foo; // should work + +// x := 1; // should not be allowed +// Bar; // should not be allowed + Free; // should not be allowed + end; +end. diff --git a/tests/webtbs/tw8150a.pp b/tests/webtbs/tw8150a.pp new file mode 100644 index 0000000000..9bf8f107b0 --- /dev/null +++ b/tests/webtbs/tw8150a.pp @@ -0,0 +1,37 @@ +{$ifdef fpc} +{$mode delphi} +{$endif} + +type + tc = class + class procedure classmethod; + procedure method; + a : longint; + end; + + ttc = class of tc; + +var + l : longint; + +class procedure tc.classmethod; +begin + if l <> 1 then + halt(1); + l := 2; +end; + +procedure tc.method; +begin +end; + +var + c: ttc; +begin + c := tc; + l := 1; + with c do + classmethod; + if l <> 2 then + halt(2); +end. diff --git a/tests/webtbs/tw8150d.pp b/tests/webtbs/tw8150d.pp new file mode 100644 index 0000000000..f30c66d6c7 --- /dev/null +++ b/tests/webtbs/tw8150d.pp @@ -0,0 +1,67 @@ +program WithForClassTypes; + +{$IFDEF FPC} + {$mode delphi} +{$ENDIF} + +type + TMyObject = class + x: Integer; + class procedure Foo; virtual; + procedure Bar; virtual; + end; + + TMyObject2 = class(TMyObject) + class procedure Foo; override; + procedure Bar; override; + end; + + TMyClass = class of TMyObject; + +{ TMyObject } + +procedure TMyObject.Bar; +begin + WriteLn('Bar ', Integer(Pointer(Self)),' ', x); +end; + +class procedure TMyObject.Foo; +begin + WriteLn('Foo'); +end; + +{ TMyObject2 } + +procedure TMyObject2.Bar; +begin + if (x <> 3) then + halt(1); + WriteLn('2Bar ', Integer(Pointer(Self)),' ', x); +end; + +class procedure TMyObject2.Foo; +begin + WriteLn('2Foo'); +end; + +var + MyClass : TMyClass = TMyObject2; + +begin + with MyClass do begin + Foo; // should work + + with Create do try // should work + x := 3; // should work + Bar; // should work + finally + Free; // should work + end; + + Foo; // should work + +// x := 1; // should not be allowed +// Bar; // should not be allowed +// Free; // should not be allowed + end; +end.