view release on metacpan or  search on metacpan

lib/B/Assembler.pm  view on Meta::CPAN

#

sub B::Asmdata::PUT_U8 {
  error "Missing argument to PUT_U8" if @_ < 1;
  my $arg = shift;
  my $c   = uncstring($arg);
  if ( defined($c) ) {
    if ( length($c) != 1 ) {
      error "argument for U8 is too long: $c";
      $c = substr( $c, 0, 1 );
    }
  }
  else {
    $arg = limcheck( $arg, 0, 0xff, 'U8' );
    $c = chr($arg);
  }
  return $c;
}

sub B::Asmdata::PUT_U16 {
  error "Missing argument to PUT_U16" if @_ < 1;
  my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
  pack( "S", $arg );
}

sub B::Asmdata::PUT_U32 {
  error "Missing argument to PUT_U32" if @_ < 1;
  my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
  pack( "L", $arg );
}

sub B::Asmdata::PUT_I32 {
  error "Missing argument to PUT_I32" if @_ < 1;
  my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
  pack( "l", $arg );
}

sub B::Asmdata::PUT_NV {
  error "Missing argument to PUT_NV" if @_ < 1;
  sprintf( "%s\0", $_[0] );
}    # "%lf" looses precision and pack('d',...)
     # may not even be portable between compilers

sub B::Asmdata::PUT_objindex {    # could allow names here
  error "Missing argument to PUT_objindex" if @_ < 1;
  my $maxidx = $_[1] || 0xffffffff;
  my $what = $_[2] || 'ix';
  my $arg = limcheck( $_[0], 0, $maxidx, $what );
  pack( "L", $arg );
}
sub B::Asmdata::PUT_svindex { B::Asmdata::PUT_objindex( @_, $maxsvix, 'svix' ) }
sub B::Asmdata::PUT_opindex { B::Asmdata::PUT_objindex( @_, $maxopix, 'opix' ) }
sub B::Asmdata::PUT_pvindex { B::Asmdata::PUT_objindex( @_, $maxsvix, 'pvix' ) }
sub B::Asmdata::PUT_hekindex { B::Asmdata::PUT_objindex( @_ ) }

sub B::Asmdata::PUT_strconst {
  error "Missing argument to PUT_strconst" if @_ < 1;
  my $arg = shift;
  my $str = uncstring($arg);
  if ( !defined($str) ) {
    my @callstack = caller(3);
    error "bad string constant: '$arg', called from ".$callstack[3]
      ." line:".$callstack[2] unless $callstack[3] eq 'B::PADNAME::ix'; # empty newpadnx
    $str = '';
  }
  if ( $str =~ s/\0//g ) {
    error "string constant argument contains NUL: $arg";
    $str = '';
  }
  return $str . "\0";
}

# expects the string argument already on the "stack" (with depth 1, one sv)
sub B::Asmdata::PUT_pvcontents {
  my $arg = shift;
  error "extraneous argument to pvcontents: $arg" if defined $arg;
  return "";
}

sub B::Asmdata::PUT_PV {
  error "Missing argument to PUT_PV" if @_ < 1;
  my $arg = shift;
  my $str = uncstring($arg);
  if ( !defined($str) ) {
    error "bad string argument: $arg";
    $str = '';
  }
  return pack( "L", length($str) ) . $str;
}

sub B::Asmdata::PUT_comment_t {
  my $arg = shift;
  $arg = uncstring($arg);
  error "bad string argument: $arg" unless defined($arg);
  if ( $arg =~ s/\n//g ) {
    error "comment argument contains linefeed: $arg";
  }
  return $arg . "\n";
}
sub B::Asmdata::PUT_double {
  error "Missing argument to PUT_double" if @_ < 1;
  sprintf( "%s\0", $_[0] )
}    # see PUT_NV above

sub B::Asmdata::PUT_none {
  my $arg = shift;
  error "extraneous argument: $arg" if defined $arg;
  return "";
}

sub B::Asmdata::PUT_op_tr_array {
  error "Missing argument to PUT_tr_array" if @_ < 1;
  my @ary = split /\s*,\s*/, shift;
  return pack "S*", @ary;
}

sub B::Asmdata::PUT_IV64 {
  error "Missing argument to PUT_IV64" if @_ < 1;
  return pack "Q", shift;
}