* interfaces are basically running

compiler/hcgdata.pas

@@ -940,7 +940,7 @@ implementation
         for i:=1 to max do
           begin
             if i<>impintfindexes[i] then { why execute x:=x ? }
-              with _class^.implementedinterfaces^ do 
+              with _class^.implementedinterfaces^ do
 	        ioffsets(i)^:=ioffsets(impintfindexes[i])^;
             gintfgenentry(_class,i,impintfindexes[i],@rawdata);
           end;
@@ -1070,7 +1070,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.13  2000-11-08 00:07:40  florian
+  Revision 1.14  2000-11-12 23:24:10  florian
+    * interfaces are basically running
+
+  Revision 1.13  2000/11/08 00:07:40  florian
      * potential range check error fixed
 
   Revision 1.12  2000/11/06 23:13:53  peter

compiler/i386/n386cal.pas

@@ -903,6 +903,7 @@ implementation
                          assigned(methodpointer) and
                          (methodpointer.resulttype^.deftype=classrefdef)
                         ) or
+                        { is_interface(pprocdef(procdefinition)^._class) or }
                         { ESI is loaded earlier }
                         (po_classmethod in procdefinition^.procoptions) then
                          begin
@@ -941,7 +942,8 @@ implementation
                    if pprocdef(procdefinition)^.extnumber=-1 then
                      internalerror(44584);
                    r^.offset:=pprocdef(procdefinition)^._class^.vmtmethodoffset(pprocdef(procdefinition)^.extnumber);
-                   if (cs_check_object_ext in aktlocalswitches) then
+                   if (cs_check_object_ext in aktlocalswitches) and
+                     not(is_interface(pprocdef(procdefinition)^._class)) then
                      begin
                         emit_sym(A_PUSH,S_L,
                           newasmsymbol(pprocdef(procdefinition)^._class^.vmt_mangledname));
@@ -1587,7 +1589,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.6  2000-11-07 23:40:49  florian
+  Revision 1.7  2000-11-12 23:24:14  florian
+    * interfaces are basically running
+
+  Revision 1.6  2000/11/07 23:40:49  florian
     + AfterConstruction and BeforeDestruction impemented
 
   Revision 1.5  2000/11/06 23:15:01  peter

compiler/i386/n386cnv.pas

@@ -51,6 +51,7 @@ interface
           procedure second_load_smallset;virtual;
           procedure second_ansistring_to_pchar;virtual;
           procedure second_pchar_to_string;virtual;
+          procedure second_class_to_intf;virtual;
           procedure second_nothing;virtual;
           procedure pass_2;override;
           procedure second_call_helper(c : tconverttype);
@@ -1207,6 +1208,37 @@ implementation
       end;
 
 
+    procedure ti386typeconvnode.second_class_to_intf;
+      var
+         hreg : tregister;
+      begin
+         case left.location.loc of
+            LOC_MEM,
+            LOC_REFERENCE:
+              begin
+                 del_reference(left.location.reference);
+                 hreg:=getregister32;
+                 exprasmlist^.concat(new(paicpu,op_ref_reg(
+                   A_MOV,S_L,newreference(left.location.reference),hreg)));
+              end;
+            LOC_CREGISTER:
+              begin
+                 hreg:=getregister32;
+                 exprasmlist^.concat(new(paicpu,op_reg_reg(
+                   A_MOV,S_L,left.location.register,hreg)));
+              end;
+            LOC_REGISTER:
+              hreg:=left.location.register;
+            else internalerror(121120001);
+         end;
+
+         emit_const_reg(A_ADD,S_L,pobjectdef(left.resulttype)^.implementedinterfaces^.ioffsets(
+           pobjectdef(left.resulttype)^.implementedinterfaces^.searchintf(resulttype))^,hreg);
+         location.loc:=LOC_REGISTER;
+         location.register:=hreg;
+      end;
+
+
     procedure ti386typeconvnode.second_nothing;
       begin
       end;
@@ -1246,7 +1278,8 @@ implementation
            @ti386typeconvnode.second_load_smallset,
            @ti386typeconvnode.second_cord_to_pointer,
            @ti386typeconvnode.second_nothing, { interface 2 string }
