View Issue Details

IDProjectCategoryView StatusLast Update
0038349FPCCompilerpublic2021-01-12 23:42
ReporterPierre Muller Assigned To 
PrioritynormalSeverityminorReproducibilityalways
Status newResolutionopen 
Product Version3.2.1 
Summary0038349: typecast of a class type to a descendant class type leads to problems
Description  using tstringdef(tdef).var

  where var is a regular field of the tstringdef should lead to a compile time error
because var is not a class variable.

 This compile time error is correctly generated when using tstringdef.var
but the tstringdef(tdef).var assumes that the VMT address is a 'normal' class instance
and thus does not emit a compile time error.
Steps To Reproduce test_class_var.pp
contains a working code when compiled without -dERRORX

adding -dERROR1, -dERROR2, -dERROR3 or -dERROR4
should always generate a compile time error,
but with the current trunk compiler, only -dERROR2
correctly generates a compile time error.
 -dERROR1 generates wrong results because it gets the value of the stringtype field
at some offset in the VMT of tdef.

-dERROR3 and -dERROR4 show similar problem.

TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget
Attached Files

Activities

Pierre Muller

2021-01-12 23:42

developer  

test_class_var.pp (4,090 bytes)   
{$mode objfpc}
type
  tdeftype = (nonedef, intdef, stringdef, floatdef, recorddef);
  tstringtype = (st_none, st_shortstring, st_longstring, st_ansistring);

  tdef = class(tobject)
    typ : tdeftype;
    class var defcount : longint;
    constructor create(atyp : tdeftype);
    constructor create; virtual;
    destructor destroy; override;
  end;

  tstringdef = class(tdef)
    stringtype : tstringtype;
    class var stringcount : longint;
    constructor create(astyp : tstringtype);
    constructor create; override;
    destructor destroy; override;
  end;

const
  tagtypes : set of tdeftype = [stringdef, recorddef];

  function use_tag_prefix(def : tdef) : boolean;
    begin
      { stringdefs are not all considered as 'taggable',
        because ansi, unicode and wide strings are
        just associated to pointer types }
      use_tag_prefix:=(def.typ in tagtypes) and
                    ((def.typ<>stringdef) or
{$ifdef ERROR1}
                    (tstringdef(tdef).stringtype in [st_shortstring,st_longstring]));
{$else}
                    (tstringdef(def).stringtype in [st_shortstring,st_longstring]));
{$endif}
    end;


   constructor tdef.create(atyp : tdeftype);
     begin
       inherited create;
       typ:=atyp;
       inc(defcount);
     end;

   constructor tdef.create;
     begin
       create(intdef);
     end;

   destructor tdef.destroy;
     begin
       dec(defcount);
       inherited destroy;
     end;

   constructor tstringdef.create(astyp : tstringtype);
     begin
       inherited create(stringdef);
       stringtype:=astyp;
       inc(stringcount);
     end;

   constructor tstringdef.create;
     begin
       create(st_shortstring);
     end;

   destructor tstringdef.destroy;
     begin
       dec(stringcount);
       inherited destroy;
     end;

var
  cdef : class of tdef; 
  def, def2, def_int, def_rec, def_shortstring, def_ansistring : tdef;
  error : boolean;

begin
  error:=false;
  cdef:=tdef;
  def:=cdef.create;
  cdef:=tstringdef;
  def2:=cdef.create;
  def_int:=tdef.create(intdef);
  def_rec:=tdef.create(recorddef);
  def_shortstring:=tstringdef.create(st_shortstring);  
  def_ansistring:=tstringdef.create(st_ansistring);  
  if use_tag_prefix(def_int) then
    begin
      writeln('Wrong result for int type');
      error:=true;
    end;
  if not use_tag_prefix(def_rec) then
    begin
      writeln('Wrong result for record type');
      error:=true;
    end;
  if not use_tag_prefix(def_shortstring) then
    begin
      writeln('Wrong result for short string type');
      error:=true;
    end;
  if use_tag_prefix(def_ansistring) then
    begin
      writeln('Wrong result for ansi string type');
      error:=true;
    end;

  if not (def is tdef) or (def is tstringdef) or use_tag_prefix(def) then
    begin
      writeln('Wrong result for default int type');
      error:=true;
    end;

  if not (def2 is tstringdef) or not use_tag_prefix(def2) then
    begin
      writeln('Wrong result for default string type');
      error:=true;
    end;

  writeln('Number of def created=',tdef.defcount);
  writeln('Number of stringdef created=',tstringdef.stringcount);
  
  writeln('Number of def created (using cdef)=',cdef.defcount);
  writeln('Number of stringdef created (using cdef)=',tstringdef(cdef).stringcount);
   writeln('test stringdefcount=',tstringdef(tdef).stringcount);
{$ifdef ERROR2}
  writeln('test stringtype=',ord(tstringdef.stringtype));
{$endif}
{$ifdef ERROR3}
  writeln('test stringtype=',ord(tstringdef(tstringdef).stringtype));
{$endif}
{$ifdef ERROR4}
  writeln('test stringtype=',ord(tstringdef(tdef).stringtype));
{$endif}
  def.destroy;
  def2.destroy;
  def_int.destroy;
  def_rec.destroy;
  def_shortstring.destroy;
  def_ansistring.destroy;

  if error then
    halt(1);

  writeln('Number of def created (using cdef)=',cdef.defcount);
  writeln('Number of stringdef created (using cdef)=',tstringdef(cdef).stringcount);
  if (cdef.defcount<>0) or (tstringdef.stringcount<>0) then
    begin
      Writeln('Not all classes are freed correctly');
      halt(2);
    end;
end.

test_class_var.pp (4,090 bytes)   

Issue History

Date Modified Username Field Change
2021-01-12 23:42 Pierre Muller New Issue
2021-01-12 23:42 Pierre Muller File Added: test_class_var.pp