View Issue Details

IDProjectCategoryView StatusLast Update
0038872FPCCompilerpublic2021-05-16 17:27
ReporterRyan Joseph Assigned To 
PrioritynormalSeverityminorReproducibilityN/A
Status newResolutionopen 
Product Version3.3.1 
Summary0038872: [PATCH] default record property
DescriptionPatch to extend record management operators so that members of the default property are "hoisted" up into the record. Used for reference counting and "smart pointers", as seen in C++. The implementation is not complete or entirely decided upon but I'm putting it in the reporter so we can further discussion and development.

For more information on the design:

https://github.com/genericptr/freepascal/wiki/Default-property
TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget
Attached Files

Activities

Ryan Joseph

2021-05-10 20:18

reporter  

patch.diff (14,488 bytes)   
diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas
index 0d0e6f4aba..5efaf4e4ab 100644
--- a/compiler/htypechk.pas
+++ b/compiler/htypechk.pas
@@ -2369,11 +2369,26 @@ implementation
               (srsym.typ=procsym) then
              begin
                hasoverload:=processprocsym(tprocsym(srsym),foundanything);
+               { if the struct implements default properties then don't break yet 
+                 so we can add any additional overloads that may exist }
+               if oo_implements_default_property in structdef.objectoptions then
+                 foundanything:=false;
                { when there is no explicit overload we stop searching }
                if foundanything and
                   not hasoverload then
                  break;
              end;
+           { now add additional overloads for default property }
+           if oo_implements_default_property in structdef.objectoptions then
+             begin
+               srsym:=tsym(structdef.default_property_symtable.FindWithHash(hashedid.id,hashedid.hash));
+               if assigned(srsym) then
+                 begin
+                   hasoverload:=processprocsym(tprocsym(srsym),foundanything);
+                   if foundanything and not hasoverload then
+                     break;
+                 end;
+             end;
            if is_objectpascal_helper(structdef) and
               (
                 (tobjectdef(structdef).extendeddef.typ=recorddef) or
diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas
index b490cd18f3..508c1dc761 100644
--- a/compiler/pdecobj.pas
+++ b/compiler/pdecobj.pas
@@ -161,6 +161,214 @@ implementation
         result:=pd;
       end;
 
+    procedure implement_default_property(default_property:tpropertysym; record_def:tabstractrecorddef);
+      
+      { builds the property symbol access list for fields }
+      function build_field_symlist(pl:tpropaccesslist; caller_sym:tsym; target_sym:tsym; out def:tdef):boolean; inline;
+        begin
+          { add caller }
+          addsymref(caller_sym);
+          pl.addsym(sl_load,caller_sym);
+          { add target }
+          addsymref(target_sym);
+          pl.addsym(sl_subscript,target_sym);
+          def:=tfieldvarsym(target_sym).vardef;
+        end;
+
+      procedure insert_field_var(fieldvar: tfieldvarsym);
+        var
+          p: tpropertysym;
+          sym: tsym;
+          def: tdef;
+        begin
+          { generate propertysym and insert in symtablestack }
+          p:=cpropertysym.create(fieldvar.realname);
+          p.visibility:=symtablestack.top.currentvisibility;
+          p.default:=longint($80000000);
+
+          { insert the property symbol into the symtable
+            this is where the duplicate symbol message will be given if there
+            is a duplicate field in the current record. }
+          symtablestack.top.insert(p);
+          
+          { set property def to be the field var def }
+          p.propdef:=fieldvar.vardef;
+
+          { make getter }
+          sym:=default_property.propaccesslist[palt_read].firstsym^.sym;
+          build_field_symlist(p.propaccesslist[palt_read],sym,fieldvar,def);
+          sym:=p.propaccesslist[palt_read].firstsym^.sym;
+          p.add_getter_or_setter_for_sym(palt_read,sym,def,nil);
+
+          { make setter }
+          sym:=default_property.propaccesslist[palt_read].firstsym^.sym;
+          build_field_symlist(p.propaccesslist[palt_write],sym,fieldvar,def);
+          sym:=p.propaccesslist[palt_write].firstsym^.sym;
+          p.add_getter_or_setter_for_sym(palt_write,sym,def,nil);
+        end;
+      
+      procedure insert_property(property_sym: tpropertysym); 
+        var
+          p: tpropertysym;
+          readprocdef,
+          writeprocdef: tprocdef;
+          hparavs: tparavarsym;
+          paranr: word;
+          sym,
+          caller_sym,
+          target_sym: tsym;
+          def: tdef;
+        begin
+          paranr := 0;
+
+          { Generate temp procdefs to search for matching read/write
+            procedures. the readprocdef will store all definitions }
+          readprocdef:=cprocdef.create(normal_function_level,false);
+          writeprocdef:=cprocdef.create(normal_function_level,false);
+
+          readprocdef.struct:=record_def;
+          writeprocdef.struct:=record_def;
+
+          { class property? }
+          if assigned(record_def) and (sp_static in property_sym.symoptions) then
+            begin
+              readprocdef.procoptions:=[po_staticmethod,po_classmethod];
+              writeprocdef.procoptions:=[po_staticmethod,po_classmethod];
+            end;
+
+          { generate propertysym and insert in symtablestack }
+          p:=cpropertysym.create(property_sym.realname);
+          p.visibility:=symtablestack.top.currentvisibility;
+          p.default:=longint($80000000);
+
+          { insert the property symbol into the symtable
+            this is where the duplicate symbol message will be given if there
+            is a duplicate field in the current record. }
+          symtablestack.top.insert(p);
+          
+          { set property def to be the field var def }
+          p.propdef:=property_sym.propdef;
+
+          caller_sym:=default_property.propaccesslist[palt_read].firstsym^.sym;
+
+          { duplicate parameters and other options }
+          property_sym.makeduplicate(p,readprocdef,writeprocdef,paranr);
+
+          { getter }
+          if property_sym.propaccesslist[palt_read].firstsym<>nil then
+            begin
+              target_sym:=property_sym.propaccesslist[palt_read].firstsym^.sym;
+              case target_sym.typ of
+                fieldvarsym:
+                  begin
+                    build_field_symlist(p.propaccesslist[palt_read],caller_sym,target_sym,def);
+                    sym:=p.propaccesslist[palt_read].firstsym^.sym;
+                    p.add_getter_or_setter_for_sym(palt_read,sym,def,nil);
+                  end;
+                procsym:
+                  begin
+                    addsymref(target_sym);
+                    p.propaccesslist[palt_read].addsym(sl_call,target_sym);
+                    readprocdef.returndef:=p.propdef;
+                    { Insert hidden parameters }
+                    handle_calling_convention(readprocdef,hcc_default_actions_intf_struct);
+                    p.add_getter_or_setter_for_sym(palt_read,target_sym,nil,readprocdef);
+                  end;
+              end;
+            end
+          else
+            p.inherit_accessor(palt_read);
+
+          { setter }
+          if property_sym.propaccesslist[palt_write].firstsym<>nil then
+            begin
+              target_sym:=property_sym.propaccesslist[palt_write].firstsym^.sym;
+              case target_sym.typ of
+                fieldvarsym:
+                  begin
+                    build_field_symlist(p.propaccesslist[palt_write],caller_sym,target_sym,def);
+                    sym:=p.propaccesslist[palt_write].firstsym^.sym;
+                    p.add_getter_or_setter_for_sym(palt_write,sym,def,nil);
+                  end;
+                procsym:
+                  begin
+                    addsymref(target_sym);
+                    p.propaccesslist[palt_write].addsym(sl_call,target_sym);
+                    { setter is a procedure with an extra value parameter of the of the property }
+                    writeprocdef.returndef:=voidtype;
+                    // TODO: do we need to inc this again here?
+                    inc(paranr);
+                    hparavs:=cparavarsym.create('$value',10*paranr,vs_value,p.propdef,[]);
+                    writeprocdef.parast.insert(hparavs);
+                    { Insert hidden parameters }
+                    handle_calling_convention(writeprocdef,hcc_default_actions_intf_struct);
+                    p.add_getter_or_setter_for_sym(palt_write,target_sym,nil,writeprocdef);
+                  end;
+              end;
+            end
+          else
+            p.inherit_accessor(palt_write);
+
+          { register propgetter and propsetter procdefs }
+          if assigned(current_module) and current_module.in_interface then
+            begin
+              if readprocdef.proctypeoption=potype_propgetter then
+                readprocdef.register_def
+              else
+                readprocdef.free;
+              if writeprocdef.proctypeoption=potype_propsetter then
+                writeprocdef.register_def
+              else
+                writeprocdef.free;
+            end
+          else
+            begin
+              if readprocdef.proctypeoption=potype_propgetter then
+                readprocdef.maybe_put_in_symtable_stack
+              else
+                readprocdef.free;
+              if writeprocdef.proctypeoption=potype_propsetter then
+                writeprocdef.maybe_put_in_symtable_stack
+              else
+                writeprocdef.free;
+            end;
+        end;
+      
+      var
+        i: integer;
+        sym: tsym;
+        classh: tobjectdef;
+      begin
+        record_def.default_property_implementer:=tabstractrecorddef(default_property.propdef);
+        include(record_def.objectoptions,oo_implements_default_property);
+        { search in the class hierarchy for members to hoist }
+        classh:=tobjectdef(record_def.default_property_implementer);
+        while assigned(classh) do
+          begin
+            for i:=0 to classh.symtable.SymList.count-1 do
+              begin
+                sym:=tsym(classh.symtable.SymList[i]);
+                { ignore hidden members }
+                if sym.visibility=vis_hidden then
+                  continue;
+                { only consider members if they are visible to the property }
+                if is_visible_for_object(classh.symtable,default_property.visibility,record_def) then
+                  case sym.typ of
+                    fieldvarsym:
+                      insert_field_var(tfieldvarsym(sym));
+                    propertysym:
+                      insert_property(tpropertysym(sym));
+                    procsym:
+                      begin
+                        if record_def.default_property_symtable=nil then
+                          record_def.default_property_symtable:=tfphashobjectlist.create(false);
+                        record_def.default_property_symtable.add(sym.name,sym);
+                      end;
+                  end;
+              end;
+            classh:=classh.childof;
+          end;
+      end;
 
     procedure struct_property_dec(is_classproperty:boolean;var rtti_attrs_def: trtti_attribute_list);
       var
@@ -180,7 +388,10 @@ implementation
               message(parser_e_only_one_default_property);
             include(current_structdef.objectoptions,oo_has_default_property);
             include(p.propoptions,ppo_defaultproperty);
-            if not(ppo_hasparameters in p.propoptions) then
+            { implement default properties members into caller }
+            if (current_structdef.typ=recorddef) and (p.propdef.typ=objectdef) then
+              implement_default_property(p,current_structdef)
+            else if not(ppo_hasparameters in p.propoptions) then
               message(parser_e_property_need_paras);
             if (token=_COLON) then
               begin
diff --git a/compiler/symconst.pas b/compiler/symconst.pas
index aa97d73dc8..78d7092411 100644
--- a/compiler/symconst.pas
+++ b/compiler/symconst.pas
@@ -559,7 +559,8 @@ type
     oo_has_class_constructor, { the object/class has a class constructor }
     oo_has_class_destructor,  { the object/class has a class destructor  }
     oo_is_enum_class,     { the class represents an enum (JVM) }
-    oo_has_new_destructor { the object/class declares a destructor (apart from potentially inherting one from the parent) }
+    oo_has_new_destructor,{ the object/class declares a destructor (apart from potentially inherting one from the parent) }
+    oo_implements_default_property { the record implements a default property }
   );
   tobjectoptions=set of tobjectoption;
 
