Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Merge branch 'nom' into newio
  • Loading branch information
@lizmat
lizmat committed Feb 23, 2015
2 parents fb24e4b + 0ec17f3 commit 96a69ac
Show file tree
Hide file tree
Showing 9 changed files with 107 additions and 69 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
2 changes: 2 additions & 0 deletions src/Perl6/Actions.nqp
View file
Expand Up @@ -6038,7 +6038,9 @@ class Perl6::Actions is HLL::Actions does STDActions {
}

method quote:sym<apos>($/) { make $<nibble>.ast; }
method quote:sym<sapos>($/){ make $<nibble>.ast; }
method quote:sym<dblq>($/) { make $<nibble>.ast; }
method quote:sym<sdblq>($/){ make $<nibble>.ast; }
method quote:sym<crnr>($/) { make $<nibble>.ast; }
method quote:sym<qq>($/) { make $<quibble>.ast; }
method quote:sym<q>($/) { make $<quibble>.ast; }
Expand Down
8 changes: 8 additions & 0 deletions src/Perl6/Grammar.nqp
View file
Expand Up @@ -3442,7 +3442,9 @@ grammar Perl6::Grammar is HLL::Grammar does STD {

proto token quote { <...> }
token quote:sym<apos> { :dba('single quotes') "'" ~ "'" <nibble(self.quote_lang(%*LANG<Q>, "'", "'", ['q']))> }
token quote:sym<sapos> { :dba('smart single quotes') "‘" ~ "’" <nibble(self.quote_lang(%*LANG<Q>, "‘", "’", ['q']))> }
token quote:sym<dblq> { :dba('double quotes') '"' ~ '"' <nibble(self.quote_lang(%*LANG<Q>, '"', '"', ['qq']))> }
token quote:sym<sdblq> { :dba('smart double quotes') '“' ~ '”' <nibble(self.quote_lang(%*LANG<Q>, '“', '”', ['qq']))> }
token quote:sym<crnr> { :dba('corner quotes') '｢' ~ '｣' <nibble(self.quote_lang(%*LANG<Q>, '｢', '｣'))> }
token quote:sym<q> {
:my $qm;
Expand Down Expand Up @@ -4611,9 +4613,15 @@ grammar Perl6::QGrammar is HLL::Grammar does STD {
token escape:sym<' '> {
<?[']> <quote=.LANG('MAIN','quote')>
}
token escape:sym<‘ ’> {
<?[‘]> <quote=.LANG('MAIN','quote')>
}
token escape:sym<" "> {
<?["]> <quote=.LANG('MAIN','quote')>
}
token escape:sym<“ ”> {
<?[“]> <quote=.LANG('MAIN','quote')>
}
token escape:sym<colonpair> {
<?[:]> <colonpair=.LANG('MAIN','colonpair')>
}
Expand Down
20 changes: 10 additions & 10 deletions src/Perl6/Metamodel/Archetypes.nqp
View file
Expand Up @@ -48,14 +48,14 @@ class Perl6::Metamodel::Archetypes {
# Are we allowed to augment the type?
has $!augmentable;

method nominal() { $!nominal }
method nominalizable() { $!nominalizable }
method inheritable() { $!inheritable }
method inheritalizable() { $!inheritalizable }
method composable() { $!composable }
method composalizable() { $!composalizable }
method generic() { $!generic }
method parametric() { $!parametric }
method coercive() { $!coercive }
method augmentable() { $!augmentable }
method nominal() { $!nominal // 0 }
method nominalizable() { $!nominalizable // 0 }
method inheritable() { $!inheritable // 0 }
method inheritalizable() { $!inheritalizable // 0 }
method composable() { $!composable // 0 }
method composalizable() { $!composalizable // 0 }
method generic() { $!generic // 0 }
method parametric() { $!parametric // 0 }
method coercive() { $!coercive // 0 }
method augmentable() { $!augmentable // 0 }
}
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 96a69ac

Please sign in to comment.