File Coverage

blib/lib/PDL/Types.pm

Criterion	Covered	Total	%
statement	52	72	72.2
branch	16	32	50.0
condition	3	6	50.0
subroutine	25	32	78.1
pod	5	9	55.5
total	101	151	66.8

package PDL::Types;
use strict;
use warnings;
require Exporter;
use Carp;
use Config;

our @ISA    = qw( Exporter );

my @TYPE_CHECK = qw/
  realctype ppforcetype usenan real unsigned integer identifier ctype
/;
my @TYPE_VERBATIM = (@TYPE_CHECK, qw(
  ioname convertfunc defbval shortctype ppsym numval sym floatsuffix
));
my @TYPE_MODIFIED = qw(realversion complexversion isnan isfinite);

sub packtypeof_PDL_Indx {
  return 'q*' if $Config{ptrsize} == 8;
  return 'l*' if $Config{ptrsize} == 4;
  die "PDL::Types: packtype for ptrsize==$Config{ptrsize} not handled\n";
}

# Data types *must* be listed in order of complexity!!
# this is critical for type conversions!!!
#
my @HASHES = (
  {
    identifier => 'SB',
    onecharident => 'A',   # only needed if different from identifier
    ctype => 'PDL_SByte',# to be defined in pdl.h
    realctype => 'signed char', # CORE21 change to int8_t
    ppforcetype => 'sbyte', # for some types different from ctype
    usenan => 0,           # do we need NaN handling for this type?
    packtype => 'c*',      # the perl pack type
    defbval => 'SCHAR_MIN',
    real=>1,
    integer=>1,
    unsigned=>0,
  },
  {
    identifier => 'B',
    ctype => 'PDL_Byte',# to be defined in pdl.h
    realctype => 'unsigned char',
    ppforcetype => 'byte', # for some types different from ctype
    usenan => 0,           # do we need NaN handling for this type?
    packtype => 'C*',      # the perl pack type
    defbval => 'UCHAR_MAX',
    real=>1,
    integer=>1,
    unsigned=>1,
  },
  {
    identifier => 'S',
    ctype => 'PDL_Short',
    realctype => 'short',
    ppforcetype => 'short',
    usenan => 0,
    packtype => 's*',
    defbval => 'SHRT_MIN',
    real=>1,
    integer=>1,
    unsigned=>0,
  },
  {
    identifier => 'US',
    onecharident => 'U',   # only needed if different from identifier
    ctype => 'PDL_Ushort',
    realctype => 'unsigned short',
    ppforcetype => 'ushort',
    usenan => 0,
    packtype => 'S*',
    defbval => 'USHRT_MAX',
    real=>1,
    integer=>1,
    unsigned=>1,
  },
  {
    identifier => 'L',
    ctype => 'PDL_Long',
    realctype => 'int32_t',
    ppforcetype => 'int',
    usenan => 0,
    packtype => 'l*',
    defbval => 'INT32_MIN',
    real=>1,
    integer=>1,
    unsigned=>0,
  },
  {
    identifier => 'UL',
    onecharident => 'K',   # only needed if different from identifier
    ctype => 'PDL_ULong',
    realctype => 'uint32_t',
    ppforcetype => 'uint',
    usenan => 0,
    packtype => 'L*',
    defbval => 'UINT32_MAX',
    real=>1,
    integer=>1,
    unsigned=>1,
  },
  {
    identifier => 'IND',
    onecharident => 'N',   # only needed if different from identifier
    ctype => 'PDL_Indx',
    realctype => 'ptrdiff_t',
    ppforcetype => 'indx',
    usenan => 0,
    packtype => &packtypeof_PDL_Indx,
    defbval => 'PTRDIFF_MIN',
    real=>1,
    integer=>1,
    unsigned=>0,
  },
# note that the I/O routines have *not* been updated to be aware of
# such a type yet
  { # this one before LL so last integer is signed, to avoid default-type (last in list) changing to unsigned
    identifier => 'ULL',
    onecharident => 'P',   # only needed if different from identifier
    ctype => 'PDL_ULongLong',
    realctype => 'uint64_t',
    ppforcetype => 'ulonglong',
    usenan => 0,
    packtype => 'Q*',
    defbval => 'UINT64_MAX',
    real=>1,
    integer=>1,
    unsigned=>1,
  },
  {
    identifier => 'LL',
    onecharident => 'Q',   # only needed if different from identifier
    ctype => 'PDL_LongLong',
    realctype => 'int64_t',
    ppforcetype => 'longlong',
    usenan => 0,
    packtype => 'q*',
    defbval => 'INT64_MIN',
    real=>1,
    integer=>1,
    unsigned=>0,
  },
# IMPORTANT:
# PDL_F *must* be the first non-integer type in this list
# as there are many places in the code (.c/.xs/.pm/.pd)
# with tests like this:
#                        if (ndarraytype < PDL_F) { ... }
  {
    identifier => 'F',
    ctype => 'PDL_Float',
    realctype => 'float',
    ppforcetype => 'float',
    usenan => 1,
    packtype => 'f*',
    defbval => '-FLT_MAX',
    real=>1,
    complexversion=> 'G',
    integer=>0,
    unsigned=>0,
    isnan=>'isnan(%1$s)',
    isfinite=>'isfinite(%1$s)',
    floatsuffix=>'f',
  },
  {
    identifier => 'D',
    ctype => 'PDL_Double',
    realctype => 'double',
    ppforcetype => 'double',
    usenan => 1,
    packtype => 'd*',
    defbval => '-DBL_MAX',
    real=>1,
    complexversion=> 'C',
    integer=>0,
    unsigned=>0,
    isnan=>'isnan(%1$s)',
    isfinite=>'isfinite(%1$s)',
    floatsuffix=>'',
  },
  {
    identifier => 'LD',
    onecharident => 'E',   # only needed if different from identifier
    ctype => 'PDL_LDouble',
    realctype => 'long double',
    ppforcetype => 'ldouble',
    usenan => 1,
    packtype => 'D*',
    defbval => '-LDBL_MAX',
    real=>1,
    complexversion=> 'CLD',
    integer=>0,
    unsigned=>0,
    isnan=>'isnan(%1$s)',
    isfinite=>'isfinite(%1$s)',
    floatsuffix=>'l',
  },
# the complex types need to be in the same order as their real
# counterparts, because the "real" ppforcetype relies on a fixed interval
# between each real and complex version
# they also need to occur at the end of the types, as a < PDL_CF
# comparison is done at C level to see if a type is real, analogous to
# the < PDL_F above
  {
    identifier => 'CF',
    onecharident => 'G',   # only needed if different from identifier
    ctype => 'PDL_CFloat',
    realctype => 'complex float',
    ppforcetype => 'cfloat',
    usenan => 1,
    packtype => '(ff)*',
    defbval => '(-FLT_MAX - I*FLT_MAX)',
    real=>0,
    realversion=>'F',
    integer=>0,
    unsigned=>0,
    isnan=>'(isnan(crealf(%1$s)) || isnan(cimagf(%1$s)))',
    isfinite=>'(isfinite(crealf(%1$s)) && isfinite(cimagf(%1$s)))',
    floatsuffix=>'f',
  },
  {
    identifier => 'CD',
    onecharident => 'C',   # only needed if different from identifier
    ctype => 'PDL_CDouble',
    realctype => 'complex double',
    ppforcetype => 'cdouble',
    usenan => 1,
    packtype => '(dd)*',
    defbval => '(-DBL_MAX - I*DBL_MAX)',
    real=>0,
    realversion=>'D',
    integer=>0,
    unsigned=>0,
    isnan=>'(isnan(creal(%1$s)) || isnan(cimag(%1$s)))',
    isfinite=>'(isfinite(creal(%1$s)) && isfinite(cimag(%1$s)))',
    floatsuffix=>'',
  },
  {
    identifier => 'CLD',
    onecharident => 'H',   # only needed if different from identifier
    ctype => 'PDL_CLDouble',
    realctype => 'complex long double',
    ppforcetype => 'cldouble',
    usenan => 1,
    packtype => '(DD)*',
    defbval => '(-LDBL_MAX - I*LDBL_MAX)',
    real=>0,
    realversion=>'LD',
    integer=>0,
    unsigned=>0,
    isnan=>'(isnan(creall(%1$s)) || isnan(cimagl(%1$s)))',
    isfinite=>'(isfinite(creall(%1$s)) && isfinite(cimagl(%1$s)))',
    floatsuffix=>'l',
  },
);