diff --git a/compiler/symdef.pas b/compiler/symdef.pas
index fca90803bf..0252dea66f 100644
--- a/compiler/symdef.pas
+++ b/compiler/symdef.pas
@@ -339,6 +339,12 @@ interface
           { for targets that initialise typed constants via explicit assignments
             instead of by generating an initialised data sectino }
           tcinitcode     : tnode;
+          { default property }
+          { TODO: how do we write these types to PPU?
+             or should we build these on demand,
+             or re-search for every proc call (slow!)? }
+          default_property_implementer : tabstractrecorddef;
+          default_property_symtable : tfphashobjectlist;
           constructor create(const n:string; dt:tdeftyp;doregister:boolean);
           constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
           procedure ppuwrite(ppufile:tcompilerppufile);override;
@@ -4565,6 +4571,7 @@ implementation
         stringdispose(objrealname);
         stringdispose(import_lib);
         tcinitcode.free;
+        freeandnil(default_property_symtable);
         inherited destroy;
       end;
 
diff --git a/compiler/symtable.pas b/compiler/symtable.pas
index 8117af72f7..f4d7233ae0 100644
--- a/compiler/symtable.pas
+++ b/compiler/symtable.pas
@@ -3829,6 +3829,25 @@ implementation
             result:=true;
             exit;
           end;
+        { search in default properties if nothing is found }
+        if oo_implements_default_property in recordh.objectoptions then
+          begin
+            if recordh.default_property_symtable<>nil then
+              begin
+                srsym:=tsym(recordh.default_property_symtable.FindWithHash(hashedid.id,hashedid.hash));
+                if assigned(srsym) then
+                  begin
+                    srsymtable:=srsym.owner;
+                    addsymref(srsym);
+                    result:=true;
+                    exit;
+                  end;
+              end;
+            { if nothing is found then search class helpers for the property }
+            result:=search_objectpascal_helper(recordh.default_property_implementer,recordh.default_property_implementer,s,srsym,srsymtable);
+            if result then
+              exit;
+          end;
         srsym:=nil;
         srsymtable:=nil;
       end;
patch.diff (14,488 bytes)   

Ryan Joseph

2021-05-10 20:26

reporter   ~0130813

