[perl #127460] NativeCall CUnion bug

[via RT]

# New Ticket Created by   
# Please include the string:  [perl #127460]
# in the subject line of all future correspondence about this issue. 
# <URL: https://rt.perl.org/Ticket/Display.html?id=127460 >


Setting an int32 member of a CUnion (nested in a CStruct) to 0 from C 
causes the NativeCall layer to return a type object to the user.

This is a bit bizarre, but the files are below. I'm nesting a CUnion 
within a CStruct in order to match the layout of the C struct.

-- bug.pm6 --
use NativeCall;

constant ZERO = 0;
constant TYPE_BOOL = 2;

class Inline::Scheme::Guile::AltType is repr('CUnion') {
         has int32 $.int_content; # When this is populated with 0, 
NativeCall returns the I::S::G::AltType type rather than an instance of 
the object.
         has Str   $.string_content;
}

class Inline::Scheme::Guile::ConsCell is repr('CStruct') {
         has int32 $.type;
         HAS Inline::Scheme::Guile::AltType $.content; # The nested 
CUnion is here.
}

class Inline::Scheme::Guile {
         sub native(Sub $sub) {
                 my Str $path = %?RESOURCES<libraries/guile-helper>.Str;
                 die "unable to find libguile-helper library"
                         unless $path;
                 trait_mod:<is>($sub, :native($path));
         }

         sub run( Str $expression,
                  &marshal_guile 
(Pointer[Inline::Scheme::Guile::ConsCell]) )
                    { ... }
                 native(&run);

         method run( Str $expression ) {
                 my @stuff;
                 my $ref = sub ( Pointer[Inline::Scheme::Guile::ConsCell] 
$cell )                        {
                         CATCH {
                                 warn "Don't die in callback, warn 
instead.\n";
                                 warn $_;
                         }
                         my $type = $cell.deref.type;
                         given $type {
                                 when TYPE_BOOL {
                                         my $content = 
$cell.deref.content; # Content comes back as the AltType type object 
rather than an instance.
                                         if $content.int_content == 1 {
                                                 @stuff.push( True );
                                         }
                                         else {
                                                 @stuff.push( False );
                                         }
                                 }
                         }
                 }
                 run( $expression, $ref );
                 return @stuff;
         }
}
--cut here--

-- bug.c --
#include <libguile.h>
#include <stdio.h>

typedef enum {
         VOID = -1,
         ZERO = 0,
         TYPE_BOOL = 2,
}
cons_cell_type;

typedef struct {
         cons_cell_type type;
         union {
                 long  int_content; // This is the problem.
                 char* string_content;
         };
}
cons_cell;

static void _walk_scm( SCM scm, cons_cell* result ) {
         int num_values = scm_c_nvalues( scm );

         // '#f' is not null, bool, false and only 1 value.
         //
         if (    num_values == 1 &&
                 //scm_is_null( scm ) &&
                 scm_is_bool( scm ) &&
                 scm_is_false( scm ) ) {
                 result[0].type = TYPE_BOOL;
//              result[0].int_content = -1; // Assigning -1 to 
int_content returns an instance
                 result[0].int_content = 0; // Assigning 0 to int_content 
returns the type object.
                 result[1].type = ZERO;
                 return;
         }

         // '#t' is not null, bool, not false, true and only 1 value.
         //
         if (    num_values == 1 &&
                 //scm_is_null( scm ) &&
                 scm_is_bool( scm ) &&
                 !scm_is_false( scm ) &&
                 scm_is_true( scm ) ) {
                 result[0].type = TYPE_BOOL;
                 result[0].int_content = 1;
                 result[1].type = ZERO;
                 return;
         }
}

void* _run( void* expression ) {
         SCM str = scm_from_latin1_string( (char*) expression );
         SCM scm = scm_eval_string( str );

         // Sigh, special-case void lists.
         if ( scm_c_nvalues( scm ) == 0 ) {
                 cons_cell* result = malloc( sizeof( cons_cell ) * 2 );
                 result[0].type = VOID;
                 result[1].type = ZERO;
                 return result;
         }

         cons_cell* result = malloc( sizeof( cons_cell ) * 2 );

         _walk_scm( scm, result );

         return result;
}

void run( const char* expression, void (*unmarshal(void*)) ) {
         cons_cell* cells = scm_with_guile( _run, (void*)expression );
         cons_cell* head = cells;

         while( head->type != ZERO ) {
                 unmarshal(head++);
         }

         free(cells);
}
--cut here--



-- t/00-core.t --
#!/usr/bin/env perl6

use v6;
use Test;

use NativeCall;

plan 3;

use Inline::Scheme::Guile;

my $g = Inline::Scheme::Guile.new;

is-deeply [ $g.run( q{#f} ) ],   [ False ], q{value (#f)}; # This should 
segfault when 0 is used as False rather than -1.
is-deeply [ $g.run( q{#t} ) ],   [ True  ], q{value (#t)}; # This should 
work regardless.
--cut here--