my $i = 0;
my @check_keys = (@TYPE_CHECK, qw(
  identifier packtype defbval
));
for my $type (@HASHES) {
  die "type is not a HASH ref but ".ref($type) unless ref $type eq 'HASH';
  my @missing_keys = grep !exists $type->{$_}, @check_keys;
  die "type hash missing (@missing_keys)" if @missing_keys;
  $type->{shortctype} = $type->{ctype} =~ s/PDL_//r;
  $type->{ioname} = $type->{convertfunc} = lc $type->{shortctype};
  $type->{ppsym} = $type->{onecharident} || $type->{identifier};
  $type->{numval} = $i++;
  $type->{sym} = "PDL_$type->{identifier}";
  $type->{realversion} ||= $type->{ppsym};
  $type->{complexversion} ||= !$type->{real} ? $type->{ppsym} : 'G';
  $type->{floatsuffix} //= 'INVALID';

}

our @EXPORT = (qw(@pack %typehash), my @typevars = map "\$$_->{sym}", @HASHES);
our @EXPORT_OK = (@EXPORT,
  qw/types typesrtkeys mapfld typefld
    ppdefs ppdefs_complex ppdefs_all
  /
);
our %EXPORT_TAGS = (
	All=>\@EXPORT_OK,
);

eval "our ( @{[ join ',', @typevars ]} ) = (0..$#HASHES)";
die if $@;
# Corresponding pack types
our @pack= map $_->{packtype}, @HASHES;
our @names= map $_->{sym}, @HASHES;

