Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

CUnion bug #5113

Open
p6rt opened this issue Feb 4, 2016 · 3 comments
Open

CUnion bug #5113

p6rt opened this issue Feb 4, 2016 · 3 comments

Comments

@p6rt
Copy link

p6rt commented Feb 4, 2016

Migrated from rt.perl.org#127460 (status was 'open')

Searchable as RT127460$

@p6rt
Copy link
Author

p6rt commented Feb 4, 2016

From @drforr

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--

@p6rt
Copy link
Author

p6rt commented Oct 6, 2016

From @niner

This is probably fixed by MoarVM/MoarVM@d912378

Can you please re-test with current rakudo?

@p6rt
Copy link
Author

p6rt commented Oct 6, 2016

The RT System itself - Status changed from 'new' to 'open'

@p6rt p6rt added the NativeCall label Jan 5, 2020
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

1 participant