Implement NativeCall wide string support

lib/NativeCall.pm6

@@ -23,11 +23,17 @@ my constant ulonglong     is export(:types, :DEFAULT) = NativeCall::Types::ulong
 my constant bool          is export(:types, :DEFAULT) = NativeCall::Types::bool;
 my constant size_t        is export(:types, :DEFAULT) = NativeCall::Types::size_t;
 my constant ssize_t       is export(:types, :DEFAULT) = NativeCall::Types::ssize_t;
+my constant wchar_t       is export(:types, :DEFAULT) = NativeCall::Types::wchar_t;
+my constant wint_t        is export(:types, :DEFAULT) = NativeCall::Types::wint_t;
+my constant char16_t      is export(:types, :DEFAULT) = NativeCall::Types::char16_t;
+my constant char32_t      is export(:types, :DEFAULT) = NativeCall::Types::char32_t;
 my constant void          is export(:types, :DEFAULT) = NativeCall::Types::void;
 my constant CArray        is export(:types, :DEFAULT) = NativeCall::Types::CArray;
 my constant Pointer       is export(:types, :DEFAULT) = NativeCall::Types::Pointer;
 my constant OpaquePointer is export(:types, :DEFAULT) = NativeCall::Types::Pointer;
-
+my constant WideStr       is export(:types, :DEFAULT) = NativeCall::Types::WideStr;
+my constant U16Str        is export(:types, :DEFAULT) = NativeCall::Types::U16Str;
+my constant U32Str        is export(:types, :DEFAULT) = NativeCall::Types::U32Str;
 
 # Role for carrying extra calling convention information.
 my role NativeCallingConvention[$name] {
@@ -43,7 +49,6 @@ my role NativeCallMangled[$name] {
     method native_call_mangled() { $name }
 }
 
-
 # Throwaway type just to get us some way to get at the NativeCall
 # representation.
 my class native_callsite is repr('NativeCall') { }
@@ -57,7 +62,13 @@ sub string_encoding_to_nci_type(\encoding) {
         ?? "asciistr"
         !! nqp::iseq_s($enc,"utf16")
           ?? "utf16str"
-          !! die "Unknown string encoding for native call: $enc"
+          !! nqp::iseq_s($enc, 'wide')
+            ?? "widestr"
+            !! nqp::iseq_s($enc, 'u16')
+              ?? "u16str"
+              !! nqp::iseq_s($enc, 'u32')
+                ?? "u32str"
+                !! die "Unknown string encoding for native call: $enc"
 }
 
 # Builds a hash of type information for the specified parameter.
@@ -150,6 +161,10 @@ my constant $type_map = nqp::hash(
   "num64",      "double",
   "size_t",     nqp::atpos_s($signed_ints_by_size,nativesizeof(size_t)),
   "ssize_t",    nqp::atpos_s($signed_ints_by_size,nativesizeof(ssize_t)),
+  "wchar_t",    "wchar_t",
+  "wint_t",     "wint_t",
+  "char16_t",   "char16_t",
+  "char32_t",   "char32_t",
   "uint",       "ulong",
   "uint16",     "ushort",
   "uint32",     "uint",
@@ -623,23 +638,81 @@ multi trait_mod:<is>(Routine $r, :$nativeconv!) is export(:DEFAULT, :traits) {
 multi trait_mod:<is>(Parameter $p, :$encoded!) is export(:DEFAULT, :traits) {
     $p does NativeCallEncoded[$encoded];
 }
-multi trait_mod:<is>(Routine $p, :$encoded!) is export(:DEFAULT, :traits) {
-    $p does NativeCallEncoded[$encoded];
+multi trait_mod:<is>(Routine $r, :$encoded!) is export(:DEFAULT, :traits) {
+    $r does NativeCallEncoded[$encoded];
+}
+multi trait_mod:<is>(Parameter $p, :$wide!) is export(:DEFAULT, :traits) {
+    $p does NativeCallEncoded['wide'];
+}
+multi trait_mod:<is>(Routine $r, :$wide!) is export(:DEFAULT, :traits) {
+    $r does NativeCallEncoded['wide'];
+}
+multi trait_mod:<is>(Parameter $p, :$u16!) is export(:DEFAULT, :traits) {
+    $p does NativeCallEncoded['u16'];
+}
+multi trait_mod:<is>(Routine $r, :$u16!) is export(:DEFAULT, :traits) {
+    $r does NativeCallEncoded['u16'];
+}
+multi trait_mod:<is>(Parameter $p, :$u32!) is export(:DEFAULT, :traits) {
+    $p does NativeCallEncoded['u32'];
+}
+multi trait_mod:<is>(Routine $r, :$u32!) is export(:DEFAULT, :traits) {
+    $r does NativeCallEncoded['u32'];
 }
 
 multi trait_mod:<is>(Routine $p, :$mangled!) is export(:DEFAULT, :traits) {
     $p does NativeCallMangled[$mangled === True ?? 'C++' !! $mangled];
 }
 
-role ExplicitlyManagedString {
-    has $.cstr is rw;
+class NativeStr is export(:DEFAULT, :types) { }
+class NativeCStr is NativeStr is repr('CStr') {
+    # Once encodings are supported properly with the CStr REPR, set the
+    # encoding on the class' metamodel while parameterizing.
+    method ^parameterize(Mu:U \C, Str $encoding) {
+        C
+    }
 }
+# These don't support encodings because wide strings, u16strings, and
+# u32strings already have their own encoding and can use no other.
+class NativeWideStr is NativeStr is wide is repr('CStr') { }
+class NativeU16Str  is NativeStr is u16  is repr('CStr') { }
+class NativeU32Str  is NativeStr is u32  is repr('CStr') { }
+
+role ExplicitlyManagedString[Str $encoding, Mu:U $native-type] {
+    has NativeStr $.native-string is rw;
+    method encoding(--> Str)     { $encoding    }
+    method native-type(--> Mu:U) { $native-type }
+}
+
+multi explicitly-manage(Str $str, :$encoding = 'utf8', :$type = 'c' --> NativeStr) is export(:DEFAULT, :utils) {
+    my Mu:U $class;
+    my Mu:U $native-type;
+    given $type {
+        when 'c'    {
+            $class       := NativeCStr[$encoding];
+            # XXX: this can be uint8 on certain platforms but we have no way to
+            # tell! There needs to be a native char type.
+            $native-type := int8;
+        }
+        when 'wide' {
+            $class       := NativeWideStr;
+            $native-type := wchar_t;
+        }
+        when 'u16'  {
+            $class       := NativeU16Str;
+            $native-type := char16_t;
+        }
+        when 'u32'  {
+            $class       := NativeU32Str;
+            $native-type := char32_t;
+        }
+        default     {
+            die "Unsupported explicitly managed string type: $type";
+        }
+    }
 
-multi explicitly-manage(Str $x, :$encoding = 'utf8') is export(:DEFAULT,
-:utils) {
-    $x does ExplicitlyManagedString;
-    my $class = class CStr is repr('CStr') { method encoding() { $encoding; } };
-    $x.cstr = nqp::box_s(nqp::unbox_s($x), nqp::decont($class));
+    $str does ExplicitlyManagedString[$encoding, $native-type];
+    $str.native-string = nqp::box_s(nqp::unbox_s(nqp::decont($str)), $class);
 }
 
 role CPPConst {
@@ -707,8 +780,8 @@ sub check_routine_sanity(Routine $r) is export(:TEST) {
       return True if nqp::existskey($repr_map,T.REPR) && T.REPR ne 'CArray' | 'CPointer';
       return True if T.^name eq 'Str' | 'str' | 'Bool';
       return False if T.REPR eq 'P6opaque';
-      return False if T.HOW.^can("nativesize") && !nqp::defined(T.^nativesize); #to disting int and int32 for example
-      return validnctype(T.of) if T.REPR eq 'CArray' | 'CPointer' and T.^can('of');
+      return False if T.HOW.^can('ctype') && T.^ctype eq ''; # to disting int and int32 for example
+      return validnctype(T.of) if T.REPR eq 'CArray' | 'CPointer' && T.^can('of');
       return True;
     }
     my $sig = $r.signature;

lib/NativeCall/Types.pm6

@@ -6,16 +6,26 @@ sub nativecast($target-type, $source) {
         nqp::decont(map_return_type($target-type)), nqp::decont($source));
 }
 
-our native long     is Int is ctype("long")     is repr("P6int") { };
-our native longlong is Int is ctype("longlong") is repr("P6int") { };
+our native long      is Int is ctype("long")     is repr("P6int") { };
+our native longlong  is Int is ctype("longlong") is repr("P6int") { };
 our native ulong     is Int is ctype("long")     is unsigned is repr("P6int") { };
 our native ulonglong is Int is ctype("longlong") is unsigned is repr("P6int") { };
 our native size_t    is Int is ctype("size_t")   is unsigned is repr("P6int") { };
-our native ssize_t   is Int is ctype("size_t")               is repr("P6int") { };
-our native bool      is Int is ctype("bool")                 is repr("P6int") { };
-our class void                                  is repr('Uninstantiable') { };
+our native ssize_t   is Int is ctype("size_t")   is repr("P6int") { };
+our native bool      is Int is ctype("bool")     is repr("P6int") { };
+our native wchar_t   is Int is ctype("wchar_t")  is unsigned(nqp::iswcharunsigned()) is repr("P6int") { };
+our native wint_t    is Int is ctype("wint_t")   is unsigned(nqp::iswintunsigned())  is repr("P6int") { };
+our native char16_t  is Int is ctype("char16_t") is unsigned is repr("P6int") { };
+our native char32_t  is Int is ctype("char32_t") is unsigned is repr("P6int") { };
+
+our class WideStr is Str is wide is repr('P6str') { };
+our class U16Str  is Str is u16  is repr('P6str') { };
+our class U32Str  is Str is u32  is repr('P6str') { };
+
+our class void is repr('Uninstantiable') { };
+
 # Expose a Pointer class for working with raw pointers.
-our class Pointer                               is repr('CPointer') {
+our class Pointer                                is repr('CPointer') {
     method of() { void }
 
     multi method new() {

src/Perl6/Metamodel/BOOTSTRAP.nqp

@@ -19,12 +19,14 @@ use QRegex;
 my class BOOTSTRAPATTR {
     has $!name;
     has $!type;
+    has $!char_type;
     has $!box_target;
     has $!package;
     has $!inlined;
     has $!dimensions;
     method name() { $!name }
     method type() { $!type }
+    method char_type() { $!char_type }
     method box_target() { $!box_target }
     method package() { $!package }
     method inlined() { $!inlined }
@@ -1413,6 +1415,7 @@ BEGIN {
     Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!required>, :type(Mu), :package(Attribute)));
     Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!has_accessor>, :type(int), :package(Attribute)));
     Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!type>, :type(Mu), :package(Attribute)));
+    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!char_type>, :type(int), :package(Attribute)));
     Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!container_descriptor>, :type(Mu), :package(Attribute)));
     Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!auto_viv_container>, :type(Mu), :package(Attribute)));
     Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!build_closure>, :type(Mu), :package(Attribute)));