For reference is my other older patch for the "move operator" (https://bugs.freepascal.org/view.php?id=35825) which would need to be added to make smart pointers work properly. Currently I think we'd have problems with how to implement the copy operator since not all classes can be copied. There's also an efficiency problem with making needless copies when assigning from constructors (see the move operator report for more information).

Ryan Joseph

2021-05-14 20:33

reporter   ~0130878

I needed to make some changes to support for..in loops and actually I did indeed need to add subscript node in 2 locations. It's still not 100% complete but I think this is enough to review the general design.

{$mode objfpc}
{$modeswitch advancedrecords}

program tdefprop8;
uses
  Classes;

type
  TManaged = record
    m_object: TStringList;
    property obj: TStringList read m_object write m_object; default;
  end;

var
  list: TManaged;
  s: string;
begin
  list.obj := TStringList.Create;
  list.Add('hello world');
  for s in list do
    writeln(s);
  list.Free;
end.
patch-2.diff (22,574 bytes)   
diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas
index 0d0e6f4aba..5efaf4e4ab 100644
--- a/compiler/htypechk.pas
+++ b/compiler/htypechk.pas
@@ -2369,11 +2369,26 @@ implementation
               (srsym.typ=procsym) then
              begin
                hasoverload:=processprocsym(tprocsym(srsym),foundanything);
+               { if the struct implements default properties then don't break yet 
+                 so we can add any additional overloads that may exist }
+               if oo_implements_default_property in structdef.objectoptions then
+                 foundanything:=false;
                { when there is no explicit overload we stop searching }
                if foundanything and
                   not hasoverload then
                  break;
              end;
+           { now add additional overloads for default property }
+           if oo_implements_default_property in structdef.objectoptions then
+             begin
+               srsym:=tsym(structdef.default_property_symtable.FindWithHash(hashedid.id,hashedid.hash));
+               if assigned(srsym) then
+                 begin
+                   hasoverload:=processprocsym(tprocsym(srsym),foundanything);
+                   if foundanything and not hasoverload then
+                     break;
+                 end;
+             end;
            if is_objectpascal_helper(structdef) and
               (
                 (tobjectdef(structdef).extendeddef.typ=recorddef) or
diff --git a/compiler/nflw.pas b/compiler/nflw.pas
index 870d23ebed..2e363cc58a 100644
--- a/compiler/nflw.pas
+++ b/compiler/nflw.pas
@@ -975,7 +975,15 @@ implementation
                             MessagePos1(expr.fileinfo,sym_e_no_enumerator_current,pd.returndef.typename);
                           end
                         else
-                          result:=create_enumerator_for_in_loop(hloopvar, hloopbody, expr, pd, movenext, current);
+                          begin
+                            if (expr.resultdef.typ=recorddef) and (oo_implements_default_property in tabstractrecorddef(expr.resultdef).objectoptions) then
+                              begin
+                                hoist_default_property(tpropertysym(tabstractrecorddef(expr.resultdef).default_property),tabstractrecorddef(expr.resultdef).symtable,expr);
+                                if expr.resultdef = nil then
+                                  do_typecheckpass(expr);
+                              end;
+                            result:=create_enumerator_for_in_loop(hloopvar, hloopbody, expr, pd, movenext, current);
+                          end;
                       end;
                   end
                 else
diff --git a/compiler/nutils.pas b/compiler/nutils.pas
index be76d4cf71..ba5c5efad7 100644
--- a/compiler/nutils.pas
+++ b/compiler/nutils.pas
@@ -112,6 +112,8 @@ interface
     procedure propaccesslist_to_node(var p1:tnode;st:TSymtable;pl:tpropaccesslist);
     function node_to_propaccesslist(p1:tnode):tpropaccesslist;
 
+    procedure hoist_default_property(propsym:tpropertysym; st:tsymtable; var p1:tnode);
+
     { checks whether sym is a static field and if so, translates the access
       to the appropriate node tree }
     function handle_staticfield_access(sym: tsym; var p1: tnode): boolean;
@@ -1230,6 +1232,26 @@ implementation
       end;
 
 
+    procedure hoist_default_property(propsym:tpropertysym; st:tsymtable; var p1:tnode);
+      var
+        propaccesslist: tpropaccesslist;
+        sym: tsym;
+      begin
+        if propsym.getpropaccesslist(palt_read,propaccesslist) then
+          begin
+           sym:=propaccesslist.firstsym^.sym;
+           case sym.typ of
+             fieldvarsym :
+               begin
+                 { generate access code }
+                 if not handle_staticfield_access(sym,p1) then
+                   propaccesslist_to_node(p1,st,propaccesslist);
+               end;
+            end;
+          end;
+      end;
+
+
     function node_to_propaccesslist(p1:tnode):tpropaccesslist;
       var
         sl : tpropaccesslist;
diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas
index b490cd18f3..269874fe2d 100644
--- a/compiler/pdecobj.pas
+++ b/compiler/pdecobj.pas
@@ -161,6 +161,224 @@ implementation
         result:=pd;
       end;
 
+    procedure implement_default_property(default_property:tpropertysym; record_def:tabstractrecorddef);
+      
+      { builds the property symbol access list for fields }
+      function build_field_symlist(pl:tpropaccesslist; caller_sym:tsym; target_sym:tsym; out def:tdef):boolean; inline;
+        begin
+          { add caller }
+          addsymref(caller_sym);
+          pl.addsym(sl_load,caller_sym);
+          { add target }
+          addsymref(target_sym);
+          pl.addsym(sl_subscript,target_sym);
+          def:=tfieldvarsym(target_sym).vardef;
+        end;
+
+      procedure insert_field_var(fieldvar: tfieldvarsym);
+        var
+          p: tpropertysym;
+          sym: tsym;
+          def: tdef;
+        begin
+          { generate propertysym and insert in symtablestack }
+          p:=cpropertysym.create(fieldvar.realname);
+          p.visibility:=symtablestack.top.currentvisibility;
+          p.default:=longint($80000000);
+
+          { insert the property symbol into the symtable
+            this is where the duplicate symbol message will be given if there
+            is a duplicate field in the current record. }
+          symtablestack.top.insert(p);
+          
+          { set property def to be the field var def }
+          p.propdef:=fieldvar.vardef;
+
+          { make getter }
+          sym:=default_property.propaccesslist[palt_read].firstsym^.sym;
+          build_field_symlist(p.propaccesslist[palt_read],sym,fieldvar,def);
+          sym:=p.propaccesslist[palt_read].firstsym^.sym;
+          p.add_getter_or_setter_for_sym(palt_read,sym,def,nil);
+
+          { make setter }
+          sym:=default_property.propaccesslist[palt_read].firstsym^.sym;
+          build_field_symlist(p.propaccesslist[palt_write],sym,fieldvar,def);
+          sym:=p.propaccesslist[palt_write].firstsym^.sym;
+          p.add_getter_or_setter_for_sym(palt_write,sym,def,nil);
+        end;
+      
+      procedure insert_property(property_sym: tpropertysym); 
+        var
+          p: tpropertysym;
+          readprocdef,
+          writeprocdef: tprocdef;
+          hparavs: tparavarsym;
+          paranr: word;
+          sym,
+          caller_sym,
+          target_sym: tsym;
+          def: tdef;
+        begin
+          paranr := 0;
+
+          { Generate temp procdefs to search for matching read/write
+            procedures. the readprocdef will store all definitions }
+          readprocdef:=cprocdef.create(normal_function_level,false);
+          writeprocdef:=cprocdef.create(normal_function_level,false);
+
+          readprocdef.struct:=record_def;
+          writeprocdef.struct:=record_def;
+
+          { class property? }
+          if assigned(record_def) and (sp_static in property_sym.symoptions) then
+            begin
+              readprocdef.procoptions:=[po_staticmethod,po_classmethod];
+              writeprocdef.procoptions:=[po_staticmethod,po_classmethod];
+            end;
+
+          { generate propertysym and insert in symtablestack }
+          p:=cpropertysym.create(property_sym.realname);
+          p.visibility:=symtablestack.top.currentvisibility;
+          p.default:=longint($80000000);
+
+          { insert the property symbol into the symtable
+            this is where the duplicate symbol message will be given if there
+            is a duplicate field in the current record. }
+          symtablestack.top.insert(p);
+          
+          { set property def to be the field var def }
+          p.propdef:=property_sym.propdef;
+
+          caller_sym:=default_property.propaccesslist[palt_read].firstsym^.sym;
+
+          { duplicate parameters and other options }
+          property_sym.makeduplicate(p,readprocdef,writeprocdef,paranr);
+
+          { getter }
+          if property_sym.propaccesslist[palt_read].firstsym<>nil then
+            begin
+              target_sym:=property_sym.propaccesslist[palt_read].firstsym^.sym;
+              case target_sym.typ of
+                fieldvarsym:
+                  begin
+                    build_field_symlist(p.propaccesslist[palt_read],caller_sym,target_sym,def);
+                    sym:=p.propaccesslist[palt_read].firstsym^.sym;
+                    p.add_getter_or_setter_for_sym(palt_read,sym,def,nil);
+                  end;
+                procsym:
+                  begin
+                    addsymref(target_sym);
+                    p.propaccesslist[palt_read].addsym(sl_call,target_sym);
+                    readprocdef.returndef:=p.propdef;
+                    { Insert hidden parameters }
+                    handle_calling_convention(readprocdef,hcc_default_actions_intf_struct);
+                    p.add_getter_or_setter_for_sym(palt_read,target_sym,nil,readprocdef);
+                  end;
+              end;
+            end
+          else
+            p.inherit_accessor(palt_read);
+
+          { setter }
+          if property_sym.propaccesslist[palt_write].firstsym<>nil then
+            begin
+              target_sym:=property_sym.propaccesslist[palt_write].firstsym^.sym;
+              case target_sym.typ of
+                fieldvarsym:
+                  begin
+                    build_field_symlist(p.propaccesslist[palt_write],caller_sym,target_sym,def);
+                    sym:=p.propaccesslist[palt_write].firstsym^.sym;
+                    p.add_getter_or_setter_for_sym(palt_write,sym,def,nil);
+                  end;
+                procsym:
+                  begin
+                    addsymref(target_sym);
+                    p.propaccesslist[palt_write].addsym(sl_call,target_sym);
+                    { setter is a procedure with an extra value parameter of the of the property }
+                    writeprocdef.returndef:=voidtype;
+                    // TODO: do we need to inc this again here?
+                    inc(paranr);
+                    hparavs:=cparavarsym.create('$value',10*paranr,vs_value,p.propdef,[]);
+                    writeprocdef.parast.insert(hparavs);
+                    { Insert hidden parameters }
+                    handle_calling_convention(writeprocdef,hcc_default_actions_intf_struct);
+                    p.add_getter_or_setter_for_sym(palt_write,target_sym,nil,writeprocdef);
+                  end;
+              end;
+            end
+          else
+            p.inherit_accessor(palt_write);
+
+          { register propgetter and propsetter procdefs }
+          if assigned(current_module) and current_module.in_interface then
+            begin
+              if readprocdef.proctypeoption=potype_propgetter then
+                readprocdef.register_def
+              else
+                readprocdef.free;
+              if writeprocdef.proctypeoption=potype_propsetter then
+                writeprocdef.register_def
+              else
+                writeprocdef.free;
+            end
+          else
+            begin
+              if readprocdef.proctypeoption=potype_propgetter then
+                readprocdef.maybe_put_in_symtable_stack
+              else
+                readprocdef.free;
+              if writeprocdef.proctypeoption=potype_propsetter then
+                writeprocdef.maybe_put_in_symtable_stack
+              else
+                writeprocdef.free;
+            end;
+        end;
+      
+      var
+        i: integer;
+        sym: tsym;
+        classh: tobjectdef;
+      begin
+
+        { default field must have read }
+        if default_property.propaccesslist[palt_read].firstsym=nil then
+          begin
+            // TODO: make a proper error (parser_e_default_field_must_be_readable)
+            Message(parser_e_illegal_expression);
+            exit;
+          end;
+
+        record_def.default_property:=default_property;
+        include(record_def.objectoptions,oo_implements_default_property);
+
+        { search in the class hierarchy for members to hoist }
+        classh:=tobjectdef(record_def.get_default_property_field);
+        while assigned(classh) do
+          begin
+            for i:=0 to classh.symtable.SymList.count-1 do
+              begin
+                sym:=tsym(classh.symtable.SymList[i]);
+                { ignore hidden members }
+                if sym.visibility=vis_hidden then
+                  continue;
+                { only consider members if they are visible to the property }
+                if is_visible_for_object(classh.symtable,default_property.visibility,record_def) then
+                  case sym.typ of
+                    fieldvarsym:
+                      insert_field_var(tfieldvarsym(sym));
+                    propertysym:
+                      insert_property(tpropertysym(sym));
+                    procsym:
+                      begin
+                        if record_def.default_property_symtable=nil then
+                          record_def.default_property_symtable:=tfphashobjectlist.create(false);
+                        record_def.default_property_symtable.add(sym.name,sym);
+                      end;
+                  end;
+              end;
+            classh:=classh.childof;
+          end;
+      end;
 
     procedure struct_property_dec(is_classproperty:boolean;var rtti_attrs_def: trtti_attribute_list);
       var
@@ -180,7 +398,13 @@ implementation
               message(parser_e_only_one_default_property);
             include(current_structdef.objectoptions,oo_has_default_property);
             include(p.propoptions,ppo_defaultproperty);
-            if not(ppo_hasparameters in p.propoptions) then
+            { implement default properties members into caller }
+            if (current_structdef.typ=recorddef) and ((p.propdef.typ=objectdef) or (p.propdef.typ=undefineddef)) then
+              begin
+                if not current_structdef.is_generic then
+                  implement_default_property(p,current_structdef);
+              end
+            else if not(ppo_hasparameters in p.propoptions) then
               message(parser_e_property_need_paras);
             if (token=_COLON) then
               begin
diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas
index 28483ebd95..b98f22b4dc 100644
--- a/compiler/pexpr.pas
+++ b/compiler/pexpr.pas
@@ -2435,6 +2435,13 @@ implementation
                              else
                                begin
                                  searchsym_in_record(structh,pattern,srsym,srsymtable);
+                                 { if nothing was found search default properties }
+                                 if not assigned(srsym) and 
+                                   (oo_implements_default_property in structh.objectoptions) and
+                                   searchsym_in_default_property(trecorddef(structh),pattern,srsym,srsymtable) then
+                                   begin
+                                     hoist_default_property(tpropertysym(structh.default_property),structh.symtable,p1);
+                                   end;
                                  consume(_ID);
                                  if handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then
                                    erroroutp1:=false;
@@ -2443,6 +2450,13 @@ implementation
                          else
                            begin
                              searchsym_in_record(structh,pattern,srsym,srsymtable);
+                             { if nothing was found search default properties }
+                             if not assigned(srsym) and 
+                               (oo_implements_default_property in structh.objectoptions) and
+                               searchsym_in_default_property(trecorddef(structh),pattern,srsym,srsymtable) then
+                               begin
+                                 hoist_default_property(tpropertysym(structh.default_property),structh.symtable,p1);
+                               end;
                              if assigned(srsym) then
                                begin
                                  old_current_filepos:=current_filepos;
diff --git a/compiler/symconst.pas b/compiler/symconst.pas
index aa97d73dc8..78d7092411 100644
--- a/compiler/symconst.pas
+++ b/compiler/symconst.pas
@@ -559,7 +559,8 @@ type
     oo_has_class_constructor, { the object/class has a class constructor }
     oo_has_class_destructor,  { the object/class has a class destructor  }
     oo_is_enum_class,     { the class represents an enum (JVM) }
-    oo_has_new_destructor { the object/class declares a destructor (apart from potentially inherting one from the parent) }
+    oo_has_new_destructor,{ the object/class declares a destructor (apart from potentially inherting one from the parent) }
+    oo_implements_default_property { the record implements a default property }
   );
   tobjectoptions=set of tobjectoption;
 
diff --git a/compiler/symdef.pas b/compiler/symdef.pas
index fca90803bf..1cba786e51 100644
--- a/compiler/symdef.pas
+++ b/compiler/symdef.pas
@@ -339,6 +339,12 @@ interface
           { for targets that initialise typed constants via explicit assignments
             instead of by generating an initialised data sectino }
           tcinitcode     : tnode;
+          { default property }
+          { TODO: how do we write these types to PPU?
+             or should we build these on demand,
+             or re-search for every proc call (slow!)? }
+          default_property : tsym;
+          default_property_symtable : tfphashobjectlist;
           constructor create(const n:string; dt:tdeftyp;doregister:boolean);
           constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
           procedure ppuwrite(ppufile:tcompilerppufile);override;
@@ -360,6 +366,7 @@ interface
           function contains_float_field : boolean;
           { check if the symtable contains a field that spans an aword boundary }
           function contains_cross_aword_field: boolean;
+          function get_default_property_field: tabstractrecorddef;
        end;
 
        pvariantrecdesc = ^tvariantrecdesc;
@@ -4565,6 +4572,7 @@ implementation
         stringdispose(objrealname);
         stringdispose(import_lib);
         tcinitcode.free;
+        freeandnil(default_property_symtable);
         inherited destroy;
       end;
 
@@ -4756,6 +4764,9 @@ implementation
               end;
             end;
           end;
+        { nothing was found so search in default property next }
+        if get_default_property_field<>nil then
+          result:=get_default_property_field.search_enumerator_get;
       end;
 
     function tabstractrecorddef.search_enumerator_move: tprocdef;
@@ -4798,6 +4809,9 @@ implementation
               end;
             end;
           end;
+        { nothing was found so search in default property next }
+        if get_default_property_field<>nil then
+          result:=get_default_property_field.search_enumerator_move;
       end;
 
     function tabstractrecorddef.search_enumerator_current: tsym;
@@ -4826,6 +4840,9 @@ implementation
             result:=sym;
             exit;
           end;
+        { nothing was found so search in default property next }
+        if get_default_property_field<>nil then
+          result:=get_default_property_field.search_enumerator_current;
       end;
 
 
@@ -4928,6 +4945,15 @@ implementation
         result:=false;
       end;
 
+
+    function tabstractrecorddef.get_default_property_field: tabstractrecorddef;
+      begin
+        if default_property<>nil then
+          result:=tabstractrecorddef(tpropertysym(default_property).propdef)
+        else
+          result:=nil;
+      end;
+
 {$ifdef DEBUG_NODE_XML}
     procedure tabstractrecorddef.XMLPrintDefData(var T: Text; Sym: TSym);
 
diff --git a/compiler/symtable.pas b/compiler/symtable.pas
index 8117af72f7..2505e363b7 100644
--- a/compiler/symtable.pas
+++ b/compiler/symtable.pas
@@ -354,6 +354,7 @@ interface
     function  searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
     function  searchsym_in_class(classh: tobjectdef; contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
     function  searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
+    function  searchsym_in_default_property(recordh:trecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
     { searches symbols inside of a helper's implementation }
@@ -3833,6 +3834,34 @@ implementation
         srsymtable:=nil;
       end;
 
+    function  searchsym_in_default_property(recordh:trecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
+      var
+        hashedid : THashedIDString;
+      begin
+        result:=false;
+        // todo: should be an internal error instead?
+        if not (oo_implements_default_property in recordh.objectoptions) then
+          exit;
+        hashedid.id:=s;
+        if recordh.default_property_symtable<>nil then
+          begin
+            srsym:=tsym(recordh.default_property_symtable.FindWithHash(hashedid.id,hashedid.hash));
+            if assigned(srsym) then
+              begin
+                srsymtable:=srsym.owner;
+                addsymref(srsym);
+                result:=true;
+                exit;
+              end;
+          end;
+        { if nothing is found then search class helpers for the property }
+        result:=search_objectpascal_helper(recordh.get_default_property_field,recordh.get_default_property_field,s,srsym,srsymtable);
+        if result then
+          exit;
+        srsym:=nil;
+        srsymtable:=nil;
+      end;
+
     function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
       var
         def : tdef;
patch-2.diff (22,574 bytes)   

Ryan Joseph

2021-05-16 17:27

reporter   ~0130921

Last change I think is to prevent hoisting default fields using implicit self. This is because the feature is really only intended to facilitate smart pointers which hoist members to the outside caller. Supporting implicit self complicates the design slightly and adds extra vectors for confusion for no real gain because you reference the default field using the property name anyways.

I also added a number of tests in a zip file. So, if this is considered the only thing left to do is add support in PPUDump and implement the PPU loading (if that's how it's decided we go).
tests.zip (15,112 bytes)
patch-3.diff (31,876 bytes)   
diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas
index 0d0e6f4aba..740c8c694b 100644
--- a/compiler/htypechk.pas
+++ b/compiler/htypechk.pas
@@ -80,14 +80,14 @@ interface
         FParaNode   : tnode;
         FParaLength : smallint;
         FAllowVariant : boolean;
-        procedure collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext);
+        procedure collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers,anoninherited,implicitself:boolean;spezcontext:tspecializationcontext);
         procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall,explicitunit: boolean;spezcontext:tspecializationcontext);
-        procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext);
+        procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited,implicitself:boolean;spezcontext:tspecializationcontext);
         procedure calc_distance(st_root:tsymtable;objcidcall: boolean);
         function  proc_add(st:tsymtable;pd:tprocdef;objcidcall: boolean):pcandidate;
         function  maybe_specialize(var pd:tprocdef;spezcontext:tspecializationcontext):boolean;
       public
