Skip to content
This repository
Jonathan Worthington March 14, 2014
file 153 lines (120 sloc) 3.986 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
use lib '.';
use t::CompileTestLib;
use NativeCall;
use Test;

plan 30;

compile_test_lib('06-struct');

class MyStruct is repr('CStruct') {
    has int $.int;
    has num $.num;
    has int8 $.byte;
    has num32 $.float;
    has CArray $.arr;

    method init() {
        $!int = 42;
        $!byte = 7;
        $!num = -3.7e0;
        $!float = 3.14e0;
        my $arr := CArray[int].new();
        $arr[0] = 1;
        $arr[1] = 2;
        $!arr := $arr;
    }
}

# Workaround a Rakudo-bug where $!arr := CArray[int].new() won't work if $.arr
# is declared as type CArray[int].
class MyStruct2 is repr('CStruct') {
    has int $.int;
    has num $.num;
    has int8 $.byte;
    has num32 $.float;
    has CArray[int] $.arr;
}

class IntStruct is repr('CStruct') {
    has int $.first;
    has int $.second;

    # Work around struct members not being containerized yet.
    method init {
        $!first = 13;
        $!second = 17;
    }
}

class NumStruct is repr('CStruct') {
    has num $.first;
    has num $.second;

    # Work around struct members not being containerized yet.
    method init {
        $!first = 0.9e0;
        $!second = 3.14e0;
    }
}

class StructStruct is repr('CStruct') {
    has IntStruct $.a;
    has NumStruct $.b;

    # Work around struct members not being containerized yet.
    method init {
        $!a := IntStruct.new;
        $!b := NumStruct.new;
        $!a.init;
        $!b.init;
    }
}

class StringStruct is repr('CStruct') {
    has Str $.first;
    has Str $.second;

    method init {
        $!first := 'Lorem';
        $!second := 'ipsum';
    }
}

class PointerThing is repr('CPointer') {
    sub _deref(PointerThing $x) returns int is native('./06-struct') { * }
    method deref() { return _deref(self); }
}

class PointerStruct is repr('CStruct') {
    has PointerThing $.p;
}

sub ReturnAStruct() returns MyStruct2 is native('./06-struct') { * }
sub TakeAStruct(MyStruct $arg) is native('./06-struct') { * }

sub ReturnAStructStruct() returns StructStruct is native('./06-struct') { * }
sub TakeAStructStruct(StructStruct $arg) is native('./06-struct') { * }

sub ReturnAPointerStruct() returns PointerStruct is native('./06-struct') { * }

sub ReturnAStringStruct() returns StringStruct is native('./06-struct') { * }
sub TakeAStringStruct(StringStruct $arg) is native('./06-struct') { * }

# Perl-side tests:
my MyStruct $obj .= new;
$obj.init;

is $obj.int, 42, 'getting int';
is_approx $obj.num, -3.7e0, 'getting num';
is $obj.byte, 7, 'getting int8';
is_approx $obj.float, 3.14e0, 'getting num32';
is $obj.arr[1], 2, 'getting CArray and element';

# C-side tests:
my $cobj = ReturnAStruct;

is $cobj.int, 17, 'getting int from C-created struct';
is_approx $cobj.num, 4.2e0, 'getting num from C-created struct';
is $cobj.byte, 13, 'getting int8 from C-created struct';
is_approx $cobj.float, -6.28e0, 'getting num32 from C-created struct';
is $cobj.arr[0], 2, 'C-created array member, elem 1';
is $cobj.arr[1], 3, 'C-created array member, elem 2';
is $cobj.arr[2], 5, 'C-created array member, elem 3';

my StructStruct $ss = ReturnAStructStruct();
is $ss.a.first, 7, 'field 1 from struct 1 in struct';
is $ss.a.second, 11, 'field 2 from struct 1 in struct';

is_approx $ss.b.first, 3.7e0, 'field 1 from struct 2 in struct';
is_approx $ss.b.second, 0.1e0, 'field 2 from struct 2 in struct';

my PointerStruct $x = ReturnAPointerStruct();
is $x.p.deref, 19, 'CPointer object in struct';

my StringStruct $strstr = ReturnAStringStruct();
is $strstr.first, 'OMG!', 'first string in struct';
is $strstr.second, 'Strings!', 'second string in struct';

TakeAStruct($obj);

my StructStruct $ss2 .= new();
$ss2.init;

TakeAStructStruct($ss2);

my StringStruct $strstr2 .= new();
$strstr2.init;
#$strstr2.first := "Lorem";
#$strstr2.second := "ipsum";
TakeAStringStruct($strstr2);

# vim:ft=perl6
Something went wrong with that request. Please try again.