@@ -1427,11 +1430,12 @@ BEGIN {
 
     # Need new and accessor methods for Attribute in here for now.
     Attribute.HOW.add_method(Attribute, 'new',
-        nqp::getstaticcode(sub ($self, :$name!, :$type!, :$package!, :$inlined = 0, :$has_accessor,
+        nqp::getstaticcode(sub ($self, :$name!, :$type!, :$char_type = nqp::const::P6STR_C_TYPE_CHAR, :$package!, :$inlined = 0, :$has_accessor,
                 :$positional_delegate = 0, :$associative_delegate = 0, *%other) {
             my $attr := nqp::create($self);
             nqp::bindattr_s($attr, Attribute, '$!name', $name);
             nqp::bindattr($attr, Attribute, '$!type', nqp::decont($type));
+            nqp::bindattr_i($attr, Attribute, '$!char_type', $char_type);
             nqp::bindattr_i($attr, Attribute, '$!has_accessor', $has_accessor);
             nqp::bindattr($attr, Attribute, '$!package', $package);
             nqp::bindattr_i($attr, Attribute, '$!inlined', $inlined);
@@ -1473,6 +1477,16 @@ BEGIN {
             nqp::getattr(nqp::decont($self),
                 Attribute, '$!type');
         }));
+    Attribute.HOW.add_method(Attribute, 'set_char_type', nqp::getstaticcode(sub ($self, $value) {
+            $*W.add_object_if_no_sc($value);
+            nqp::bindattr_i(nqp::decont($self),
+                Attribute, '$!char_type', $value);
+            nqp::hllboolfor(1, "perl6")
+        }));
+    Attribute.HOW.add_method(Attribute, 'char_type', nqp::getstaticcode(sub ($self) {
+            nqp::getattr_i(nqp::decont($self),
+                Attribute, '$!char_type');
+        }));
     Attribute.HOW.add_method(Attribute, 'container_descriptor', nqp::getstaticcode(sub ($self) {
             nqp::getattr(nqp::decont($self),
                 Attribute, '$!container_descriptor');

src/Perl6/Metamodel/CharType.nqp

@@ -0,0 +1,20 @@
+# Handles type declarations that really map down to string types of some kind,
+# containing information about the native type used to represent characters, so
+# they should be composed as a stringy representation.
+role Perl6::Metamodel::CharType {
+    has int $!char_type;
+    has int $!has_char_type;
+
+    method has_char_type($obj) {
+        $!has_char_type ?? 1 !! 0
+    }
+
+    method char_type($obj) {
+        $!char_type
+    }
+
+    method set_char_type($obj, $type) {
+        $!char_type     := $type;
+        $!has_char_type := 1;
+    }
+}

src/Perl6/Metamodel/ClassHOW.nqp

@@ -17,6 +17,7 @@ class Perl6::Metamodel::ClassHOW
     does Perl6::Metamodel::Trusting
     does Perl6::Metamodel::BUILDPLAN
     does Perl6::Metamodel::Mixins
+    does Perl6::Metamodel::CharType
     does Perl6::Metamodel::ArrayType
     does Perl6::Metamodel::BoolificationProtocol
     does Perl6::Metamodel::REPRComposeProtocol

src/Perl6/Metamodel/ConcreteRoleHOW.nqp

@@ -7,6 +7,7 @@ class Perl6::Metamodel::ConcreteRoleHOW
     does Perl6::Metamodel::AttributeContainer
     does Perl6::Metamodel::RoleContainer
     does Perl6::Metamodel::MultipleInheritance
+    does Perl6::Metamodel::CharType
     does Perl6::Metamodel::ArrayType
     does Perl6::Metamodel::Concretization
 {