our %typehash = map {
  my $type = $_;
  $type->{sym} => +{
    (map +($_ => $type->{$_}), @TYPE_VERBATIM, @TYPE_MODIFIED),
  };
} @HASHES;

# Cross-reference by common names
our %typenames;
for my $h (@HASHES) {
  my $n = $h->{numval};
  $typenames{$_} = $n for $n, @$h{qw(sym ioname ctype ppforcetype ppsym identifier)};
}

=head1 NAME

PDL::Types - define fundamental PDL Datatypes

=head1 SYNOPSIS

 use PDL::Types;

 $pdl = ushort( 2.0, 3.0 );
 print "The actual c type used to store ushort's is '" .
    $pdl->type->realctype() . "'\n";
 The actual c type used to store ushort's is 'unsigned short'

=head1 DESCRIPTION

Internal module - holds all the PDL Type info.  The type info can be
accessed easily using the C object returned by
the L method as shown in the synopsis.

Skip to the end of this document to find out how to change
the set of types supported by PDL.

=head1 FUNCTIONS

A number of functions are available for module writers
to get/process type information. These are used in various
places (e.g. C, C) to generate the
appropriate type loops, etc.

=head2 typesrtkeys

=for ref

Returns an array of keys of typehash sorted in order of type complexity

=for example

 pdl> @typelist = PDL::Types::typesrtkeys;
 pdl> print @typelist;
 PDL_SB PDL_B PDL_S PDL_US PDL_L PDL_UL PDL_IND PDL_ULL PDL_LL PDL_F PDL_D PDL_LD PDL_CF PDL_CD PDL_CLD
=cut

sub typesrtkeys { @names }

=head2 ppdefs

=for ref

Returns an array of pp symbols for all real types. This informs the
default C for C functions, making support for
complex types require an "opt-in".

=for example

 pdl> print PDL::Types::ppdefs
 A B S U L K N P Q F D E

=cut

my @PPDEFS = map $_->{ppsym}, grep $_->{real}, @HASHES;
sub ppdefs { @PPDEFS }

=head2 ppdefs_complex

=for ref

Returns an array of pp symbols for all complex types.

=for example

 pdl> print PDL::Types::ppdefs_complex
 G C H

=cut

my @PPDEFS_CPLX = map $_->{ppsym}, grep !$_->{real}, @HASHES;
sub ppdefs_complex { @PPDEFS_CPLX }

=head2 ppdefs_all

=for ref

Returns an array of pp symbols for all types including complex.

=for example

 pdl> print PDL::Types::ppdefs_all
 A B S U L K N P Q F D E G C H

=cut

my @PPDEFS_ALL = map $_->{ppsym}, @HASHES;
sub ppdefs_all { @PPDEFS_ALL }

sub typefld {
  my ($type,$fld) = @_;
  croak "unknown type $type" unless exists $typehash{$type};
  croak "unknown field $fld in type $type"
     unless exists $typehash{$type}->{$fld};
  return $typehash{$type}->{$fld};
}

sub mapfld {
	my ($type,$src,$trg) = @_;
	my @keys = grep {$typehash{$_}->{$src} eq $type} typesrtkeys;
	return @keys > 0 ? $typehash{$keys[0]}->{$trg} : undef;
}

=head2 typesynonyms

