pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

added: _stretreg funcion; 1.0 ivariables binding; missing type encoding constants; common objc_msgSend* loading

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@760 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
skalogryz
2009-04-03 10:18:44 +00:00
parent 4c15005f84
commit 60127de191
4 changed files with 260 additions and 108 deletions
Download Patch File Download Diff File Expand all files Collapse all files

60
bindings/objc/objcrtl.pas
View File

@ -231,6 +231,7 @@ var
objc_msgSend : function (self: id; op: SEL; param3: array of const): id; cdecl = nil;
objc_msgSendSuper : function (super: pobjc_super; op: SEL; param3: array of const): id; cdecl = nil;
objc_msgSend_stret : procedure (stret: Pointer; self: id; op: SEL; param3: array of const); cdecl= nil;
objc_msgSend_stretreg : function (self: id; op: SEL; param3: array of const): id; cdecl= nil;
objc_msgSendSuper_stret : procedure (stret: Pointer; super: pobjc_super; op: SEL; param3: array of const); cdecl = nil;
objc_msgSend_fpret : function (self: id; op: SEL; param3: array of const): double; cdecl = nil;
{$WARNINGS ON}
@ -240,6 +241,34 @@ var
objc_collect : procedure (options: LongWord); cdecl= nil;
objc_collectingEnabled : function : BOOL; cdecl= nil;
const
_C_ID = '@';
_C_CLASS = '#';
_C_SEL = ':';
_C_CHR = 'c';
_C_UCHR = 'C';
_C_SHT = 's';
_C_USHT = 'S';
_C_INT = 'i';
_C_UINT = 'I';
_C_LNG = 'l';
_C_ULNG = 'L';
_C_FLT = 'f';
_C_DBL = 'd';
_C_BFLD = 'b';
_C_VOID = 'v';
_C_UNDEF = '?';
_C_PTR = '^';
_C_CHARPTR = '*';
_C_ARY_B = '[';
_C_ARY_E = ']';
_C_UNION_B = '(';
_C_UNION_E = ')';
_C_STRUCT_B = '{';
_C_STRUCT_E = '}';
_C_PASOBJ = _C_PTR + _C_VOID;
_C_SELF_AND_SEL = '@:';
// objc-exception.h
// compiler reserves a setjmp buffer + 4 words as localExceptionData
@ -296,10 +325,6 @@ OBJC_EXPORT objc_uncaught_exception_handler objc_setUncaughtExceptionHandler(obj
}
// since exception handling does not change from version to version
// it's nice to make a common RTL loading function for exception functions.
// this proc, MUST BE called by run-time initialization proc!
function LoadDefaultObjCExepction(hnd: TLibHandle): Boolean;
// objc-sync.h
@ -307,7 +332,7 @@ var
// Begin synchronizing on 'obj'.
// Allocates recursive pthread_mutex associated with 'obj' if needed.
// Returns OBJC_SYNC_SUCCESS once lock is acquired.
objc_sync_enter: function (obj: id ): Integer; cdecl = nil;
objc_sync_enter: function (obj: id): Integer; cdecl = nil;
// End synchronizing on 'obj'.
// Returns OBJC_SYNC_SUCCESS or OBJC_SYNC_NOT_OWNING_THREAD_ERROR
objc_sync_exit : function (obj: id) : Integer; cdecl = nil;
@ -327,7 +352,12 @@ const
OBJC_SYNC_TIMED_OUT = -2;
OBJC_SYNC_NOT_INITIALIZED = -3;
// since exception handling does not change from version to version
// it's nice to make a common RTL loading function for exception functions.
// this proc, MUST BE called by run-time initialization proc!
function LoadDefaultObjCExepction(hnd: TLibHandle): Boolean;
function LoadDefaultObjCSync(hnd: TLibHandle): Boolean;
function LoadDefaultObjCMessaging(hnd: TLibHandle): Boolean;
implementation
@ -336,8 +366,8 @@ begin
Result := hnd <> 0;
if not Result then Exit;
objc_exception_throw := Tobjc_exception_throw( GetProcedureAddress(hnd, 'objc_exception_throw'));
objc_exception_try_enter := Tobjc_exception_try_enter( GetProcedureAddress(hnd, 'objc_exception_try_enter'));
objc_exception_throw := Tobjc_exception_throw(GetProcedureAddress(hnd, 'objc_exception_throw'));
objc_exception_try_enter := Tobjc_exception_try_enter(GetProcedureAddress(hnd, 'objc_exception_try_enter'));
objc_exception_try_exit := Tobjc_exception_try_exit(GetProcedureAddress(hnd, 'objc_exception_try_exit'));
objc_exception_extract := Tobjc_exception_extract(GetProcedureAddress(hnd, 'objc_exception_extract'));
objc_exception_match := Tobjc_exception_match(GetProcedureAddress(hnd, 'objc_exception_match'));
@ -354,6 +384,22 @@ begin
Pointer(objc_sync_notifyAll) := GetProcedureAddress(hnd, 'objc_sync_notifyAll');
end;
function LoadDefaultObjCMessaging(hnd: TLibHandle): Boolean;
begin
Pointer(objc_msgSend) := GetProcedureAddress(hnd, 'objc_msgSend');
Pointer(objc_msgSendSuper) := GetProcedureAddress(hnd, 'objc_msgSendSuper');
Pointer(objc_msgSend_stret) := GetProcedureAddress(hnd, 'objc_msgSend_stret');
Pointer(objc_msgSendSuper_stret) := GetProcedureAddress(hnd, 'objc_msgSendSuper_stret');
{$ifndef CPUPOWERPC} // arm also uses objc_msgSend_fpret?
Pointer(objc_msgSend_fpret) := GetProcedureAddress(hnd, 'objc_msgSend_fpret');
Pointer(objc_msgSend_stretreg) := GetProcedureAddress(hnd, 'objc_msgSend');
{$else}
Pointer(objc_msgSend_fpret) := GetProcedureAddress(hnd, 'objc_msgSend');
Pointer(objc_msgSend_stretreg) := GetProcedureAddress(hnd, 'objc_msgSend_streg');
{$endif}
end;
initialization
end.