-           @ti386typeconvnode.second_nothing  { interface 2 guid   }
+           @ti386typeconvnode.second_nothing, { interface 2 guid   }
+           @ti386typeconvnode.second_class_to_intf
          );
       type
          tprocedureofobject = procedure of object;
@@ -1446,7 +1479,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.4  2000-11-11 16:00:10  jonas
+  Revision 1.5  2000-11-12 23:24:14  florian
+    * interfaces are basically running
+
+  Revision 1.4  2000/11/11 16:00:10  jonas
     * optimize converting of 8/16/32 bit constants to 64bit ones
 
   Revision 1.3  2000/11/04 14:25:23  florian

compiler/i386/n386ic.pas

@@ -137,6 +137,8 @@ procedure cgintfwrapper(asmlist: paasmoutput; procdef: pprocdef; const labelname
 
 var
   oldexprasmlist: paasmoutput;
+  lab : pasmsymbol;
+
 begin
   if procdef^.proctypeoption<>potype_none then
     Internalerror(200006137);
@@ -194,7 +196,8 @@ begin
   { case 0 }
   else
     begin
-      emitcall(procdef^.mangledname);
+      lab:=newasmsymbol(procdef^.mangledname);
+      emit_sym(A_JMP,S_NO,lab);
     end;
   exprasmlist:=oldexprasmlist;
 end;
@@ -202,7 +205,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.1  2000-11-04 14:25:23  florian
+  Revision 1.2  2000-11-12 23:24:15  florian
+    * interfaces are basically running
+
+  Revision 1.1  2000/11/04 14:25:23  florian
     + merged Attila's changes for interfaces, not tested yet
 
   Revision 1.1.2.2  2000/06/15 15:05:30  kaz

compiler/i386/n386inl.pas

@@ -1396,6 +1396,8 @@ implementation
                     begin
                        { get temp. space }
                        gettempofsizereference(l*4,hr);
+                       { keep data start }
+                       hr2:=hr;
                        { copy dimensions }
                        hp:=left;
                        while assigned(tcallparanode(hp).right) do
@@ -1427,8 +1429,8 @@ implementation
                     end
                   else secondpass(tcallparanode(hp).left);
                   if is_dynamic_array(def) then
-                    begin
-                       emitpushreferenceaddr(hr);
+                    begin                       
+                       emitpushreferenceaddr(hr2);
                        push_int(l);
                        reset_reference(hr2);
                        hr2.symbol:=pstoreddef(def)^.get_inittable_label;
@@ -1663,7 +1665,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.5  2000-11-09 17:46:56  florian
+  Revision 1.6  2000-11-12 23:24:15  florian
+    * interfaces are basically running
+
+  Revision 1.5  2000/11/09 17:46:56  florian
     * System.TypeInfo fixed
     + System.Finalize implemented
     + some new keywords for interface support added
@@ -1690,4 +1695,4 @@ end.
   Revision 1.1  2000/10/14 10:14:49  peter
     * moehrendorf oct 2000 rewrite
 
-}
+}

compiler/i386/n386ld.pas

@@ -95,7 +95,7 @@ implementation
                      begin
                         location.loc:=LOC_MEM;
                         location.reference.symbol:=newasmsymbol(pconstsym(symtableentry)^.owner^.name^+'_RESOURCESTRINGLIST');
-                        location.reference.offset:=pconstsym(symtableentry)^.resstrindex*16+4;
+                        location.reference.offset:=pconstsym(symtableentry)^.resstrindex*16+8;
                      end
                    else
                      internalerror(22798);
@@ -1050,7 +1050,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.6  2000-11-11 22:59:20  florian
+  Revision 1.7  2000-11-12 23:24:15  florian
+    * interfaces are basically running
+
+  Revision 1.6  2000/11/11 22:59:20  florian
     * fixed resourcestrings, made a stupid mistake yesterday
 
   Revision 1.5  2000/11/09 18:52:06  florian
@@ -1072,4 +1075,4 @@ end.
   Revision 1.1  2000/10/14 10:14:49  peter
     * moehrendorf oct 2000 rewrite
 
-}
+}

compiler/ncnv.pas

