Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
add typed Pointer type as replacement for OpaquePointer 
A Pointer can still be used as is, and will Pointer[void] (void*).
When a Pointer points to something more useful(i.e. Pointer[int32]),
one can call method 'deref' on the pointer to reveal the the thing
it is pointing to. Besides that a Pointer can still be instantiatet
using a memory address and numifies back to that mem address.
We export the OpaquePointer type as an alias to Pointer, to allow
adoption before we OpaquePointer gets deprecated.
  • Loading branch information
@FROGGS
FROGGS committed Feb 23, 2015
1 parent a2a1afb commit 5ec0c6e
Show file tree
Hide file tree
Showing 6 changed files with 87 additions and 59 deletions.
92 changes: 60 additions & 32 deletions lib/NativeCall.pm
View file
Expand Up @@ -65,7 +65,63 @@ sub return_hash_for(Signature $s, &r?, :$with-typeobj) {
$result
}

my native long is repr("P6int") is Int is ctype("long") is export(:types, :DEFAULT) { };
my native long is Int is ctype("long") is repr("P6int") is export(:types, :DEFAULT) { };
my native longlong is Int is ctype("longlong") is repr("P6int") is export(:types, :DEFAULT) { };
my class void is repr('CPointer') is export(:types, :DEFAULT) { };
# Expose a Pointer class for working with raw pointers.
my class Pointer is repr('CPointer') is export(:types, :DEFAULT) { };

# need to introduce the roles in there in an augment, because you can't
# inherit from types that haven't been properly composed.
use MONKEY_TYPING;
augment class Pointer {
method of() { void }

method ^name() { 'Pointer' }

multi method new() {
self.CREATE()
}
multi method new(int $addr) {
nqp::box_i($addr, ::?CLASS)
}
multi method new(Int $addr) {
nqp::box_i(nqp::unbox_i(nqp::decont($addr)), ::?CLASS)
}

method Numeric(::?CLASS:D:) { self.Int }
method Int(::?CLASS:D:) {
nqp::p6box_i(nqp::unbox_i(nqp::decont(self)))
}

method deref(::?CLASS:D \ptr:) { nativecast(void, ptr) }

multi method gist(::?CLASS:U:) { '(' ~ self.^name ~ ')' }
multi method gist(::?CLASS:D:) {
if self.Int -> $addr {
self.^name ~ '<' ~ $addr.fmt('%#x') ~ '>'
}
else {
self.^name ~ '<NULL>'
}
}

multi method perl(::?CLASS:U:) { self.^name }
multi method perl(::?CLASS:D:) { self.^name ~ '.new(' ~ self.Int ~ ')' }

my role TypedPointer[::TValue = void] is Pointer is repr('CPointer') {
method of() { ::TValue }
method ^name() { 'Pointer[' ~ ::TValue.^name ~ ']' }
method deref(::?CLASS:D \ptr:) { nativecast(::TValue, ptr) }
}
multi method PARAMETERIZE_TYPE(Mu:U \t) {
die "A typed pointer can only hold integers, numbers, strings, CStructs, CPointers or CArrays (not {t.^name})"
unless t ~~ Int || t ~~ Num || t === Str || t.REPR eq 'CStruct' | 'CUnion' | 'CPPStruct' | 'CPointer' | 'CArray';
my \typed := TypedPointer[t];
typed.HOW.make_pun(typed);
}
}
my constant OpaquePointer is export(:types, :DEFAULT) = Pointer;