-        constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext);
+        constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited,implicitself:boolean;spezcontext:tspecializationcontext);
         constructor create_operator(op:ttoken;ppn:tnode);
         destructor destroy;override;
         procedure list(all:boolean);
@@ -2175,7 +2175,7 @@ implementation
                            TCallCandidates
 ****************************************************************************}
 
-    constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext);
+    constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited,implicitself:boolean;spezcontext:tspecializationcontext);
       begin
         if not assigned(sym) then
           internalerror(200411015);
@@ -2184,7 +2184,7 @@ implementation
         FProcsymtable:=st;
         FParanode:=ppn;
         FIgnoredCandidateProcs:=tfpobjectlist.create(false);
-        create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited,spezcontext);
+        create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited,implicitself,spezcontext);
       end;
 
 
@@ -2195,7 +2195,7 @@ implementation
         FProcsymtable:=nil;
         FParanode:=ppn;
         FIgnoredCandidateProcs:=tfpobjectlist.create(false);
-        create_candidate_list(false,false,false,false,false,false,nil);
+        create_candidate_list(false,false,false,false,false,false,false,nil);
       end;
 
 
@@ -2232,7 +2232,7 @@ implementation
       end;
 
 
-    procedure tcallcandidates.collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext);
+    procedure tcallcandidates.collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers,anoninherited,implicitself:boolean;spezcontext:tspecializationcontext);
 
       var
         changedhierarchy : boolean;