@@ -61,6 +61,7 @@ interface
           function first_pchar_to_string : tnode;virtual;
           function first_ansistring_to_pchar : tnode;virtual;
           function first_arrayconstructor_to_set : tnode;virtual;
+          function first_class_to_intf : tnode;virtual;
           function first_call_helper(c : tconverttype) : tnode;
        end;
 
@@ -698,6 +699,15 @@ implementation
         first_arrayconstructor_to_set:=hp;
       end;
 
+    function ttypeconvnode.first_class_to_intf : tnode;
+
+      begin
+         first_class_to_intf:=nil;
+         location.loc:=LOC_REFERENCE;
+         if registers32<1 then
+           registers32:=1;
+      end;
+
     function ttypeconvnode.first_call_helper(c : tconverttype) : tnode;
 
       const
@@ -728,7 +738,8 @@ implementation
            @ttypeconvnode.first_load_smallset,
            @ttypeconvnode.first_cord_to_pointer,
            @ttypeconvnode.first_nothing,
-           @ttypeconvnode.first_nothing
+           @ttypeconvnode.first_nothing,
+           @ttypeconvnode.first_class_to_intf
          );
       type
          tprocedureofobject = function : tnode of object;
@@ -1165,7 +1176,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.10  2000-11-04 14:25:20  florian
+  Revision 1.11  2000-11-12 23:24:11  florian
+    * interfaces are basically running
+
+  Revision 1.10  2000/11/04 14:25:20  florian
     + merged Attila's changes for interfaces, not tested yet
 
   Revision 1.9  2000/10/31 22:02:48  peter

compiler/pdecobj.pas

@@ -732,7 +732,7 @@ implementation
               if pd^.deftype=procdef then
                 begin
                   pd^.extnumber:=aktclass^.lastvtableindex;
-                  aktclass^.lastvtableindex:=aktclass^.lastvtableindex+1;
+                  inc(aktclass^.lastvtableindex);
                   include(pd^.procoptions,po_virtualmethod);
                   pd^.forwarddef:=false;
                 end;
@@ -858,7 +858,6 @@ implementation
         var
           tt: ttype;
           p : tnode;
-          isiidguidvalid: boolean;
 
         begin
           p:=comp_expr(true);
@@ -1156,7 +1155,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.10  2000-11-12 22:17:47  peter
+  Revision 1.11  2000-11-12 23:24:11  florian
+    * interfaces are basically running
+
+  Revision 1.10  2000/11/12 22:17:47  peter
     * some realname updates for messages
 
   Revision 1.9  2000/11/06 23:05:52  florian

compiler/symdef.pas

@@ -259,31 +259,31 @@ interface
        end;
 
        timplementedinterfaces = object
-         constructor init;
-         destructor  done; virtual;
+          constructor init;
+          destructor  done; virtual;
 
-         function  count: longint;
-         function  interfaces(intfindex: longint): pobjectdef;
-         function  ioffsets(intfindex: longint): plongint;
-         function  searchintf(def: pdef): longint;
-         procedure addintf(def: pdef);
+          function  count: longint;
+          function  interfaces(intfindex: longint): pobjectdef;
+          function  ioffsets(intfindex: longint): plongint;
+          function  searchintf(def: pdef): longint;
+          procedure addintf(def: pdef);
 
-         procedure deref;
-         procedure addintfref(def: pdef);
+          procedure deref;
+          procedure addintfref(def: pdef);
 
-         procedure clearmappings;
-         procedure addmappings(intfindex: longint; const name, newname: string);
-         function  getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
+          procedure clearmappings;
+          procedure addmappings(intfindex: longint; const name, newname: string);
+          function  getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
 
-         procedure clearimplprocs;
-         procedure addimplproc(intfindex: longint; procdef: pprocdef);
-         function  implproccount(intfindex: longint): longint;
-         function  implprocs(intfindex: longint; procindex: longint): pprocdef;
-         function  isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
+          procedure clearimplprocs;
+          procedure addimplproc(intfindex: longint; procdef: pprocdef);
+          function  implproccount(intfindex: longint): longint;
+          function  implprocs(intfindex: longint; procindex: longint): pprocdef;
+          function  isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
 
        private