=for ref

return type related synonym definitions to be included in pdl.h .
This routine must be updated to include new types as required.
Mostly the automatic updating should take care of the vital
things.

=cut

sub typesynonyms {
  my $add = join "\n",
      map {"#define PDL_".typefld($_,'ppsym')." ".typefld($_,'sym')}
        grep {"PDL_".typefld($_,'ppsym') ne typefld($_,'sym')} typesrtkeys;
  return "$add\n";
}

=head1 PDL TYPES OVERVIEW

As of 2.065, PDL supports these types:

=over

=item SByte

Signed 8-bit value.

=item Byte

Unsigned 8-bit value.

=item Short

Signed 16-bit value.

=item UShort

Unsigned 16-bit value.

=item Long

Signed 32-bit value.

=item ULong

Unsigned 32-bit value.

=item Indx

Signed value, same size as a pointer on the system in use.

=item ULongLong

Unsigned 64-bit value.

=item LongLong

Signed 64-bit value.

=item Float

L single-precision real
floating-point value.

=item Double

IEEE 754 double-precision real value.

=item LDouble

A C99 "long double", defined as "at least as precise as a double",
but often more precise.

=item CFloat

A C99 complex single-precision floating-point value.

=item CDouble

A C99 complex double-precision floating-point value.

=item CLDouble

A C99 complex "long double" - see above for description.

=back

As of 2.099, documentation for L is separate. See there for more.

=cut

my @CACHED_TYPES = map bless([$_->{numval}, $_], 'PDL::Type'), @HASHES;
# return all known types as type objects
sub types { @CACHED_TYPES }

{
package PDL::Type;

use Carp;
sub new {
  my ($type,$val) = @_;
  return $val if "PDL::Type" eq ref $val;
  if (ref $val and UNIVERSAL::isa($val, 'PDL')) {
    PDL::Core::barf("Can't make a type out of non-scalar ndarray $val!")
      if $val->getndims != 0;
    $val = $val->at;
  }
  confess "Can't make a type out of non-scalar $val (".
    (ref $val).")!" if ref $val;
  confess "Unknown type string '$val' (should be one of ".
    join(",",map $PDL::Types::typehash{$_}{ioname}, @names).
    ")\n"
    if !defined $PDL::Types::typenames{$val};
  $CACHED_TYPES[$PDL::Types::typenames{$val}];
}

sub enum { $_[0][0] }
*symbol = \&sym;

sub realversion {
  $CACHED_TYPES[$PDL::Types::typenames{ $_[0][1]{realversion} }];
}
sub complexversion {
  $CACHED_TYPES[$PDL::Types::typenames{ $_[0][1]{complexversion} }];
}
sub isnan { sprintf $_[0][1]{isnan}, $_[1] }
sub isfinite { sprintf $_[0][1]{isfinite}, $_[1] }

my (%bswap_cache, %howbig_cache);
sub bswap {
  PDL::Core::barf('Usage: $type->bswap with no args') if @_ > 1;
  return $bswap_cache{$_[0][0]} if $bswap_cache{$_[0][0]};
  my $size = $_[0]->howbig;
  return $bswap_cache{$_[0][0]} = sub {} if $size < 2;
  require PDL::IO::Misc;
  my $swapper = PDL->can("bswap$size");
  PDL::Core::barf("Type::bswap couldn't find swap function for $_[0][1]{shortctype}, size was '$size'") if !defined $swapper;
  $bswap_cache{$_[0][0]} = $swapper;
}

sub howbig {
  $howbig_cache{$_[0][0]} ||= PDL::Core::howbig($_[0][0]);
}

foreach my $name (@TYPE_VERBATIM) {
  no strict 'refs';
  *$name = sub { $_[0][1]{$name}; };
}

sub badvalue {
  PDL::Bad::_badvalue_int( $_[1], $_[0][0] );
}
sub orig_badvalue {
  PDL::Bad::_default_badvalue_int($_[0][0]);
}

# make life a bit easier
use overload (
  '""'  => sub { lc $_[0]->shortctype },
  "eq"  => sub { my ($self, $other, $swap) = @_; ("$self" eq $other); },
  "cmp" => sub { my ($self, $other, $swap) = @_;
    $swap ? $other cmp "$self" : "$self" cmp $other;
  },
  "<=>" => sub { $_[2] ? $_[1][0] <=> $_[0][0] : $_[0][0] <=> $_[1][0] },
);
} # package: PDL::Type
# Return
1;

__END__