* interfaces basically running

rtl/i386/i386.inc

@@ -1117,7 +1117,6 @@ end;
 {$ifdef SYSTEMDEBUG}
 end;
 {$endif def SYSTEMDEBUG}
-{$ifdef HASINTF}
 { do a thread save inc/dec }
 
 procedure declocked(var l : longint);assembler;
@@ -1158,11 +1157,12 @@ procedure inclocked(var l : longint);assembler;
 .Linclockedend:
   end ['EDI'];
 
-{$endif HASINTF}
-
 {
   $Log$
-  Revision 1.4  2000-11-07 23:42:21  florian
+  Revision 1.5  2000-11-12 23:23:34  florian
+    * interfaces basically running
+
+  Revision 1.4  2000/11/07 23:42:21  florian
     + AfterConstruction and BeforeDestruction implemented
     + TInterfacedObject implemented
 

rtl/inc/dynarr.inc

@@ -16,6 +16,10 @@
  **********************************************************************
 }
 
+procedure FinalizeArray(data,typeinfo : pointer;count,size : longint);forward;
+Procedure Addref (Data,TypeInfo : Pointer);forward;
+Procedure int_finalize (Data,TypeInfo: Pointer);forward;
+
 type
    tdynarrayindex = longint;
    pdynarrayindex = ^tdynarrayindex;