-         finterfaces: tindexarray;
-         procedure checkindex(intfindex: longint);
+          finterfaces: tindexarray;
+          procedure checkindex(intfindex: longint);
        end;
 
 
@@ -4069,9 +4069,9 @@ Const local_symtable_index : longint = $8001;
         symtable^.datasize:=0;
         symtable^.defowner:=@self;
         symtable^.dataalignment:=packrecordalignment[aktpackrecords];
+        lastvtableindex:=0;
         set_parent(c);
         objname:=stringdup(n);
-        lastvtableindex:=0;
 
         { set up guid }
         isiidguidvalid:=true; { default null guid }
@@ -4394,14 +4394,18 @@ Const local_symtable_index : longint = $8001;
     function tobjectdef.vmtmethodoffset(index:longint):longint;
       begin
         { for offset of methods for classes, see rtl/inc/objpash.inc }
-        if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba] then
-          vmtmethodoffset:=(index+12)*target_os.size_of_pointer
+        case objecttype of
+        odt_class:
+          vmtmethodoffset:=(index+12)*target_os.size_of_pointer;
+        odt_interfacecom,odt_interfacecorba:
+          vmtmethodoffset:=index*target_os.size_of_pointer;
         else
 {$ifdef WITHDMT}
-         vmtmethodoffset:=(index+4)*target_os.size_of_pointer;
+          vmtmethodoffset:=(index+4)*target_os.size_of_pointer;
 {$else WITHDMT}
-         vmtmethodoffset:=(index+3)*target_os.size_of_pointer;
+          vmtmethodoffset:=(index+3)*target_os.size_of_pointer;
 {$endif WITHDMT}
+        end;
       end;
 
 
@@ -5524,7 +5528,10 @@ Const local_symtable_index : longint = $8001;
 end.
 {
   $Log$
-  Revision 1.10  2000-11-11 16:12:38  peter
+  Revision 1.11  2000-11-12 23:24:12  florian
+    * interfaces are basically running
+
+  Revision 1.10  2000/11/11 16:12:38  peter
     * add far; to typename for far pointer
 
   Revision 1.9  2000/11/07 20:01:57  peter
@@ -5555,4 +5562,4 @@ end.
   Revision 1.1  2000/10/31 22:02:52  peter
     * symtable splitted, no real code changes
 
-}
+}

compiler/types.pas

@@ -176,7 +176,8 @@ interface
           tc_load_smallset,
           tc_cord_2_pointer,
           tc_intf_2_string,
-          tc_intf_2_guid
+          tc_intf_2_guid,
+          tc_class_2_intf
        );
 
     function assignment_overloaded(from_def,to_def : pdef) : pprocdef;
@@ -1576,12 +1577,11 @@ implementation
            objectdef :
              begin
                { object pascal objects }
-               if (def_from^.deftype=objectdef) {and
-                  pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass }then
+               if (def_from^.deftype=objectdef) and
+                 pobjectdef(def_from)^.is_related(pobjectdef(def_to)) then
                 begin
                   doconv:=tc_equal;
-                  if pobjectdef(def_from)^.is_related(pobjectdef(def_to)) then
-                   b:=1;
+                  b:=1;
                 end
                else
                { Class specific }
@@ -1600,6 +1600,15 @@ implementation
                      begin
                        doconv:=tc_equal;
                        b:=1;
+                     end
+                   { classes can be assigned to interfaces }
+                   else if is_interface(def_to) and
+                     is_class(def_from) and
+                     assigned(pobjectdef(def_from)^.implementedinterfaces) and
+                     (pobjectdef(def_from)^.implementedinterfaces^.searchintf(def_to)<>-1) then
+                     begin
+                        doconv:=tc_class_2_intf;
+                        b:=1;
                      end;
                  end;
              end;
@@ -1710,7 +1719,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.20  2000-11-11 16:13:31  peter
+  Revision 1.21  2000-11-12 23:24:12  florian
+    * interfaces are basically running
+
+  Revision 1.20  2000/11/11 16:13:31  peter
     * farpointer and normal pointer aren't compatible
 
   Revision 1.19  2000/11/06 22:30:30  peter
@@ -1771,4 +1783,4 @@ end.
   Revision 1.2  2000/07/13 11:32:53  michael
   + removed logs
 
-}
+}