* fixed with-support for classrefdefs (mantis 8150), with thanks to

Thorsten Engler for supplying an initial patch

git-svn-id: trunk@6088 -

.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

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 :

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);

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.

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.

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.

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.

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.

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.

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.

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.