mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-01 10:13:58 +02:00
125 lines
2.6 KiB
ObjectPascal
125 lines
2.6 KiB
ObjectPascal
{ %target=darwin }
|
|
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
|
|
|
|
{ Written by Jonas Maebe in 2009, released into the public domain }
|
|
|
|
{$mode objfpc}
|
|
{$modeswitch objectivec1}
|
|
|
|
type
|
|
tbaseclass = objccategory(NSObject)
|
|
function tabaseproc(cp: longint): double; message 'tabaseproc:';
|
|
class function taclassproc: longint; message 'taclassproc';
|
|
end;
|
|
|
|
ta = objcclass(NSObject)
|
|
a: longint;
|
|
procedure taproc; message 'taproc';
|
|
function tabaseproc(cp: longint): double; message 'tabaseproc:'; //override; -- override doesn't work, the compiler doesn't treat the category as part of NSObject
|
|
class function taclassproc: longint; message 'taclassproc'; //override; -- idem
|
|
end;
|
|
|
|
ca = objccategory(ta)
|
|
procedure categorymethod; message 'categorymethod';
|
|
function tabaseproc(cp: longint): double; reintroduce;
|
|
end;
|
|
|
|
da = objccategory(ta)
|
|
procedure anothercategorymethod; message 'anothercategorymethod';
|
|
class function taclassproc: longint; reintroduce;
|
|
end;
|
|
|
|
class function tbaseclass.taclassproc: longint;
|
|
begin
|
|
writeln('tbaseclass.taclassproc');
|
|
result:=654321;
|
|
end;
|
|
|
|
function tbaseclass.tabaseproc(cp: longint): double;
|
|
begin
|
|
writeln('tbaseclass.tabaseproc');
|
|
if (cp<>98765) then
|
|
halt(12);
|
|
result:=1234.875;
|
|
end;
|
|
|
|
procedure ta.taproc;
|
|
begin
|
|
a:=0;
|
|
categorymethod;
|
|
if (a<>1) then
|
|
halt(1);
|
|
anothercategorymethod;
|
|
if (a<>2) then
|
|
halt(2);
|
|
if taclassproc<>123456 then
|
|
halt(5);
|
|
end;
|
|
|
|
function ta.tabaseproc(cp: longint): double;
|
|
begin
|
|
{ should be replaced/hidden by ca.tabaseproc }
|
|
halt(9);
|
|
result:=-1.0;
|
|
end;
|
|
|
|
class function ta.taclassproc: longint;
|
|
begin
|
|
{ should be replaced/hidden by da.taclassproc }
|
|
halt(3);
|
|
result:=0;
|
|
end;
|
|
|
|
procedure ca.categorymethod;
|
|
begin
|
|
a:=1;
|
|
if tabaseproc(555) <> 1.0 then
|
|
halt(16);
|
|
end;
|
|
|
|
function ca.tabaseproc(cp: longint): double;
|
|
begin
|
|
writeln('start ca.tabaseproc');
|
|
if (cp<>555) then
|
|
halt(13);
|
|
if inherited tabaseproc(98765)<>1234.875 then
|
|
halt(11);
|
|
writeln('end ca.tabaseproc');
|
|
result:=1.0;
|
|
end;
|
|
|
|
procedure da.anothercategorymethod;
|
|
begin
|
|
a:=2;
|
|
if tabaseproc(555)<>1.0 then
|
|
halt(15);
|
|
end;
|
|
|
|
class function da.taclassproc: longint;
|
|
begin
|
|
writeln('start da.taclassproc, calling inherited');
|
|
if inherited taclassproc<>654321 then
|
|
halt(4);
|
|
writeln('end da.taclassproc');
|
|
result:=123456;
|
|
end;
|
|
|
|
var
|
|
a: ta;
|
|
begin
|
|
a:=ta(ta.alloc).init;
|
|
a.taproc;
|
|
a.a:=0;
|
|
a.categorymethod;
|
|
if (a.a<>1) then
|
|
halt(6);
|
|
a.anothercategorymethod;
|
|
if (a.a<>2) then
|
|
halt(7);
|
|
if a.taclassproc<>123456 then
|
|
halt(8);
|
|
if (a.tabaseproc(555)<>1.0) then
|
|
halt(14);
|
|
a.release;
|
|
end.
|