@@ -2369,11 +2369,26 @@ implementation
               (srsym.typ=procsym) then
              begin
                hasoverload:=processprocsym(tprocsym(srsym),foundanything);
+               { if the struct implements default properties then don't break yet 
+                 so we can add any additional overloads that may exist }
+               if not implicitself and (oo_implements_default_property in structdef.objectoptions) then
+                 foundanything:=false;
                { when there is no explicit overload we stop searching }
                if foundanything and
                   not hasoverload then
                  break;
              end;
+           { now add additional overloads for default property }
+           if not implicitself and (oo_implements_default_property in structdef.objectoptions) then
+             begin
+               srsym:=tsym(structdef.default_property_symtable.FindWithHash(hashedid.id,hashedid.hash));
+               if assigned(srsym) then
+                 begin
+                   hasoverload:=processprocsym(tprocsym(srsym),foundanything);
+                   if foundanything and not hasoverload then
+                     break;
+                 end;
+             end;
            if is_objectpascal_helper(structdef) and
               (
                 (tobjectdef(structdef).extendeddef.typ=recorddef) or
@@ -2500,7 +2515,7 @@ implementation
       end;
 
 
-    procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext);
+    procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited,implicitself:boolean;spezcontext:tspecializationcontext);
       var
         j     : integer;
         pd    : tprocdef;
