paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 11:29:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

* interfaces are basically running

Browse Source
This commit is contained in:
florian 2000-11-12 23:24:10 +00:00
parent 5da658c6db
commit 1462deb207
10 changed files with 146 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/hcgdata.pas
View File

@ -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

9
compiler/i386/n386cal.pas
View File

@ -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

40
compiler/i386/n386cnv.pas
View File

@ -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

10
compiler/i386/n386ic.pas
View File

@ -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

13
compiler/i386/n386inl.pas
View File

@ -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
}
}

9
compiler/i386/n386ld.pas
View File

@ -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
}
}

18
compiler/ncnv.pas
View File

@ -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

8
compiler/pdecobj.pas
View File

@ -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

59
compiler/symdef.pas
View File

@ -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
}
}

26
compiler/types.pas
View File

@ -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
}
}