# Gets the NCI type code to use based on a given Perl 6 type.
my %type_map =
Expand Down Expand Up @@ -96,8 +152,8 @@ sub type_code_for(Mu ::T) {
# the REPR of a Buf or Blob type object is Uninstantiable, so
# needs an extra special case here that isn't covered in the
# hash lookup above.
return 'vmarray'
if T ~~ Blob;
return 'vmarray' if T ~~ Blob;
return 'cpointer' if T ~~ Pointer;
die "Unknown type {T.^name} used in native call.\n" ~
"If you want to pass a struct, be sure to use the CStruct representation.\n" ~
"If you want to pass an array, be sure to use the CArray type.";
Expand Down Expand Up @@ -170,36 +226,8 @@ my role NativeCallEncoded[$name] {
method native_call_encoded() { $name };
}

# Expose an OpaquePointer class for working with raw pointers.
my class OpaquePointer is export(:types, :DEFAULT) is repr('CPointer') {
multi method new() {
self.CREATE()
}
multi method new(int $addr) {
nqp::box_i($addr, OpaquePointer)
}
multi method new(Int $addr) {
nqp::box_i(nqp::unbox_i(nqp::decont($addr)), OpaquePointer)
}
method Int(OpaquePointer:D:) {
nqp::p6box_i(nqp::unbox_i(nqp::decont(self)))
}
method Numeric(OpaquePointer:D:) { self.Int }
multi method gist(OpaquePointer:U:) { '(OpaquePointer)' }
multi method gist(OpaquePointer:D:) {
if self.Int -> $addr {
'OpaquePointer<' ~ $addr.fmt('%#x') ~ '>'
}
else {
'OpaquePointer<NULL>'
}
}
multi method perl(OpaquePointer:U:) { 'OpaquePointer' }
multi method perl(OpaquePointer:D:) { 'OpaquePointer.new(' ~ self.Int ~ ')' }
}

# CArray class, used to represent C arrays.
my class CArray is export(:types, :DEFAULT) is repr('CArray') is array_type(OpaquePointer) { };
my class CArray is export(:types, :DEFAULT) is repr('CArray') is array_type(Pointer) { };

# need to introduce the roles in there in an augment, because you can't
# inherit from types that haven't been properly composed.
Expand Down
16 changes: 8 additions & 8 deletions t/04-nativecall/04-pointers.t
View file
Expand Up @@ -8,8 +8,8 @@ plan 10;

compile_test_lib('04-pointers');

sub ReturnSomePointer() returns OpaquePointer is native("./04-pointers") { * }
sub CompareSomePointer(OpaquePointer) returns int32 is native("./04-pointers") { * }
sub ReturnSomePointer() returns Pointer is native("./04-pointers") { * }
sub CompareSomePointer(Pointer) returns int32 is native("./04-pointers") { * }

my $x = ReturnSomePointer();
my int $a = 4321;
Expand All @@ -18,9 +18,9 @@ ok CompareSomePointer($x), 'Got passed back the pointer I returned';
ok $x, 'Non-NULL pointer is trueish';
ok $x.Int, 'Calling .Int on non-NULL pointer is trueish';
ok +$x, 'Calling prefix:<+> on non-NULL pointer is trueish';
is +$x.perl.EVAL, +$x, 'OpaquePointer roundtrips okay using .perl and EVAL';
is OpaquePointer.new.gist, 'OpaquePointer<NULL>', 'OpaquePointer.new gistifies to "OpaquePointer<NULL>"';
is OpaquePointer.new(0).gist, 'OpaquePointer<NULL>', 'OpaquePointer.new(0) gistifies to "OpaquePointer<NULL>"';
is OpaquePointer.new(1234).gist, 'OpaquePointer<0x4d2>', 'OpaquePointer.new(1234) gistifies to "OpaquePointer<0x4d2>"';
is OpaquePointer.new($a).gist, 'OpaquePointer<0x10e1>', 'OpaquePointer.new accepts a native int too';
is OpaquePointer.gist, '(OpaquePointer)', 'The OpaquePointer type object gistifies ot "OpaquePointer"';
is +$x.perl.EVAL, +$x, 'Pointer roundtrips okay using .perl and EVAL';
is Pointer.new.gist, 'Pointer<NULL>', 'Pointer.new gistifies to "Pointer<NULL>"';
is Pointer.new(0).gist, 'Pointer<NULL>', 'Pointer.new(0) gistifies to "Pointer<NULL>"';
is Pointer.new(1234).gist, 'Pointer<0x4d2>', 'Pointer.new(1234) gistifies to "Pointer<0x4d2>"';
is Pointer.new($a).gist, 'Pointer<0x10e1>', 'Pointer.new accepts a native int too';
is Pointer.gist, '(Pointer)', 'The Pointer type object gistifies ot "Pointer"';
4 changes: 2 additions & 2 deletions t/04-nativecall/05-arrays.t
View file
Expand Up @@ -42,8 +42,8 @@ compile_test_lib('05-arrays');
}