@@ -2520,7 +2535,7 @@ implementation
         if not objcidcall and
            (FOperator=NOTOKEN) and
            (FProcsym.owner.symtabletype in [objectsymtable,recordsymtable]) then
-          collect_overloads_in_struct(tabstractrecorddef(FProcsym.owner.defowner),ProcdefOverloadList,searchhelpers,anoninherited,spezcontext)
+          collect_overloads_in_struct(tabstractrecorddef(FProcsym.owner.defowner),ProcdefOverloadList,searchhelpers,anoninherited,implicitself,spezcontext)
         else
         if (FOperator<>NOTOKEN) then
           begin
@@ -2531,7 +2546,7 @@ implementation
               begin
                 if (pt.resultdef.typ=recorddef) and
                     (sto_has_operator in tabstractrecorddef(pt.resultdef).symtable.tableoptions) then
-                  collect_overloads_in_struct(tabstractrecorddef(pt.resultdef),ProcdefOverloadList,searchhelpers,anoninherited,spezcontext);
+                  collect_overloads_in_struct(tabstractrecorddef(pt.resultdef),ProcdefOverloadList,searchhelpers,anoninherited,implicitself,spezcontext);
                 pt:=tcallparanode(pt.right);
               end;
             collect_overloads_in_units(ProcdefOverloadList,objcidcall,explicitunit,spezcontext);
diff --git a/compiler/ncal.pas b/compiler/ncal.pas
index d1c4c37cbe..2ca8f344e6 100644
--- a/compiler/ncal.pas
+++ b/compiler/ncal.pas
@@ -57,7 +57,8 @@ interface
          cnf_call_self_node_done,{ the call_self_node has been generated if necessary
                                    (to prevent it from potentially happening again in a wrong context in case of constant propagation or so) }
          cnf_ignore_visibility,  { internally generated call that should ignore visibility checks }
-         cnf_check_fpu_exceptions { after the call fpu exceptions shall be checked }
+         cnf_check_fpu_exceptions, { after the call fpu exceptions shall be checked }
+         cnf_implicit_self       { the call originated from an implicit self block }
        );
        tcallnodeflags = set of tcallnodeflag;
 
@@ -3738,7 +3739,8 @@ implementation
                                      (cnf_ignore_visibility in callnodeflags);
                    candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility,
                      not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags,