245
bindings/objc/objcrtl10.pas
View File

@ -31,11 +31,35 @@ uses
http://developer.apple.com/documentation/Cocoa/Reference/ObjCRuntimeRef/Articles/ocr10_5delta.html#//apple_ref/doc/uid/TP40002981-TPXREF101
}
function InitializeObjCRtl10(const ObjCLibName: AnsiString): Boolean;
implementation
{$HINTS OFF} {.Parameter not used.}
function ObjCAllocMem(size: Integer): Pointer;
begin
//todo: store the mem pointers
// and release them at finalization section
// this must be thread safe, so allocating additional NsObject
// that can be used with objc_sync is recommended
Result := AllocMem(size);
end;
procedure ObjCFreeMem(p: Pointer);
begin
//todo:
Freemem(p);
end;
function allocstr(const src: String): Pchar;
begin
Result := ObjCAllocMem(length(src)+1);
if src <> '' then System.Move(src[1], Result^, length(src));
end;
const
CLS_CLASS = $1;
CLS_META = $2;
@ -198,53 +222,102 @@ var
//class_addMethods : procedure (myClass: _Class1; methodList : Pobjc_method_list1); cdecl;
type
TClassMethod1Reg = record
listpointer : Pobjc_method_list1;
itemscount : Integer;
{ TClassMethod1Reg }
TClassMethod1Reg = class(TObject)
private
methods : array of objc_method1;
count : Integer;
public
procedure AddMethod(name:SEL; imp:IMP; types:pchar);
function AllocMethodList: Pobjc_method_list1;
end;
PClassMethod1Reg = ^TClassMethod1Reg;
//PClassMethod1Reg = ^TClassMethod1Reg;
function AllocMethodReg: PClassMethod1Reg;
begin
Result := GetMem(sizeof (TClassMethod1Reg));
Result^.itemscount := 0;
Result^.listpointer := Pointer(-1);
end;
TIVar1Reg = record
size : Integer;
types : String;
name : String;
alignment : Uint8_t;
end;
function ReleaseMethodReg(p : PClassMethod1Reg): PPobjc_method_list1;
begin
Result := GetMem(sizeof(Pobjc_method_list1));
if p^.itemscount = 0
then Result^ := Pointer(-1)
else Result^ := p^.listpointer;
Freemem(p);
end;
{ TClassIVar1Reg }
procedure AddMethodToList(var list: TClassMethod1Reg; name:SEL; imp:IMP; types:pchar);
var
n : Integer;
sz : Integer;
nlist : Pobjc_method_list1;
TClassIVar1Reg = class(TObject)
private
ivarscount : Integer;
ivars : array of TIVar1Reg;
public
procedure AddIVar(name:pchar; size:size_t; alignment:uint8_t; types:pchar);
function AllocIVarsList(ivarOffset: Integer; out ivarssize: Integer): Pobjc_ivar_list1;
end;
{ TClassMethod1Reg }
procedure TClassMethod1Reg.AddMethod(name: SEL; imp: IMP; types: pchar);
begin
if list.itemscount = 0 then begin
list.listpointer := GetMem(sizeof(objc_method_list1));
list.listpointer^.method_count := 1;
list.itemscount := 1;
n := 0;
end else begin
if list.listpointer^.method_count = list.itemscount then begin
list.itemscount := list.itemscount * 2;
sz := sizeof(objc_method_list1) + ((list.itemscount) - 1) * sizeof(objc_method1);
nlist := GetMem(sz);
sz := sizeof(objc_method_list1) + ((list.listpointer^.method_count) - 1) * sizeof(objc_method1);
System.Move(list.listpointer^, nlist^, sizeof(objc_method_list1) + ((list.itemscount) - 1) * sizeof(objc_method1));
if length(methods) = count then begin
if count = 0 then SetLength(methods, 4)
else begin
SetLength(methods, count * 2);
end;
end;
methods[count].method_imp := IMP1(imp);
methods[count].method_types := allocstr(types);
methods[count].method_name := name;
inc(count);
end;
function TClassMethod1Reg.AllocMethodList: Pobjc_method_list1;
var
i : Integer;
begin
if count = 0 then Result := nil
else begin
Result := ObjCAllocMem( sizeof(objc_method_list1) + (count-1)*sizeof(objc_method1) );
Pobjc_method_list1(Result)^.method_count := count;
for i := 0 to count - 1 do begin
Pobjc_method_list1(Result)^.method_list1[i].method_name := methods[i].method_name;
Pobjc_method_list1(Result)^.method_list1[i].method_types := methods[i].method_types;
Pobjc_method_list1(Result)^.method_list1[i].method_imp := methods[i].method_imp;
end;
end;
end;
procedure TClassIVar1Reg.AddIVar(name: pchar; size: size_t; alignment: uint8_t;
types: pchar);
begin
if ivarscount = length(ivars) then begin
if ivarscount = 0 then SetLength(ivars, 4)
else setLength(ivars, ivarscount * 2);
end;
ivars[ivarscount].name := name;
ivars[ivarscount].size := size;
ivars[ivarscount].types := types;
ivars[ivarscount].alignment := alignment;
inc(ivarscount);
end;
function TClassIVar1Reg.AllocIVarsList(ivarOffset: Integer; out ivarssize: Integer): Pobjc_ivar_list1;
var
i : Integer;
begin
if ivarscount = 0 then begin
Result := nil;
ivarssize := 0;
end else begin
ivarssize := 0;
Result := ObjCAllocMem( sizeof(objc_ivar_list1) + (ivarscount-1)*sizeof(objc_ivar1) );
Result^.ivar_count := ivarscount;
for i := 0 to ivarscount - 1 do begin
Result^.ivar_list[i].ivar_name := allocstr(ivars[i].name);
Result^.ivar_list[i].ivar_offset := ivarOffset + ivarssize;
Result^.ivar_list[i].ivar_type := allocstr(ivars[i].name);
inc(ivarssize, ivars[i].size);
end;
n := list.listpointer^.method_count;
inc(list.listpointer^.method_count);
end;
list.listpointer^.method_list1[n].method_types := types;
list.listpointer^.method_list1[n].method_imp := IMP1(imp);
list.listpointer^.method_list1[n].method_name := SEL1(name);
end;
function object_getClass10(obj:id): _Class; cdecl;
@ -341,7 +414,7 @@ begin
root_class := root_class^.super_class;
// Allocate space for the class and its metaclass
new_class := AllocMem(2 * SizeOf(objc_class1));
new_class := ObjCAllocMem(2 * SizeOf(objc_class1));
meta_class := @new_class[1];
// setup class
@ -354,14 +427,14 @@ begin
// to share this copy of the name, but this is not a requirement
// imposed by the runtime.
namelen := strlen(name);
new_class^.name := AllocMem(namelen + 1);
new_class^.name := ObjCAllocMem(namelen + 1);
Move(name^, new_class^.name^, namelen);
meta_class^.name := new_class^.name;
// Allocate empty method lists.
// We can add methods later.
new_class^.methodLists := PPObjc_method_list1(AllocMethodReg); //AllocMem ( SizeOf(TClassMethod1Reg)) ;// SizeOf(Pobjc_method_list1));
meta_class^.methodLists := PPObjc_method_list1(AllocMethodReg);
new_class^.methodLists := Pointer(TClassMethod1Reg.Create); // PPObjc_method_list1(AllocMethodReg); //AllocMem ( SizeOf(TClassMethod1Reg)) ;// SizeOf(Pobjc_method_list1));
meta_class^.methodLists := Pointer(TClassMethod1Reg.Create); //PPObjc_method_list1(AllocMethodReg);
// Connect the class definition to the class hierarchy:
// Connect the class to the superclass.
@ -374,6 +447,7 @@ begin
// Set the sizes of the class and the metaclass.
new_class^.instance_size := super^.instance_size;
meta_class^.instance_size := meta_class^.super_class^.instance_size;
new_class^.ivars := Pointer(TClassIVar1Reg.Create);
Result := new_class;
end;
@ -382,15 +456,46 @@ procedure objc_registerClassPair10(aClass:_Class); cdecl;
var
meta_class : _Class1;
new_class : _Class1;
MethodReg : TClassMethod1Reg;
iVarReg : TClassIVar1Reg;
ivarslist : Pobjc_ivar_list1;
sz : Integer;
procedure RegisterMethodList(reg: TClassMethod1Reg; cls1: _Class1);
var
mtdlist : Pobjc_method_list1;
begin
if not Assigned(reg) then Exit;
cls1^.methodLists := ObjCAllocMem(sizeof(Pobjc_method_list1));
mtdList := reg.AllocMethodList;
if not Assigned(mtdlist)
then cls1^.methodLists^ := Pointer(-1)
else cls1^.methodLists^ := mtdlist;
end;
begin
new_class := _Class1(aClass);
// Finally, register the class with the runtime.
new_class^.methodLists := ReleaseMethodReg(PClassMethod1Reg(new_class^.methodLists));
meta_class := _Class1(new_Class)^.isa;
meta_class^.methodLists := ReleaseMethodReg(PClassMethod1Reg(meta_class^.methodLists));
// Finally, register the class with the runtime.
if new_class <> nil then
objc_addClass(new_class);
MethodReg := TClassMethod1Reg(new_class^.methodLists);
RegisterMethodList(MethodReg, new_class);
MethodReg.Free;
MethodReg := TClassMethod1Reg(meta_class^.methodLists);
RegisterMethodList(MethodReg, meta_class);
MethodReg.Free;
iVarReg := TClassIVar1Reg(new_class^.ivars);
ivarslist := iVarReg.AllocIVarsList(new_class^.instance_size, sz);
new_class^.ivars := ivarslist;
inc(new_class^.instance_size, sz);
iVarReg.Free;
if new_class <> nil then objc_addClass(new_class);
end;
function objc_duplicateClass10(original:_Class; name:pchar; extraBytes:size_t):_Class; cdecl;
@ -403,26 +508,27 @@ begin
end;
function class_addMethod10(cls:_Class; name:SEL; imp:IMP; types:pchar):BOOL; cdecl;
var
//list : Pobjc_method_list1;
reg : PClassMethod1Reg;
function class_addMethod10(cls:_Class; name:SEL; _imp:IMP; types:pchar):BOOL; cdecl;
begin
reg := PClassMethod1Reg(_Class1(cls)^.methodLists);
AddMethodToList( reg^, name, imp, types);
{ list := GetMem(sizeof(objc_method_list1));
list^.method_count := 1;
list^.method_list1[0].method_imp := IMP1(imp);
list^.method_list1[0].method_name := SEL1(name);
list^.method_list1[0].method_types := types;
class_addMethods(cls, @list);}
if not Assigned(cls) or not Assigned(name) or not Assigned(_imp) or not Assigned(types) then begin
Result := false;
Exit;
end;
TClassMethod1Reg(_Class1(cls)^.methodLists).AddMethod(name, _imp, types);
Result := true;
end;
function class_addIvar10(cls:_Class; name:pchar; size:size_t; alignment:uint8_t; types:pchar):BOOL; cdecl;
var
cls1 : _Class1;
begin
Result := false;
if (alignment <> 1) or (class_isMetaClass10(cls)) then begin
Result := false;
Exit;
end;
cls1 := _Class1(cls);
TClassIVar1Reg(cls1^.ivars).AddIVar(name, size, alignment, types);
Result := true;
end;
function class_addProtocol10(cls:_Class; protocol:pProtocol):BOOL; cdecl;
@ -670,17 +776,8 @@ begin
//Messaging
//The following functions are unchanged:
Pointer(objc_msgSend) := GetProcedureAddress(hnd, 'objc_msgSend');
Pointer(objc_msgSend_stret) := GetProcedureAddress(hnd, 'objc_msgSend_stret');
Pointer(objc_msgSendSuper) := GetProcedureAddress(hnd, 'objc_msgSendSuper');
Pointer(objc_msgSendSuper_stret) := GetProcedureAddress(hnd, 'objc_msgSendSuper_stret');
LoadDefaultObjCMessaging(hnd);
{$ifndef CPUPOWERPC} // arm also uses objc_msgSend_fpret ?
Pointer(objc_msgSend_fpret) := GetProcedureAddress(hnd, 'objc_msgSend_fpret');
{$else}
Pointer(objc_msgSend_fpret) := GetProcedureAddress(hnd, 'objc_msgSend');
{$endif}
//The following functions are removed:objc_msgSendv Given an argument list, send a message with a simple return value.
//objc_msgSendv_stret Given an argument list, send a message with a data-structure return value.