@@ -23,39 +27,73 @@ type
 
    { don't add new fields, the size is used }
    { to calculate memory requirements       }
-   tdynarray = record
+   pdynarray = ^tdynarray;
+   tdynarray = packed record
       refcount : dword;
       high : tdynarrayindex;
    end;
 
-   pdynarray = ^tdynarray;
+   pdynarraytypeinfo = ^tdynarraytypeinfo;
-   pdynarraytypeinfo = packed record
+   tdynarraytypeinfo = packed record
       kind : byte;
       namelen : byte;
-      // here the chars follow, we've to skip them
+      { here the chars follow, we've to skip them }
       elesize : t_size;
       eletype : pdynarraytypeinfo;
    end;
 
-function dynarray_length(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_LENGTH'];
 
+function dynarray_length(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_LENGTH'];
   begin
      dynarray_length:=pdynarray(p-sizeof(tdynarray))^.high+1;
   end;
 
+
 function dynarray_high(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_HIGH'];
-
   begin
-//!!!!!!!     dynarray_length:=pdynarray(p-sizeof(tdynarray))^.high;
+     dynarray_high:=pdynarray(p-sizeof(tdynarray))^.high;
   end;
 
-procedure dynarray_decr_ref(var p : pointer);[Public,Alias:'FPC_DYNARRAY_DECR_REF'];
 
+{ releases and finalizes the data of a dyn. array and sets p to nil }
+procedure dynarray_clear(var p : pdynarray;ti : pdynarraytypeinfo);
   begin
+     { skip kind and name }
+     inc(pointer(ti),ord(ti^.namelen));
+
+     { finalize all data }
+     finalizearray(p,ti^.eletype,p^.high+1,ti^.elesize);
+
+     { release the data }
+     freemem(p,sizeof(tdynarray)+p^.high+1*ti^.elesize);
+     p:=nil;
   end;
 
-procedure dynarray_setlength(var p : pointer;ti : pdynarraytypeinfo;
+
-  dimcount : dword;dims : pdynarrayindex);[Public,Alias:'FPC_DYNARRAY_SETLENGTH'];
+procedure dynarray_decr_ref(var p : pointer;ti : pdynarraytypeinfo);[Public,Alias:'FPC_DYNARRAY_DECR_REF'];
+  var
+     realp : pdynarray;
+  begin
+     if p=nil then
+       exit;
+
+     realp:=pdynarray(p-sizeof(tdynarray));
+     if realp^.refcount=0 then
+       HandleErrorFrame(204,get_frame);
+
+     { this isn't MT safe! }
+     { decr. ref. count }
+     declocked(realp^.refcount);
+
+     { should we remove the array? }
+     if realp^.refcount=0 then
+       dynarray_clear(realp,ti);
+     p:=nil;
+  end;
+
+
+procedure dynarray_setlength(var p : pointer;pti : pdynarraytypeinfo;
+  dimcount : dword;dims : pdynarrayindex);[Public,Alias:'FPC_DYNARR_SETLENGTH'];
 
   var
      i : tdynarrayindex;
@@ -63,76 +101,111 @@ procedure dynarray_setlength(var p : pointer;ti : pdynarraytypeinfo;
      { contains the "fixed" pointers where the refcount }
      { and high are at positive offsets                 }
      realp,newp : pdynarray;
+     ti : pdynarraytypeinfo;
 
   begin
-(* !!!!!!
+     ti:=pti;
-     realp:=pdynarray(p-sizeof(tdynarray));
+     { skip kind and name }
-     if dims[0]<0 then
+     inc(pointer(ti),ord(ti^.namelen));
-       HandleErrorFrame(201,get_frame);
-     if dims[0]=0 then
-       begin
-          { release all data }
-          !!!!!
-          p:=nil;
-          exit;
-       end;
-     if dims[0]<>realp^.high+1 then
-       begin
-          { determine new memory size }
-          size:=ti.elesize*dims[0]+sizeof(tdynarray);
 
-          { range checking is quite difficult ... }
+     { determine new memory size }
-          if (size<sizeof(tdynarray)) or
+     size:=ti^.elesize*dims[0]+sizeof(tdynarray);
-            ((ti.elesize>0) and (size<ti.elesize)) then
+
+     { not assigned yet? }
+     if not(assigned(p)) then
+       begin
+          getmem(newp,size);
+          fillchar(newp^,size,0);
+       end
+     else
+       begin
+          realp:=pdynarray(p-sizeof(tdynarray));
+
+          if dims[0]<0 then
             HandleErrorFrame(201,get_frame);
 
-          { skip kind and name }
+          { if the new dimension is 0, we've to release all data }
-          inc(pointer(ti),ord(ti.namelen));
+          if dims[0]=0 then
-
-          { resize? }
-          if realp.refcount=1 then
             begin
-               { shrink the array? }
+               dynarray_clear(realp,pti);
-               if dims[0]<realp^.high+1 then
+               p:=nil;
+               exit;
+            end;
+
+          if realp^.refcount<>1 then
+            begin
+               { make an unique copy }
+               getmem(newp,size);
+               move(p^,(newp+sizeof(tdynarray))^,ti^.elesize*dims[0]);
+
+               { increment ref. count of members }
+               for i:=0 to dims[0]-1 do
+                 addref(newp+sizeof(tdynarray)+ti^.elesize*i,ti^.eletype);
+
+               { a declock(ref. count) isn't enough here }
+               { it could be that the in MT enviroments  }
+               { in the mean time the refcount was       }
+               { decremented                             }
+               dynarray_decr_ref(p,ti);
+            end
+          else if dims[0]<>realp^.high+1 then
+            begin
+
+               { range checking is quite difficult ...  }
+               { if size overflows then it is less than }
+               { the values it was calculated from      }
+               if (size<sizeof(tdynarray)) or
+                 ((ti^.elesize>0) and (size<ti^.elesize)) then
+                 HandleErrorFrame(201,get_frame);
+
+               { resize? }
+               if realp^.refcount=1 then
                  begin
-                    for i:=dims[0]-1 to realp^.high do
+                    { shrink the array? }
-                       finalize(,ti^.eletype);
+                    if dims[0]<realp^.high+1 then
-                    reallocmem(realp,size);
+                      begin
-                 end
+                          finalizearray(realp+sizeof(realp)+ti^.elesize*dims[0],
-               else
+                            ti^.eletype,realp^.high-dims[0]+1,ti^.elesize);
-                 begin
+                         reallocmem(realp,size);
-                    reallocmem(realp,size);
+                      end
-                    !!!!!! fillchar
+                    else if dims[0]>realp^.high+1 then
+                      begin
+                         reallocmem(realp,size);
+                         fillchar((realp+sizeof(realp)+ti^.elesize*(realp^.high+1))^,
+                           (dims[0]-realp^.high-1)*ti^.elesize,0);
+                      end;
                  end;
             end
           else
+            newp:=realp;
+
+          { handle nested arrays }
+          if dimcount>1 then
             begin
-               { no, copy }
+               for i:=0 to dims[0]-1 do
-               !!!!!!!
+                 dynarray_setlength(pointer(plongint(newp+sizeof(tdynarray))[i*ti^.elesize]),
+                   ti^.eletype,dimcount-1,@dims[1]);
             end;
        end;
-
-     { handle nested arrays }
-     if dimcount>1 then
-       begin
-          for i:=0 to dims[0]-1 do
-            dynarray_setlength(newp+sizeof(tdynarray)+i*elesize,
-              ti.eletype,dimcount-1,@dims[1]);
-       end;
      p:=newp+sizeof(tdynarray);
-!!!!!! *)
+     newp^.refcount:=1;
+     newp^.high:=dims[0]-1;
   end;
 
 function dynarray_copy(var p : pointer;ti : pdynarraytypeinfo;
   dimcount : dword;dims : pdynarrayindex) : pointer;[Public,Alias:'FPC_DYNARRAY_COPY'];
 
   begin
+     {!!!!!!!!!!}
   end;
 
 
 {
   $Log$
-  Revision 1.3  2000-11-07 23:42:21  florian
+  Revision 1.4  2000-11-12 23:23:34  florian
+    * interfaces basically running
+
+  Revision 1.3  2000/11/07 23:42:21  florian
     + AfterConstruction and BeforeDestruction implemented
     + TInterfacedObject implemented
 
@@ -141,4 +214,4 @@ function dynarray_copy(var p : pointer;ti : pdynarraytypeinfo;
 
   Revision 1.1  2000/11/04 17:52:46  florian
     * fixed linker errors
-}
+}

rtl/inc/objpas.inc

@@ -14,8 +14,6 @@
 
  **********************************************************************}
 
-Procedure int_finalize (Data,TypeInfo: Pointer);forward;
-
 {****************************************************************************
                   Internal Routines called from the Compiler
 ****************************************************************************}
@@ -128,6 +126,24 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
            InstanceSize:=plongint(self)^;
         end;
 
+      procedure InitInterfacePointers(objclass: tclass;instance : pointer);
+
+        var
+           intftable : pinterfacetable;
+           i : longint;
+
+        begin
+{$ifdef HASINTF}
+          if assigned(objclass.classparent) then
+            InitInterfacePointers(objclass.classparent,instance);
+          intftable:=objclass.getinterfacetable;
+          if assigned(intftable) then
+            for i:=0 to intftable^.EntryCount-1 do
+              ppointer(@(PChar(instance)[intftable^.Entries[i].IOffset]))^:=
+                pointer(intftable^.Entries[i].VTable);
+{$endif HASINTF}
+        end;
+
       class function TObject.InitInstance(instance : pointer) : tobject;
 
         begin
@@ -135,6 +151,9 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
            { insert VMT pointer into the new created memory area }
            { (in class methods self contains the VMT!)           }
            ppointer(instance)^:=pointer(self);
+{$ifdef HASINTF}
+           InitInterfacePointers(self,instance);
+{$endif HASINTF}
            InitInstance:=TObject(Instance);
         end;
 
@@ -217,13 +236,12 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
            MethodAddress:=nil;
         end;
 
-      class function TObject.MethodName(address : pointer) : shortstring;
 
+      class function TObject.MethodName(address : pointer) : shortstring;
         var
            methodtable : pmethodnametable;
            i : dword;
            c : tclass;
-
         begin
            c:=self;
            while assigned(c) do
@@ -244,10 +262,7 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
         end;
 
 
-
-
       function TObject.FieldAddress(const name : shortstring) : pointer;
-
         type
            PFieldInfo = ^TFieldInfo;
            TFieldInfo = packed record
@@ -595,6 +610,7 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
         begin
           getinterfacetable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
         end;
+
 {****************************************************************************
                                TINTERFACEDOBJECT
 ****************************************************************************}
@@ -661,7 +677,10 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
 
 {
   $Log$
-  Revision 1.11  2000-11-09 17:50:12  florian
+  Revision 1.12  2000-11-12 23:23:34  florian
+    * interfaces basically running
+
+  Revision 1.11  2000/11/09 17:50:12  florian
     * Finalize to int_finalize renamed
 
   Revision 1.10  2000/11/07 23:42:21  florian
@@ -691,4 +710,4 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
 
   Revision 1.1.2.1  2000/07/22 14:46:57  sg
   * Made TObject.MethodAddress case independent
-}
+}