mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 23:28:28 +02:00
+ support for exporting Objective-C classes from dynamic libraries. It works
the same as for exporting functions/procedures and variables: add the name
of the class to the "exports" section of the library. By default, classes
are only visible inside a shared library.
git-svn-id: branches/objc@13765 -
This commit is contained in:
Jonas Maebe
parent
046b652c28
commit
6f3bace0f3
5
.gitattributes
vendored
5
.gitattributes
vendored
@ -8628,6 +8628,10 @@ tests/test/tobjc8a.pp svneol=native#text/plain
|
||||
tests/test/tobjc9.pp svneol=native#text/plain
|
||||
tests/test/tobjc9a.pp svneol=native#text/plain
|
||||
tests/test/tobjc9b.pp svneol=native#text/plain
|
||||
tests/test/tobjcl1.pp svneol=native#text/plain
|
||||
tests/test/tobjcl2.pp svneol=native#text/plain
|
||||
tests/test/tobjcl3.pp svneol=native#text/plain
|
||||
tests/test/tobjcl4.pp svneol=native#text/plain
|
||||
tests/test/tobject1.pp svneol=native#text/plain
|
||||
tests/test/tobject2.pp svneol=native#text/plain
|
||||
tests/test/tobject3.pp svneol=native#text/plain
|
||||
@ -8940,6 +8944,7 @@ tests/test/units/sysutils/tfloattostr.pp svneol=native#text/plain
|
||||
tests/test/units/sysutils/tlocale.pp svneol=native#text/plain
|
||||
tests/test/units/sysutils/tsscanf.pp svneol=native#text/plain
|
||||
tests/test/units/sysutils/tstrtobool.pp svneol=native#text/plain
|
||||
tests/test/uobjcl1.pp svneol=native#text/plain
|
||||
tests/test/uprec6.pp svneol=native#text/plain
|
||||
tests/test/uprec7.pp svneol=native#text/plain
|
||||
tests/test/uprocext1.pp svneol=native#text/plain
|
||||
|
||||
@ -73,6 +73,9 @@ type
|
||||
|
||||
procedure exportprocsym(sym: tsym; const s : string; index: longint; options: word);
|
||||
procedure exportvarsym(sym: tsym; const s : string; index: longint; options: word);
|
||||
{ to export symbols not directly related to a tsym (e.g., the Objective-C
|
||||
rtti) }
|
||||
procedure exportname(const s : string; options: word);
|
||||
|
||||
procedure exportallprocdefnames(sym: tprocsym; pd: tprocdef; options: word);
|
||||
procedure exportallprocsymnames(ps: tprocsym; options: word);
|
||||
@ -122,6 +125,12 @@ procedure exportvarsym(sym: tsym; const s : string; index: longint; options: wor
|
||||
end;
|
||||
|
||||
|
||||
procedure exportname(const s : string; options: word);
|
||||
begin
|
||||
exportvarsym(nil,s,0,options);
|
||||
end;
|
||||
|
||||
|
||||
procedure exportallprocdefnames(sym: tprocsym; pd: tprocdef; options: word);
|
||||
var
|
||||
item: TCmdStrListItem;
|
||||
|
||||
@ -172,7 +172,8 @@ begin
|
||||
end
|
||||
else
|
||||
begin
|
||||
if (hp2.name^<>hp2.sym.mangledname) then
|
||||
if assigned(hp2.sym) and
|
||||
(hp2.name^<>hp2.sym.mangledname) then
|
||||
Message2(parser_e_cant_export_var_different_name,hp2.sym.realname,hp2.sym.mangledname)
|
||||
else
|
||||
exportedsymnames.insert(hp2.name^);
|
||||
|
||||
@ -52,6 +52,9 @@ interface
|
||||
signature or field declaration. }
|
||||
function objcchecktype(def: tdef; out founderror: tdef): boolean;
|
||||
|
||||
{ Exports all assembler symbols related to the obj-c class }
|
||||
procedure exportobjcclass(def: tobjectdef);
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
@ -806,4 +809,44 @@ end;
|
||||
end;
|
||||
|
||||
|
||||
{******************************************************************
|
||||
ObjC class exporting
|
||||
*******************************************************************}
|
||||
|
||||
procedure exportobjcclassfields(objccls: tobjectdef);
|
||||
var
|
||||
i: longint;
|
||||
vf: tfieldvarsym;
|
||||
prefix: string;
|
||||
begin
|
||||
prefix:=target_info.cprefix+'OBJC_IVAR_$_'+objccls.objextname^+'.';
|
||||
for i:=0 to objccls.symtable.SymList.Count-1 do
|
||||
if tsym(objccls.symtable.SymList[i]).typ=fieldvarsym then
|
||||
begin
|
||||
vf:=tfieldvarsym(objccls.symtable.SymList[i]);
|
||||
{ TODO: package visibility (private_extern) -- must not be exported
|
||||
either}
|
||||
if (vf.visibility<>vis_private) then
|
||||
exportname(prefix+vf.RealName,0);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure exportobjcclass(def: tobjectdef);
|
||||
begin
|
||||
if (target_info.system in system_objc_nfabi) then
|
||||
begin
|
||||
{ export class and metaclass symbols }
|
||||
exportname(def.rtti_mangledname(objcclassrtti),0);
|
||||
exportname(def.rtti_mangledname(objcmetartti),0);
|
||||
{ export public/protected instance variable offset symbols }
|
||||
exportobjcclassfields(def);
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ export the class symbol }
|
||||
exportname('.objc_class_name_'+def.objextname^,0);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -45,6 +45,8 @@ implementation
|
||||
{ parser }
|
||||
scanner,
|
||||
pbase,pexpr,
|
||||
{ obj-c }
|
||||
objcutil,
|
||||
{ link }
|
||||
gendef,export
|
||||
;
|
||||
@ -107,114 +109,136 @@ implementation
|
||||
else
|
||||
InternalProcName:=pd.mangledname;
|
||||
end;
|
||||
typesym :
|
||||
begin
|
||||
if not is_objcclass(ttypesym(srsym).typedef) then
|
||||
Message(parser_e_illegal_symbol_exported)
|
||||
end;
|
||||
else
|
||||
Message(parser_e_illegal_symbol_exported)
|
||||
end;
|
||||
if InternalProcName<>'' then
|
||||
begin
|
||||
{ This is wrong if the first is not
|
||||
an underline }
|
||||
if InternalProcName[1]='_' then
|
||||
delete(InternalProcName,1,1)
|
||||
else if (target_info.system in [system_i386_win32,system_i386_wdosx,system_arm_wince,system_i386_wince]) and UseDeffileForExports then
|
||||
if (srsym.typ<>typesym) then
|
||||
begin
|
||||
if InternalProcName<>'' then
|
||||
begin
|
||||
Message(parser_e_dlltool_unit_var_problem);
|
||||
Message(parser_e_dlltool_unit_var_problem2);
|
||||
{ This is wrong if the first is not
|
||||
an underline }
|
||||
if InternalProcName[1]='_' then
|
||||
delete(InternalProcName,1,1)
|
||||
else if (target_info.system in [system_i386_win32,system_i386_wdosx,system_arm_wince,system_i386_wince]) and UseDeffileForExports then
|
||||
begin
|
||||
Message(parser_e_dlltool_unit_var_problem);
|
||||
Message(parser_e_dlltool_unit_var_problem2);
|
||||
end;
|
||||
if length(InternalProcName)<2 then
|
||||
Message(parser_e_procname_to_short_for_export);
|
||||
DefString:=srsym.realname+'='+InternalProcName;
|
||||
end;
|
||||
if length(InternalProcName)<2 then
|
||||
Message(parser_e_procname_to_short_for_export);
|
||||
DefString:=srsym.realname+'='+InternalProcName;
|
||||
end;
|
||||
if try_to_consume(_INDEX) then
|
||||
begin
|
||||
pt:=comp_expr(true);
|
||||
if pt.nodetype=ordconstn then
|
||||
if (Tordconstnode(pt).value<int64(low(index))) or
|
||||
(Tordconstnode(pt).value>int64(high(index))) then
|
||||
begin
|
||||
index:=0;
|
||||
message(parser_e_range_check_error)
|
||||
end
|
||||
else
|
||||
index:=Tordconstnode(pt).value.svalue
|
||||
else
|
||||
begin
|
||||
index:=0;
|
||||
consume(_INTCONST);
|
||||
end;
|
||||
options:=options or eo_index;
|
||||
pt.free;
|
||||
if target_info.system in [system_i386_win32,system_i386_wdosx,system_arm_wince,system_i386_wince] then
|
||||
DefString:=srsym.realname+'='+InternalProcName+' @ '+tostr(index)
|
||||
else
|
||||
DefString:=srsym.realname+'='+InternalProcName; {Index ignored!}
|
||||
end;
|
||||
if try_to_consume(_NAME) then
|
||||
begin
|
||||
pt:=comp_expr(true);
|
||||
if pt.nodetype=stringconstn then
|
||||
hpname:=strpas(tstringconstnode(pt).value_str)
|
||||
else
|
||||
begin
|
||||
consume(_CSTRING);
|
||||
end;
|
||||
options:=options or eo_name;
|
||||
pt.free;
|
||||
DefString:=hpname+'='+InternalProcName;
|
||||
end;
|
||||
if try_to_consume(_RESIDENT) then
|
||||
begin
|
||||
options:=options or eo_resident;
|
||||
DefString:=srsym.realname+'='+InternalProcName;{Resident ignored!}
|
||||
end;
|
||||
if (DefString<>'') and UseDeffileForExports then
|
||||
DefFile.AddExport(DefString);
|
||||
|
||||
if srsym.typ=procsym then
|
||||
begin
|
||||
{ if no specific name or index was given, then if }
|
||||
{ the procedure has aliases defined export those, }
|
||||
{ otherwise export the name as it appears in the }
|
||||
{ export section (it doesn't make sense to export }
|
||||
{ the generic mangled name, because the name of }
|
||||
{ the parent unit is used in that) }
|
||||
if ((options and (eo_name or eo_index))=0) and
|
||||
(tprocdef(tprocsym(srsym).procdeflist[0]).aliasnames.count>1) then
|
||||
exportallprocsymnames(tprocsym(srsym),options)
|
||||
else
|
||||
begin
|
||||
{ there's a name or an index -> export only one name }
|
||||
{ correct? Or can you export multiple names with the }
|
||||
{ same index? And/or should we also export the aliases }
|
||||
{ if a name is specified? (JM) }
|
||||
|
||||
if ((options and eo_name)=0) then
|
||||
{ Export names are not mangled on Windows and OS/2 }
|
||||
if (target_info.system in (system_all_windows+[system_i386_emx, system_i386_os2])) then
|
||||
hpname:=orgs
|
||||
{ Use set mangled name in case of cdecl/cppdecl/mwpascal }
|
||||
{ and no name specified }
|
||||
else if (tprocdef(tprocsym(srsym).procdeflist[0]).proccalloption in [pocall_cdecl,pocall_mwpascal]) then
|
||||
hpname:=target_info.cprefix+tprocsym(srsym).realname
|
||||
else if (tprocdef(tprocsym(srsym).procdeflist[0]).proccalloption in [pocall_cppdecl]) then
|
||||
hpname:=target_info.cprefix+tprocdef(tprocsym(srsym).procdeflist[0]).cplusplusmangledname
|
||||
else
|
||||
hpname:=orgs;
|
||||
|
||||
exportprocsym(srsym,hpname,index,options);
|
||||
end
|
||||
end
|
||||
{ can also be errorsym }
|
||||
else if (srsym.typ=staticvarsym) then
|
||||
begin
|
||||
if ((options and eo_name)=0) then
|
||||
{ for "cvar" }
|
||||
if (vo_has_mangledname in tstaticvarsym(srsym).varoptions) then
|
||||
hpname:=srsym.mangledname
|
||||
else
|
||||
hpname:=orgs;
|
||||
exportvarsym(srsym,hpname,index,options);
|
||||
if try_to_consume(_INDEX) then
|
||||
begin
|
||||
pt:=comp_expr(true);
|
||||
if pt.nodetype=ordconstn then
|
||||
if (Tordconstnode(pt).value<int64(low(index))) or
|
||||
(Tordconstnode(pt).value>int64(high(index))) then
|
||||
begin
|
||||
index:=0;
|
||||
message(parser_e_range_check_error)
|
||||
end
|
||||
else
|
||||
index:=Tordconstnode(pt).value.svalue
|
||||
else
|
||||
begin
|
||||
index:=0;
|
||||
consume(_INTCONST);
|
||||
end;
|
||||
options:=options or eo_index;
|
||||
pt.free;
|
||||
if target_info.system in [system_i386_win32,system_i386_wdosx,system_arm_wince,system_i386_wince] then
|
||||
DefString:=srsym.realname+'='+InternalProcName+' @ '+tostr(index)
|
||||
else
|
||||
DefString:=srsym.realname+'='+InternalProcName; {Index ignored!}
|
||||
end;
|
||||
if try_to_consume(_NAME) then
|
||||
begin
|
||||
pt:=comp_expr(true);
|
||||
if pt.nodetype=stringconstn then
|
||||
hpname:=strpas(tstringconstnode(pt).value_str)
|
||||
else
|
||||
begin
|
||||
consume(_CSTRING);
|
||||
end;
|
||||
options:=options or eo_name;
|
||||
pt.free;
|
||||
DefString:=hpname+'='+InternalProcName;
|
||||
end;
|
||||
if try_to_consume(_RESIDENT) then
|
||||
begin
|
||||
options:=options or eo_resident;
|
||||
DefString:=srsym.realname+'='+InternalProcName;{Resident ignored!}
|
||||
end;
|
||||
if (DefString<>'') and UseDeffileForExports then
|
||||
DefFile.AddExport(DefString);
|
||||
end;
|
||||
case srsym.typ of
|
||||
procsym:
|
||||
begin
|
||||
{ if no specific name or index was given, then if }
|
||||
{ the procedure has aliases defined export those, }
|
||||
{ otherwise export the name as it appears in the }
|
||||
{ export section (it doesn't make sense to export }
|
||||
{ the generic mangled name, because the name of }
|
||||
{ the parent unit is used in that) }
|
||||
if ((options and (eo_name or eo_index))=0) and
|
||||
(tprocdef(tprocsym(srsym).procdeflist[0]).aliasnames.count>1) then
|
||||
exportallprocsymnames(tprocsym(srsym),options)
|
||||
else
|
||||
begin
|
||||
{ there's a name or an index -> export only one name }
|
||||
{ correct? Or can you export multiple names with the }
|
||||
{ same index? And/or should we also export the aliases }
|
||||
{ if a name is specified? (JM) }
|
||||
|
||||
if ((options and eo_name)=0) then
|
||||
{ Export names are not mangled on Windows and OS/2 }
|
||||
if (target_info.system in (system_all_windows+[system_i386_emx, system_i386_os2])) then
|
||||
hpname:=orgs
|
||||
{ Use set mangled name in case of cdecl/cppdecl/mwpascal }
|
||||
{ and no name specified }
|
||||
else if (tprocdef(tprocsym(srsym).procdeflist[0]).proccalloption in [pocall_cdecl,pocall_mwpascal]) then
|
||||
hpname:=target_info.cprefix+tprocsym(srsym).realname
|
||||
else if (tprocdef(tprocsym(srsym).procdeflist[0]).proccalloption in [pocall_cppdecl]) then
|
||||
hpname:=target_info.cprefix+tprocdef(tprocsym(srsym).procdeflist[0]).cplusplusmangledname
|
||||
else
|
||||
hpname:=orgs;
|
||||
|
||||
exportprocsym(srsym,hpname,index,options);
|
||||
end
|
||||
end;
|
||||
staticvarsym:
|
||||
begin
|
||||
if ((options and eo_name)=0) then
|
||||
{ for "cvar" }
|
||||
if (vo_has_mangledname in tstaticvarsym(srsym).varoptions) then
|
||||
hpname:=srsym.mangledname
|
||||
else
|
||||
hpname:=orgs;
|
||||
exportvarsym(srsym,hpname,index,options);
|
||||
end;
|
||||
typesym:
|
||||
begin
|
||||
case ttypesym(srsym).typedef.typ of
|
||||
objectdef:
|
||||
case tobjectdef(ttypesym(srsym).typedef).objecttype of
|
||||
odt_objcclass:
|
||||
exportobjcclass(tobjectdef(ttypesym(srsym).typedef));
|
||||
else
|
||||
internalerror(2009092601);
|
||||
end;
|
||||
else
|
||||
internalerror(2009092602);
|
||||
end;
|
||||
end;
|
||||
end
|
||||
end
|
||||
else
|
||||
consume(_ID);
|
||||
|
||||
17
tests/test/tobjcl1.pp
Normal file
17
tests/test/tobjcl1.pp
Normal file
@ -0,0 +1,17 @@
|
||||
{ %target=darwin }
|
||||
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
|
||||
{ %recompile }
|
||||
{ %norun }
|
||||
|
||||
{$mode objfpc}
|
||||
{$modeswitch objectivec1}
|
||||
|
||||
library tobjcl1;
|
||||
|
||||
uses
|
||||
uobjcl1;
|
||||
|
||||
exports
|
||||
MyLibObjCClass;
|
||||
|
||||
end.
|
||||
52
tests/test/tobjcl2.pp
Normal file
52
tests/test/tobjcl2.pp
Normal file
@ -0,0 +1,52 @@
|
||||
{ %target=darwin }
|
||||
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
|
||||
{ %NEEDLIBRARY }
|
||||
|
||||
{$mode objfpc}
|
||||
{$modeswitch objectivec1}
|
||||
|
||||
const
|
||||
{$ifdef windows}
|
||||
libname='tobjcl1.dll';
|
||||
{$else}
|
||||
libname='tobjcl1';
|
||||
{$linklib tobjcl1}
|
||||
{$endif}
|
||||
|
||||
type
|
||||
MyLibObjCClass = objcclass(NSObject)
|
||||
public
|
||||
fa: byte;
|
||||
function publicfun: byte; message 'publicfun';
|
||||
protected
|
||||
fb: byte;
|
||||
function protectedfun: byte; message 'protectedfun';
|
||||
private
|
||||
fc: byte;
|
||||
function privatefun: byte; message 'privatefun';
|
||||
end; external;
|
||||
|
||||
MyDerivedClass = objcclass(MyLibObjCClass)
|
||||
l: longint;
|
||||
function callprotectedfun: byte; message 'callprotectedfun';
|
||||
end;
|
||||
|
||||
|
||||
function MyDerivedClass.callprotectedfun: byte;
|
||||
begin
|
||||
result:=protectedfun;
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
a: MyLibObjCClass;
|
||||
begin
|
||||
a:=NSObject(MyDerivedClass.alloc).init;
|
||||
a.fa:=55;
|
||||
a.fb:=66;
|
||||
if a.publicfun<>55 then
|
||||
halt(1);
|
||||
if MyDerivedClass(a).callprotectedfun<>66 then
|
||||
halt(2);
|
||||
a.release;
|
||||
end.
|
||||
36
tests/test/tobjcl3.pp
Normal file
36
tests/test/tobjcl3.pp
Normal file
@ -0,0 +1,36 @@
|
||||
{ %target=darwin }
|
||||
{ %cpu=powerpc64,x86_64,arm }
|
||||
{ %NEEDLIBRARY }
|
||||
{ %fail }
|
||||
|
||||
{$mode objfpc}
|
||||
{$modeswitch objectivec1}
|
||||
|
||||
const
|
||||
{$ifdef windows}
|
||||
libname='tobjcl1.dll';
|
||||
{$else}
|
||||
libname='tobjcl1';
|
||||
{$linklib tobjcl1}
|
||||
{$endif}
|
||||
|
||||
type
|
||||
MyLibObjCClass = objcclass(NSObject)
|
||||
public
|
||||
fa: byte;
|
||||
fb: byte;
|
||||
{ this field is declared as private in the real class,
|
||||
and the non-fragile ABI should be sure that this
|
||||
gives a linker error }
|
||||
fc: byte;
|
||||
function publicfun: byte; message 'publicfun';
|
||||
function protectedfun: byte; message 'protectedfun';
|
||||
function privatefun: byte; message 'privatefun';
|
||||
end; external;
|
||||
|
||||
var
|
||||
a: MyLibObjCClass;
|
||||
begin
|
||||
a:=NSObject(MyLibObjCClass.alloc).init;
|
||||
a.fc:=55;
|
||||
end.
|
||||
26
tests/test/tobjcl4.pp
Normal file
26
tests/test/tobjcl4.pp
Normal file
@ -0,0 +1,26 @@
|
||||
{ %target=darwin }
|
||||
{ %cpu=i386,powerpc,powerpc64,x86_64,arm }
|
||||
{ %NEEDLIBRARY }
|
||||
{ %fail }
|
||||
|
||||
{$mode objfpc}
|
||||
{$modeswitch objectivec1}
|
||||
|
||||
const
|
||||
{$ifdef windows}
|
||||
libname='tobjcl1.dll';
|
||||
{$else}
|
||||
libname='tobjcl1';
|
||||
{$linklib tobjcl1}
|
||||
{$endif}
|
||||
|
||||
type
|
||||
MyHiddenObjcClass=objcclass(NSObject)
|
||||
end; external;
|
||||
|
||||
var
|
||||
a: MyHiddenObjcClass;
|
||||
begin
|
||||
a:=NSObject(MyHiddenObjcClass.alloc).init;
|
||||
a.release;
|
||||
end.
|
||||
45
tests/test/uobjcl1.pp
Normal file
45
tests/test/uobjcl1.pp
Normal file
@ -0,0 +1,45 @@
|
||||
{$mode objfpc}
|
||||
{$modeswitch objectivec1}
|
||||
|
||||
unit uobjcl1;
|
||||
|
||||
interface
|
||||
|
||||
type
|
||||
MyLibObjCClass = objcclass(NSObject)
|
||||
public
|
||||
fa: byte;
|
||||
function publicfun: byte; message 'publicfun';
|
||||
protected
|
||||
fb: byte;
|
||||
function protectedfun: byte; message 'protectedfun';
|
||||
private
|
||||
fc: byte;
|
||||
function privatefun: byte; message 'privatefun';
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
function MyLibObjCClass.publicfun: byte;
|
||||
begin
|
||||
result:=fa;
|
||||
end;
|
||||
|
||||
|
||||
function MyLibObjCClass.protectedfun: byte;
|
||||
begin
|
||||
result:=fb;
|
||||
end;
|
||||
|
||||
|
||||
function MyLibObjCClass.privatefun: byte;
|
||||
begin
|
||||
result:=fc;
|
||||
end;
|
||||
|
||||
type
|
||||
MyHiddenObjcClass = objcclass(NSObject)
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
Loading…
Reference in New Issue
Block a user