12
bindings/objc/objcrtl20.pas
View File

@ -145,16 +145,8 @@ begin
Pointer(objc_setEnumerationMutationHandler) := GetProcedureAddress(hnd, 'objc_setEnumerationMutationHandler');
Pointer(objc_setForwardHandler) := GetProcedureAddress(hnd, 'objc_setForwardHandler');
Pointer(objc_msgSend) := GetProcedureAddress(hnd, 'objc_msgSend');
Pointer(objc_msgSendSuper) := GetProcedureAddress(hnd, 'objc_msgSendSuper');
Pointer(objc_msgSend_stret) := GetProcedureAddress(hnd, 'objc_msgSend_stret');
Pointer(objc_msgSendSuper_stret) := GetProcedureAddress(hnd, 'objc_msgSendSuper_stret');
{$ifndef CPUPOWERPC} // arm also uses objc_msgSend_fpret?
Pointer(objc_msgSend_fpret) := GetProcedureAddress(hnd, 'objc_msgSend_fpret');
{$else}
Pointer(objc_msgSend_fpret) := GetProcedureAddress(hnd, 'objc_msgSend');
{$endif}
//Messaging
LoadDefaultObjCMessaging(hnd);
Pointer(method_invoke) := GetProcedureAddress(hnd, 'method_invoke');
Pointer(method_invoke_stret) := GetProcedureAddress(hnd, 'method_invoke_stret');