{
my @arr := CArray[OpaquePointer].new;
@arr[1] = OpaquePointer.new;
my @arr := CArray[Pointer].new;
@arr[1] = Pointer.new;
my $x = @arr[0];
pass 'getting uninitialized element in managed array';
}
Expand Down
2 changes: 1 addition & 1 deletion t/04-nativecall/07-writebarrier.t
View file
Expand Up @@ -24,7 +24,7 @@ class Structy is repr('CStruct') {
sub make_ptr() returns IntPtr is native('./07-writebarrier') { * }
sub array_twiddle(CArray[IntPtr] $a) is native('./07-writebarrier') { * }
sub struct_twiddle(Structy $s) is native('./07-writebarrier') { * }
sub dummy(CArray[OpaquePointer] $a) is native('./07-writebarrier') { * }
sub dummy(CArray[Pointer] $a) is native('./07-writebarrier') { * }
sub save_ref(Structy $s) is native('./07-writebarrier') { * }
sub atadistance() is native('./07-writebarrier') { * }

Expand Down
18 changes: 9 additions & 9 deletions t/04-nativecall/09-nativecast.t
View file
Expand Up @@ -8,33 +8,33 @@ plan(9);

compile_test_lib('09-nativecast');

sub ReturnArray() returns OpaquePointer is native('./09-nativecast') { * }
sub ReturnArray() returns Pointer is native('./09-nativecast') { * }
my $carray = nativecast(CArray[uint32], ReturnArray());
is $carray[0..2], (1, 2, 3), 'casting int * to CArray[uint32] works';

sub ReturnStruct() returns OpaquePointer is native('./09-nativecast') { * };
sub ReturnStruct() returns Pointer is native('./09-nativecast') { * };
class CUTE is repr('CStruct') {
has int32 $.i;
}
is nativecast(CUTE, ReturnStruct()).i, 100, 'casting to CStruct works';

sub ReturnInt() returns OpaquePointer is native('./09-nativecast') { * }
sub ReturnInt() returns Pointer is native('./09-nativecast') { * }
is nativecast(int32, ReturnInt()), 101, 'casting to int32 works';

sub ReturnShort() returns OpaquePointer is native('./09-nativecast') { * }
sub ReturnShort() returns Pointer is native('./09-nativecast') { * }
is nativecast(int16, ReturnShort()), 102, 'casting to int16 works';

sub ReturnByte() returns OpaquePointer is native('./09-nativecast') { * }
sub ReturnByte() returns Pointer is native('./09-nativecast') { * }
is nativecast(int8, ReturnByte()), -103, 'casting to int8 works';

sub ReturnDouble() returns OpaquePointer is native('./09-nativecast') { * }
sub ReturnDouble() returns Pointer is native('./09-nativecast') { * }
is_approx nativecast(num64, ReturnDouble()), 99.9e0, 'casting to num64 works';

sub ReturnFloat() returns OpaquePointer is native('./09-nativecast') { * }
sub ReturnFloat() returns Pointer is native('./09-nativecast') { * }
is_approx nativecast(num32, ReturnFloat()), -4.5e0, 'casting to num32 works';

sub ReturnString() returns OpaquePointer is native('./09-nativecast') { * }
sub ReturnString() returns Pointer is native('./09-nativecast') { * }
is nativecast(str, ReturnString()), "epic cuteness", 'casting to str works';

sub ReturnNullString returns OpaquePointer is native('./09-nativecast') { * }
sub ReturnNullString returns Pointer is native('./09-nativecast') { * }
nok nativecast(str, ReturnNullString()).defined, 'casting null pointer to str';
14 changes: 7 additions & 7 deletions t/04-nativecall/12-sizeof.t
View file
Expand Up @@ -45,10 +45,10 @@ sub SizeofInt() returns int32 is native('./12-sizeof') { * }
sub SizeofLng() returns int32 is native('./12-sizeof') { * }
sub SizeofPtr() returns int32 is native('./12-sizeof') { * }

is nativesizeof(Foo), SizeofFoo(), 'sizeof(Foo)';
is nativesizeof(Bar), SizeofBar(), 'sizeof(Bar)';
is nativesizeof(Baz), SizeofBaz(), 'sizeof(Baz)';
is nativesizeof(Buz), SizeofBuz(), 'sizeof(Buz)';
is nativesizeof(int32), SizeofInt(), 'sizeof(int)';
is nativesizeof(long), SizeofLng(), 'sizeof(long)';
is nativesizeof(OpaquePointer), SizeofPtr(), 'sizeof(void *)';
is nativesizeof(Foo), SizeofFoo(), 'sizeof(Foo)';
is nativesizeof(Bar), SizeofBar(), 'sizeof(Bar)';
is nativesizeof(Baz), SizeofBaz(), 'sizeof(Baz)';
is nativesizeof(Buz), SizeofBuz(), 'sizeof(Buz)';
is nativesizeof(int32), SizeofInt(), 'sizeof(int)';
is nativesizeof(long), SizeofLng(), 'sizeof(long)';
is nativesizeof(Pointer), SizeofPtr(), 'sizeof(void *)';

0 comments on commit 5ec0c6e

Please sign in to comment.