-                     callnodeflags*[cnf_anon_inherited,cnf_inherited]=[],cnf_anon_inherited in callnodeflags,spezcontext);
+                     callnodeflags*[cnf_anon_inherited,cnf_inherited]=[],cnf_anon_inherited in callnodeflags,
+                     cnf_implicit_self in callnodeflags,spezcontext);
 
                    { no procedures found? then there is something wrong
                      with the parameter size or the procedures are
diff --git a/compiler/nflw.pas b/compiler/nflw.pas
index 870d23ebed..2e363cc58a 100644
--- a/compiler/nflw.pas
+++ b/compiler/nflw.pas
@@ -975,7 +975,15 @@ implementation
                             MessagePos1(expr.fileinfo,sym_e_no_enumerator_current,pd.returndef.typename);
                           end
                         else
-                          result:=create_enumerator_for_in_loop(hloopvar, hloopbody, expr, pd, movenext, current);
+                          begin
+                            if (expr.resultdef.typ=recorddef) and (oo_implements_default_property in tabstractrecorddef(expr.resultdef).objectoptions) then
+                              begin
+                                hoist_default_property(tpropertysym(tabstractrecorddef(expr.resultdef).default_property),tabstractrecorddef(expr.resultdef).symtable,expr);
+                                if expr.resultdef = nil then
+                                  do_typecheckpass(expr);
+                              end;
+                            result:=create_enumerator_for_in_loop(hloopvar, hloopbody, expr, pd, movenext, current);
+                          end;
                       end;
                   end
                 else
diff --git a/compiler/nutils.pas b/compiler/nutils.pas
index be76d4cf71..ba5c5efad7 100644
--- a/compiler/nutils.pas
+++ b/compiler/nutils.pas
@@ -112,6 +112,8 @@ interface
     procedure propaccesslist_to_node(var p1:tnode;st:TSymtable;pl:tpropaccesslist);
     function node_to_propaccesslist(p1:tnode):tpropaccesslist;
 
+    procedure hoist_default_property(propsym:tpropertysym; st:tsymtable; var p1:tnode);
+
     { checks whether sym is a static field and if so, translates the access
       to the appropriate node tree }
     function handle_staticfield_access(sym: tsym; var p1: tnode): boolean;
@@ -1230,6 +1232,26 @@ implementation
       end;
 
 
+    procedure hoist_default_property(propsym:tpropertysym; st:tsymtable; var p1:tnode);
+      var
+        propaccesslist: tpropaccesslist;
+        sym: tsym;
+      begin
+        if propsym.getpropaccesslist(palt_read,propaccesslist) then
+          begin
+           sym:=propaccesslist.firstsym^.sym;
+           case sym.typ of
+             fieldvarsym :
+               begin
+                 { generate access code }
+                 if not handle_staticfield_access(sym,p1) then
+                   propaccesslist_to_node(p1,st,propaccesslist);
+               end;
+            end;
+          end;
+      end;
+
+
     function node_to_propaccesslist(p1:tnode):tpropaccesslist;
       var
         sl : tpropaccesslist;
diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas
index b490cd18f3..1bb429d473 100644
--- a/compiler/pdecobj.pas
+++ b/compiler/pdecobj.pas
@@ -161,6 +161,234 @@ implementation
         result:=pd;
       end;
 
+    procedure implement_default_property(default_property:tpropertysym; record_def:tabstractrecorddef);
+      
+      { builds the property symbol access list for fields }
+      function build_field_symlist(pl:tpropaccesslist; caller_sym:tsym; target_sym:tsym; out def:tdef):boolean; inline;
+        begin
+          { add caller }
+          addsymref(caller_sym);
+          pl.addsym(sl_load,caller_sym);
+          { add target }
+          addsymref(target_sym);
+          pl.addsym(sl_subscript,target_sym);
+          def:=tfieldvarsym(target_sym).vardef;
+        end;
+
+      procedure insert_field_var(fieldvar: tfieldvarsym);
+        var
+          p: tpropertysym;
+          sym: tsym;
+          def: tdef;
+        begin
+          { generate propertysym and insert in symtablestack }
+          p:=cpropertysym.create(fieldvar.realname);
+          p.visibility:=symtablestack.top.currentvisibility;
+          p.default:=longint($80000000);
+          include(p.propoptions, ppo_default_field);
+
+          { insert the property symbol into the symtable
+            this is where the duplicate symbol message will be given if there
+            is a duplicate field in the current record. }
+          symtablestack.top.insert(p);
+          
+          { set property def to be the field var def }
+          p.propdef:=fieldvar.vardef;
+
+          { make getter }
+          sym:=default_property.propaccesslist[palt_read].firstsym^.sym;
+          build_field_symlist(p.propaccesslist[palt_read],sym,fieldvar,def);
+          sym:=p.propaccesslist[palt_read].firstsym^.sym;
+          p.add_getter_or_setter_for_sym(palt_read,sym,def,nil);
+
+          { make setter }
+          sym:=default_property.propaccesslist[palt_read].firstsym^.sym;
+          build_field_symlist(p.propaccesslist[palt_write],sym,fieldvar,def);
+          sym:=p.propaccesslist[palt_write].firstsym^.sym;
+          p.add_getter_or_setter_for_sym(palt_write,sym,def,nil);
+        end;
+      
+      procedure insert_property(property_sym: tpropertysym); 
+        var
+          p: tpropertysym;
+          readprocdef,
+          writeprocdef: tprocdef;
+          hparavs: tparavarsym;
+          paranr: word;
+          sym,
+          caller_sym,
+          target_sym: tsym;
+          def: tdef;
+        begin
+          paranr := 0;
+
+          { Generate temp procdefs to search for matching read/write
+            procedures. the readprocdef will store all definitions }
+          readprocdef:=cprocdef.create(normal_function_level,false);
+          writeprocdef:=cprocdef.create(normal_function_level,false);
+
+          readprocdef.struct:=record_def;
+          writeprocdef.struct:=record_def;
+
+          { class property? }
+          if assigned(record_def) and (sp_static in property_sym.symoptions) then
+            begin
+              readprocdef.procoptions:=[po_staticmethod,po_classmethod];
+              writeprocdef.procoptions:=[po_staticmethod,po_classmethod];
+            end;
+
+          { generate propertysym and insert in symtablestack }
+          p:=cpropertysym.create(property_sym.realname);
+          p.visibility:=symtablestack.top.currentvisibility;
+          p.default:=longint($80000000);
+
+          { insert the property symbol into the symtable
+            this is where the duplicate symbol message will be given if there
+            is a duplicate field in the current record. }
+          symtablestack.top.insert(p);
+          
+          { set property def to be the field var def }
+          p.propdef:=property_sym.propdef;
+
+          caller_sym:=default_property.propaccesslist[palt_read].firstsym^.sym;
+
+          { duplicate parameters and other options }
+          property_sym.makeduplicate(p,readprocdef,writeprocdef,paranr);
+
+          { getter }
+          if property_sym.propaccesslist[palt_read].firstsym<>nil then
+            begin
+              target_sym:=property_sym.propaccesslist[palt_read].firstsym^.sym;
+              case target_sym.typ of
+                fieldvarsym:
+                  begin
+                    build_field_symlist(p.propaccesslist[palt_read],caller_sym,target_sym,def);
+                    sym:=p.propaccesslist[palt_read].firstsym^.sym;
+                    p.add_getter_or_setter_for_sym(palt_read,sym,def,nil);
+                  end;
+                procsym:
+                  begin
+                    addsymref(target_sym);
+                    p.propaccesslist[palt_read].addsym(sl_call,target_sym);
+                    readprocdef.returndef:=p.propdef;
+                    { Insert hidden parameters }
+                    handle_calling_convention(readprocdef,hcc_default_actions_intf_struct);
+                    p.add_getter_or_setter_for_sym(palt_read,target_sym,nil,readprocdef);
+                  end;
+              end;
+            end
+          else
+            p.inherit_accessor(palt_read);
+
+          { setter }
+          if property_sym.propaccesslist[palt_write].firstsym<>nil then
+            begin
+              target_sym:=property_sym.propaccesslist[palt_write].firstsym^.sym;
+              case target_sym.typ of
+                fieldvarsym:
+                  begin
+                    build_field_symlist(p.propaccesslist[palt_write],caller_sym,target_sym,def);
+                    sym:=p.propaccesslist[palt_write].firstsym^.sym;
+                    p.add_getter_or_setter_for_sym(palt_write,sym,def,nil);
+                  end;
+                procsym:
+                  begin
+                    addsymref(target_sym);
+                    p.propaccesslist[palt_write].addsym(sl_call,target_sym);
+                    { setter is a procedure with an extra value parameter of the of the property }
+                    writeprocdef.returndef:=voidtype;
+                    // TODO: do we need to inc this again here?
+                    inc(paranr);
+                    hparavs:=cparavarsym.create('$value',10*paranr,vs_value,p.propdef,[]);
+                    writeprocdef.parast.insert(hparavs);
+                    { Insert hidden parameters }
+                    handle_calling_convention(writeprocdef,hcc_default_actions_intf_struct);
+                    p.add_getter_or_setter_for_sym(palt_write,target_sym,nil,writeprocdef);
+                  end;
+              end;
+            end
+          else
+            p.inherit_accessor(palt_write);
+
+          { flag the property as a default field }
+          include(p.propoptions, ppo_default_field);
+
+          { register propgetter and propsetter procdefs }
+          if assigned(current_module) and current_module.in_interface then
+            begin
+              if readprocdef.proctypeoption=potype_propgetter then
+                readprocdef.register_def
+              else
+                readprocdef.free;
+              if writeprocdef.proctypeoption=potype_propsetter then
+                writeprocdef.register_def
+              else
+                writeprocdef.free;
+            end
+          else
+            begin
+              if readprocdef.proctypeoption=potype_propgetter then
+                readprocdef.maybe_put_in_symtable_stack
+              else
+                readprocdef.free;
+              if writeprocdef.proctypeoption=potype_propsetter then
+                writeprocdef.maybe_put_in_symtable_stack
+              else
+                writeprocdef.free;
+            end;
+        end;
+      
+      var
+        i: integer;
+        sym: tsym;
+        classh: tobjectdef;
+      begin
+
+        { default field must have read }
+        if default_property.propaccesslist[palt_read].firstsym=nil then
+          begin
+            // TODO: make a proper error (parser_e_default_field_must_be_readable)
+            Message(parser_e_illegal_expression);
+            exit;
+          end;
+
+        record_def.default_property:=default_property;
+        include(record_def.objectoptions,oo_implements_default_property);
+
+        { search in the class hierarchy for members to hoist }
+        classh:=tobjectdef(record_def.get_default_property_field);
+        while assigned(classh) do
+          begin
+            for i:=0 to classh.symtable.SymList.count-1 do
+              begin
+                sym:=tsym(classh.symtable.SymList[i]);
+                { ignore hidden members }
+                if sym.visibility=vis_hidden then
+                  continue;
+                { only consider members if they are visible to the property }
+                if is_visible_for_object(classh.symtable,default_property.visibility,record_def) then
+                  case sym.typ of
+                    fieldvarsym:
+                      insert_field_var(tfieldvarsym(sym));
+                    propertysym:
+                      begin
+                        { the property already exists so we simply skip it
+                          in order to keep precedence of the last-wins. }
+                        if record_def.symtable.find(sym.name)<>nil then
+                          continue;
+                        insert_property(tpropertysym(sym));
+                      end;
+                    procsym:
+                      begin
+                        if record_def.default_property_symtable=nil then
+                          record_def.default_property_symtable:=tfphashobjectlist.create(false);
+                        record_def.default_property_symtable.add(sym.name,sym);
+                      end;
+                  end;
+              end;
+            classh:=classh.childof;
+          end;
+      end;
 
     procedure struct_property_dec(is_classproperty:boolean;var rtti_attrs_def: trtti_attribute_list);
       var
@@ -180,7 +408,13 @@ implementation
               message(parser_e_only_one_default_property);
             include(current_structdef.objectoptions,oo_has_default_property);
             include(p.propoptions,ppo_defaultproperty);
-            if not(ppo_hasparameters in p.propoptions) then
+            { implement default properties members into caller }
+            if (current_structdef.typ=recorddef) and ((p.propdef.typ=objectdef) or (p.propdef.typ=undefineddef)) then
+              begin
+                if not current_structdef.is_generic then
+                  implement_default_property(p,current_structdef);
+              end
+            else if not(ppo_hasparameters in p.propoptions) then
               message(parser_e_property_need_paras);
             if (token=_COLON) then
               begin
diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas
index 28483ebd95..89d9fb0fc7 100644
--- a/compiler/pexpr.pas
+++ b/compiler/pexpr.pas
@@ -2435,6 +2435,13 @@ implementation
                              else
                                begin
                                  searchsym_in_record(structh,pattern,srsym,srsymtable);
+                                 { if nothing was found search default properties }
+                                 if not assigned(srsym) and 
+                                   (oo_implements_default_property in structh.objectoptions) and
+                                   searchsym_in_default_property(trecorddef(structh),pattern,srsym,srsymtable) then
+                                   begin
+                                     hoist_default_property(tpropertysym(structh.default_property),structh.symtable,p1);
+                                   end;
                                  consume(_ID);
                                  if handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then
                                    erroroutp1:=false;
@@ -2443,6 +2450,13 @@ implementation
                          else
                            begin
                              searchsym_in_record(structh,pattern,srsym,srsymtable);
+                             { if nothing was found search default properties }
+                             if not assigned(srsym) and 
+                               (oo_implements_default_property in structh.objectoptions) and
+                               searchsym_in_default_property(trecorddef(structh),pattern,srsym,srsymtable) then
+                               begin
+                                 hoist_default_property(tpropertysym(structh.default_property),structh.symtable,p1);
+                               end;
                              if assigned(srsym) then
                                begin
                                  old_current_filepos:=current_filepos;
@@ -3344,7 +3358,9 @@ implementation
                         { withsymtable as well                          }
                         if (srsym.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
                           begin
-                            do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,[],spezcontext);
+                            { implicit self call }
+                            callflags:=[cnf_implicit_self];
+                            do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,callflags,spezcontext);
                             spezcontext:=nil;
                           end
                         else