51
bindings/objc/objcrtltest.pas
View File

@ -27,7 +27,8 @@ type
PSmallRecord = ^TSmallRecord;
TSmallRecord = packed record
a,b,c: byte;
//d: byte;
//d : Integer;
d: byte;
end;
const
@ -50,6 +51,7 @@ const
newMethod5 = 'getSmallRecord';
newMethod5Enc = '{TSmallRecord=ccc}@:';
varName = 'myvar';
function imp_init(self: id; _cmd: SEL): id; cdecl;
var
@ -79,12 +81,12 @@ begin
Result := 3.125;
end;
procedure imp_getSmallRec(Result: PSmallRecord; seld: id; _cmd: SEL); cdecl;
function imp_getSmallRec(seld: id; _cmd: SEL): TSmallRecord; cdecl;
begin
Result^.a := 121;
Result^.b := 68;
Result^.c := 22;
//Result.d := 5;
Result.a := 121;
Result.b := 68;
Result.c := 22;
Result.d := 5;
end;
@ -101,13 +103,23 @@ begin
class_addMethod(cl, selector(newMethod4), @imp_newMethod4, newMethod4Enc);
class_addMethod(cl, selector(newMethod5), @imp_getSmallRec, newMethod5Enc);
if not b then writeln('failed to add/override some method(s)');
class_addIvar(cl, varName, sizeof(TObject), 1, _C_PASOBJ);
objc_registerClassPair(cl);
end;
var
obj : id;
stret : TSmallRecord;
buf : array [0..255] of byte;
obj : id;
objvar : Ivar;
stret : TSmallRecord;
varobj : TObject;
p : Pointer;
type
TgetSmallRecord = function (obj: id; cmd: Sel; arg: array of const): TSmallRecord; cdecl;
begin
// if InitializeObjcRtl20(DefaultObjCLibName) then // should be used of OSX 10.5 and iPhoneOS
@ -119,27 +131,32 @@ begin
end;
RegisterSubclass(newClassName);
writeln('registered');
obj := AllocAndInit(newClassName);
{obj := alloc(newClassName);
objc_msgSend(obj, selector(overrideMethod), []);}
writeln('sizeof(TSmallRecord) = ', sizeof(TSmallRecord));
stret := TgetSmallRecord(objc_msgSend_stretreg)(obj, selector(newMethod5), []);
//writeln('p = ', Integer(p));
//stret :=
writeln('stret.a = ', stret.a);
writeln('stret.b = ', stret.b);
writeln('stret.c = ', stret.c);
writeln('stret.d = ', stret.d);
//PInteger(@stret)^ := Integer(objc_msgSend(obj, selector(newMethod5), []));
objc_msgSend(obj, selector(newMethod1), []);
objc_msgSend(obj, selector(newMethod2), [5, 4]);
writeln('get double = ', objc_msgSend_fpret(obj, selector(newMethod3), []));
writeln('get float = ', objc_msgSend_fpret(obj, selector(newMethod4), []));
writeln('sizeof(TSmallRecord) = ', sizeof(TSmallRecord));
objc_msgSend_stret(@stret, obj, selector(newMethod5), []);
writeln('stret.a = ', stret.a);
writeln('stret.b = ', stret.b);
writeln('stret.c = ', stret.c);
release( obj );
writeln('test successfully complete');
end.