i included again my refcount patch (haven't got even a little response
on it. i'm slowly starting to wonder if i'm on the right mailing list
(usually devel list is for internal purposes of regular developers, and
others are... well,... for others (as well as bug reporting as
patches)), i got more response on C operators (which i didn't even asked
in fact) than on my first patch and error reports in interfaces)
would include auto_assign_of_guid patch too, but as much as i ask for
somebody involved in compiler nobody answers, that one requires one
change in lower levels
regards
ml
diff -ruN fpc-1.9.8-patched/compiler/htypechk.pas fpc-1.9.8-devel/compiler/htypechk.pas
--- fpc-1.9.8-patched/compiler/htypechk.pas 2005-02-20 14:12:22.000000000 +0100
+++ fpc-1.9.8-devel/compiler/htypechk.pas 2005-03-31 04:25:33.655836112 +0200
@@ -96,7 +96,7 @@
(tok:_STARSTAR;nod:starstarn;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_AS ;nod:asn;op_overloading_supported:false), { binary overloading NOT supported }
(tok:_OP_IN ;nod:inn;op_overloading_supported:false), { binary overloading NOT supported }
- (tok:_OP_IS ;nod:isn;op_overloading_supported:false), { binary overloading NOT supported }
+ (tok:_OP_IS ;nod:isn;op_overloading_supported:true), { binary overloading NOT supported }
(tok:_OP_OR ;nod:orn;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_AND ;nod:andn;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_DIV ;nod:divn;op_overloading_supported:true), { binary overloading supported }
@@ -161,7 +161,6 @@
TValidAssign=(Valid_Property,Valid_Void,Valid_Const,Valid_Addr);
TValidAssigns=set of TValidAssign;
-
function node2opstr(nt:tnodetype):string;
var
i : integer;
@@ -301,6 +300,10 @@
allowed:=false;
if not internal_check(treetyp,ld,lt,rd,rt,allowed) then
internal_check(treetyp,rd,rt,ld,lt,allowed);
+ if (not (treetyp in [equaln,unequaln])) and
+ (not ((treetyp=isn) or (treetyp=asn))) and
+ is_class_or_interface(ld) and is_interface(rd)then
+ allowed:=true;
isbinaryoperatoroverloadable:=allowed;
end;
@@ -503,6 +506,10 @@
result:=true;
case t.nodetype of
+ isn :
+ optoken:=_IS;
+ asn :
+ optoken:=_AS;
equaln,
unequaln :
optoken:=_EQUAL;
@@ -1248,7 +1255,8 @@
{ in non-delphi mode, otherwise }
{ they must match exactly, except }
{ if they are objects }
- if (def_from.deftype=objectdef) and
+ if (
+ (def_from.deftype=objectdef) and
(
not(m_delphi in aktmodeswitches) or
(
@@ -1256,7 +1264,8 @@
(tobjectdef(def_to).objecttype=odt_object)
)
) and
- (tobjectdef(def_from).is_related(tobjectdef(def_to))) then
+ (tobjectdef(def_from).is_related(tobjectdef(def_to)))
+ ) or (is_class_or_interface(def_from) and is_class_or_interface(def_to)) then
eq:=te_convert_l1;
end;
filedef :
diff -ruN fpc-1.9.8-patched/compiler/ncnv.pas fpc-1.9.8-devel/compiler/ncnv.pas
--- fpc-1.9.8-patched/compiler/ncnv.pas 2005-02-14 18:13:06.000000000 +0100
+++ fpc-1.9.8-devel/compiler/ncnv.pas 2005-03-31 04:27:06.177770640 +0200
@@ -2128,7 +2128,7 @@
firstpass(left);
if codegenerror then
exit;
-
+
{ load the value_str from the left part }
registersint:=left.registersint;
registersfpu:=left.registersfpu;
@@ -2370,8 +2370,10 @@
function tisnode.det_resulttype:tnode;
var
paras: tcallparanode;
+ procname: string;
begin
result:=nil;
+ resulttype:=booltype;
resulttypepass(left);
resulttypepass(right);
@@ -2409,37 +2411,21 @@
else if is_interface(right.resulttype.def) then
begin
{ left is a class }
- if is_class(left.resulttype.def) then
- begin
- { the operands must be related }
- if not(assigned(tobjectdef(left.resulttype.def).implementedinterfaces) and
- (tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(right.resulttype.def)<>-1)) then
- CGMessage2(type_e_classes_not_related,
- FullTypeName(left.resulttype.def,right.resulttype.def),
- FullTypeName(right.resulttype.def,left.resulttype.def))
- end
- { left is an interface }
- else if is_interface(left.resulttype.def) then
- begin
- { the operands must be related }
- if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(right.resulttype.def)))) and
- (not(tobjectdef(right.resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
- CGMessage2(type_e_classes_not_related,
- FullTypeName(left.resulttype.def,right.resulttype.def),
- FullTypeName(right.resulttype.def,left.resulttype.def));
- end
- else
+ if not is_class_or_interface(left.resulttype.def) then
CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
- { call fpc_do_is helper }
paras := ccallparanode.create(
- left,
+ right,
ccallparanode.create(
- right,nil));
- result := ccallnode.createintern('fpc_do_is',paras);
+ left,nil));
+ if is_class(left.resulttype.def) then
+ procname := 'fpc_class_is_intf'
+ else
+ procname := 'fpc_intf_is_intf';
+ result := ccallnode.createintern(procname,paras);
left := nil;
right := nil;
end
- else
+ else
CGMessage1(type_e_class_or_interface_type_expected,right.resulttype.def.typename);
resulttype:=booltype;
diff -ruN fpc-1.9.8-patched/rtl/inc/compproc.inc fpc-1.9.8-devel/rtl/inc/compproc.inc
--- fpc-1.9.8-patched/rtl/inc/compproc.inc 2005-02-14 18:13:22.000000000 +0100
+++ fpc-1.9.8-devel/rtl/inc/compproc.inc 2005-03-29 19:01:57.000000000 +0200
@@ -274,6 +274,8 @@
procedure fpc_intf_assign(var D: pointer; const S: pointer); compilerproc;
function fpc_intf_as(const S: pointer; const iid: TGUID): pointer; compilerproc;
function fpc_class_as_intf(const S: pointer; const iid: TGUID): pointer; compilerproc;
+function fpc_class_is_intf(const S: pointer; const iid: TGUID): boolean; compilerproc;
+function fpc_intf_is_intf(const S: pointer; const iid: TGUID): boolean; compilerproc;
Function fpc_PushExceptAddr (Ft: Longint;_buf,_newaddr : pointer): PJmp_buf ; compilerproc;
Procedure fpc_PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer); compilerproc;
diff -ruN fpc-1.9.8-patched/rtl/inc/objpas.inc fpc-1.9.8-devel/rtl/inc/objpas.inc
--- fpc-1.9.8-patched/rtl/inc/objpas.inc 2005-03-28 21:38:59.000000000 +0200
+++ fpc-1.9.8-devel/rtl/inc/objpas.inc 2005-03-31 03:10:25.000000000 +0200
@@ -56,6 +56,14 @@
begin
end;
+ function fpc_intf_is_intf(const S: pointer; const iid: TGUID): boolean;[public,alias: 'FPC_INTF_IS_INTF']; {$ifdef hascompilerproc} compilerproc; {$endif}
+ begin
+ end;
+
+ function fpc_class_is_intf(const S: pointer; const iid: TGUID): boolean;[public,alias: 'FPC_CLASS_IS_INTF']; {$ifdef hascompilerproc} compilerproc; {$endif}
+ begin
+ end;
+
{$else HASINTF}
{ interface helpers }
@@ -124,6 +132,36 @@
else
fpc_class_as_intf:=nil;
end;
+
+ function fpc_intf_is_intf(const S: pointer; const iid: TGUID): boolean;[public,alias: 'FPC_INTF_IS_INTF']; {$ifdef hascompilerproc} compilerproc; {$endif}
+ const
+ S_OK = 0;
+ var
+ tmpi: pointer; // _AddRef before _Release
+ begin
+ fpc_intf_is_intf:=false;
+ if assigned(S) then
+ begin
+ if IUnknown(S).QueryInterface(iid,tmpi)<>S_OK then
+ tmpi:=nil;
+ fpc_intf_is_intf:=(tmpi <> nil);
+ end;
+ end;
+
+ function fpc_class_is_intf(const S: pointer; const iid: TGUID): boolean;[public,alias: 'FPC_CLASS_IS_INTF']; {$ifdef hascompilerproc} compilerproc; {$endif}
+ const
+ S_OK = 0;
+ var
+ tmpi: pointer; // _AddRef before _Release
+ begin
+ fpc_class_is_intf:=false;
+ if assigned(S) then
+ begin
+ if not TObject(S).GetInterface(iid,tmpi) then
+ tmpi:=nil;
+ fpc_class_is_intf:=(tmpi <> nil);
+ end;
+ end;
{$endif HASINTF}
{****************************************************************************
diff -ruN fpc-1.9.8-patched/rtl/inc/objpas.inc fpc-1.9.8-devel/rtl/inc/objpas.inc
--- fpc-1.9.8-patched/rtl/inc/objpas.inc 2005-03-27 20:09:37.000000000 +0200
+++ fpc-1.9.8-devel/rtl/inc/objpas.inc 2005-03-28 21:17:14.000000000 +0200
@@ -607,7 +607,7 @@
IEntry:=getinterfaceentry(iid);
if Assigned(IEntry) then begin
PPointer(@obj)^:=Pointer(Self)+IEntry^.IOffset;
- intf_incr_ref(pointer(obj)); { it must be an com interface }
+// intf_incr_ref(pointer(obj)); { it must be an com interface }
getinterface:=True;
end
else begin
@@ -623,8 +623,8 @@
IEntry:=getinterfaceentrybystr(iidstr);
if Assigned(IEntry) then begin
PPointer(@obj)^:=Pointer(Self)+IEntry^.IOffset;
- if Assigned(IEntry^.iid) then { for Com interfaces }
- intf_incr_ref(pointer(obj));
+// if Assigned(IEntry^.iid) then { for Com interfaces }
+// intf_incr_ref(pointer(obj));
getinterfacebystr:=True;
end
else begin
_______________________________________________
fpc-pascal maillist - fpc-pascal@lists.freepascal.org
http://lists.freepascal.org/mailman/listinfo/fpc-pascal