@@ -3373,6 +3389,10 @@ implementation
                 propertysym :
                   begin
                     p1:=nil;
+                    { default fields must be referenced by subscripting only }
+                    // TODO: make a real error?
+                    if ppo_default_field in tpropertysym(srsym).propoptions then
+                      Message1(sym_e_id_not_found, srsym.realname);
                     { property of a class/object? }
                     if is_member_read(srsym,srsymtable,p1,hdef) then
                       begin
diff --git a/compiler/symconst.pas b/compiler/symconst.pas
index aa97d73dc8..26db20a30a 100644
--- a/compiler/symconst.pas
+++ b/compiler/symconst.pas
@@ -559,7 +559,8 @@ type
     oo_has_class_constructor, { the object/class has a class constructor }
     oo_has_class_destructor,  { the object/class has a class destructor  }
     oo_is_enum_class,     { the class represents an enum (JVM) }
-    oo_has_new_destructor { the object/class declares a destructor (apart from potentially inherting one from the parent) }
+    oo_has_new_destructor,{ the object/class declares a destructor (apart from potentially inherting one from the parent) }
+    oo_implements_default_property { the record implements a default property }
   );
   tobjectoptions=set of tobjectoption;
 
@@ -587,7 +588,8 @@ type
     ppo_implements,
     ppo_enumerator_current,       { implements current property for enumerator }
     ppo_overrides,                { overrides ancestor property }
-    ppo_dispid_write              { no longer used }
+    ppo_dispid_write,             { no longer used }
+    ppo_default_field             { default field property }
   );
   tpropertyoptions=set of tpropertyoption;
 
diff --git a/compiler/symdef.pas b/compiler/symdef.pas
index fca90803bf..1cba786e51 100644
--- a/compiler/symdef.pas
+++ b/compiler/symdef.pas
@@ -339,6 +339,12 @@ interface
           { for targets that initialise typed constants via explicit assignments
             instead of by generating an initialised data sectino }
           tcinitcode     : tnode;
+          { default property }
+          { TODO: how do we write these types to PPU?
+             or should we build these on demand,
+             or re-search for every proc call (slow!)? }
+          default_property : tsym;
+          default_property_symtable : tfphashobjectlist;
           constructor create(const n:string; dt:tdeftyp;doregister:boolean);
           constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
           procedure ppuwrite(ppufile:tcompilerppufile);override;
@@ -360,6 +366,7 @@ interface
           function contains_float_field : boolean;
           { check if the symtable contains a field that spans an aword boundary }
           function contains_cross_aword_field: boolean;
+          function get_default_property_field: tabstractrecorddef;
        end;
 
        pvariantrecdesc = ^tvariantrecdesc;
@@ -4565,6 +4572,7 @@ implementation
         stringdispose(objrealname);
         stringdispose(import_lib);
         tcinitcode.free;
+        freeandnil(default_property_symtable);
         inherited destroy;
       end;
 
@@ -4756,6 +4764,9 @@ implementation
               end;
             end;
           end;
+        { nothing was found so search in default property next }
+        if get_default_property_field<>nil then
+          result:=get_default_property_field.search_enumerator_get;
       end;
 
     function tabstractrecorddef.search_enumerator_move: tprocdef;
@@ -4798,6 +4809,9 @@ implementation
               end;
             end;
           end;
+        { nothing was found so search in default property next }
+        if get_default_property_field<>nil then
+          result:=get_default_property_field.search_enumerator_move;
       end;
 
     function tabstractrecorddef.search_enumerator_current: tsym;
@@ -4826,6 +4840,9 @@ implementation
             result:=sym;
             exit;
           end;
+        { nothing was found so search in default property next }
+        if get_default_property_field<>nil then
+          result:=get_default_property_field.search_enumerator_current;
       end;
 
 
@@ -4928,6 +4945,15 @@ implementation
         result:=false;
       end;
 
+
+    function tabstractrecorddef.get_default_property_field: tabstractrecorddef;
+      begin
+        if default_property<>nil then
+          result:=tabstractrecorddef(tpropertysym(default_property).propdef)
+        else
+          result:=nil;
+      end;
+
 {$ifdef DEBUG_NODE_XML}
     procedure tabstractrecorddef.XMLPrintDefData(var T: Text; Sym: TSym);
 
diff --git a/compiler/symtable.pas b/compiler/symtable.pas
index 8117af72f7..2505e363b7 100644
--- a/compiler/symtable.pas
+++ b/compiler/symtable.pas
@@ -354,6 +354,7 @@ interface
     function  searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
     function  searchsym_in_class(classh: tobjectdef; contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
     function  searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
+    function  searchsym_in_default_property(recordh:trecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
     { searches symbols inside of a helper's implementation }
@@ -3833,6 +3834,34 @@ implementation
         srsymtable:=nil;
       end;
 
+    function  searchsym_in_default_property(recordh:trecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
+      var
+        hashedid : THashedIDString;
+      begin
+        result:=false;
+        // todo: should be an internal error instead?
+        if not (oo_implements_default_property in recordh.objectoptions) then
+          exit;
+        hashedid.id:=s;
+        if recordh.default_property_symtable<>nil then
+          begin
+            srsym:=tsym(recordh.default_property_symtable.FindWithHash(hashedid.id,hashedid.hash));
+            if assigned(srsym) then
+              begin
+                srsymtable:=srsym.owner;
+                addsymref(srsym);
+                result:=true;
+                exit;
+              end;
+          end;
+        { if nothing is found then search class helpers for the property }
+        result:=search_objectpascal_helper(recordh.get_default_property_field,recordh.get_default_property_field,s,srsym,srsymtable);
+        if result then
+          exit;
+        srsym:=nil;
+        srsymtable:=nil;
+      end;
+
     function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
       var
         def : tdef;
patch-3.diff (31,876 bytes)   

Issue History

Date Modified Username Field Change
2021-05-10 20:18 Ryan Joseph New Issue
2021-05-10 20:18 Ryan Joseph File Added: patch.diff
2021-05-10 20:26 Ryan Joseph Note Added: 0130813
2021-05-14 20:33 Ryan Joseph Note Added: 0130878
2021-05-14 20:33 Ryan Joseph File Added: patch-2.diff
2021-05-16 17:27 Ryan Joseph Note Added: 0130921
2021-05-16 17:27 Ryan Joseph File Added: tests.zip
2021-05-16 17:27 Ryan Joseph File Added: patch-3.diff