(Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).
| PP.pm (PDL-2.081) | : | PP.pm (PDL-2.082) |
|---|
| | |
| skipping to change at line 517 | | skipping to change at line 517 |
|---|
| | |
| #define PDL_XS_RETURN(clause1) \ | | #define PDL_XS_RETURN(clause1) \ |
| if (nreturn) { \ | | if (nreturn) { \ |
| if (nreturn > 0) EXTEND (SP, nreturn); \ | | if (nreturn > 0) EXTEND (SP, nreturn); \ |
| clause1; \ | | clause1; \ |
| XSRETURN(nreturn); \ | | XSRETURN(nreturn); \ |
| } else { \ | | } else { \ |
| XSRETURN(0); \ | | XSRETURN(0); \ |
| } | | } |
| | |
|
| #define PDL_XS_INPLACE(in, out) \ | | #define PDL_XS_INPLACE(in, out, noutca) \ |
| if (in->state & PDL_INPLACE && (out != in)) { \ | | if (in->state & PDL_INPLACE) { \ |
| in->state &= ~PDL_INPLACE; PDL_COMMENT("unset") \ | | if (nreturn == noutca && out != in) { \ |
| out = in; \ | | barf("inplace input but different output given"); \ |
| PDL->SetSV_PDL(out ## _SV,out); \ | | } else { \ |
| | in->state &= ~PDL_INPLACE; PDL_COMMENT("unset") \ |
| | out = in; \ |
| | PDL->SetSV_PDL(out ## _SV,out); \ |
| | } \ |
| } | | } |
|
| | | |
| #define PDL_XS_INPLACE_CHECK(in) \ | | |
| if (in->state & PDL_INPLACE) barf("inplace input but output given"); | | |
| EOF | | EOF |
| | |
| our $header_c = pp_line_numbers(__LINE__, <<'EOF'); | | our $header_c = pp_line_numbers(__LINE__, <<'EOF'); |
| /* | | /* |
| * THIS FILE WAS GENERATED BY PDL::PP! Do not modify! | | * THIS FILE WAS GENERATED BY PDL::PP! Do not modify! |
| */ | | */ |
| | |
| #define PDL_COMMENT(comment) | | #define PDL_COMMENT(comment) |
| PDL_COMMENT("This preprocessor symbol is used to add commentary in the PDL ") | | PDL_COMMENT("This preprocessor symbol is used to add commentary in the PDL ") |
| PDL_COMMENT("autogenerated code. Normally, one would use typical C-style ") | | PDL_COMMENT("autogenerated code. Normally, one would use typical C-style ") |
| | |
| skipping to change at line 610 | | skipping to change at line 611 |
|---|
| EOF | | EOF |
| | |
| use Config; | | use Config; |
| use Exporter; | | use Exporter; |
| use Data::Dumper; | | use Data::Dumper; |
| | |
| our @ISA = qw(Exporter); | | our @ISA = qw(Exporter); |
| | |
| our @EXPORT = qw/pp_addhdr pp_addpm pp_bless pp_def pp_done pp_add_boot | | our @EXPORT = qw/pp_addhdr pp_addpm pp_bless pp_def pp_done pp_add_boot |
| pp_add_exported pp_addxs pp_add_isa pp_export_nothing | | pp_add_exported pp_addxs pp_add_isa pp_export_nothing |
|
| pp_core_importList pp_beginwrap pp_setversion | | pp_add_typemaps |
| | pp_core_importList pp_beginwrap pp_setversion |
| pp_addbegin pp_boundscheck pp_line_numbers | | pp_addbegin pp_boundscheck pp_line_numbers |
| pp_deprecate_module pp_add_macros/; | | pp_deprecate_module pp_add_macros/; |
| | |
| $PP::boundscheck = 1; | | $PP::boundscheck = 1; |
| $::PP_VERBOSE = 0; | | $::PP_VERBOSE = 0; |
| | |
| our $done = 0; # pp_done has not been called yet | | our $done = 0; # pp_done has not been called yet |
| | |
| use Carp; | | use Carp; |
| | |
| | |
| skipping to change at line 796 | | skipping to change at line 798 |
|---|
| # If we need to add a # line directive, do so after incrementing | | # If we need to add a # line directive, do so after incrementing |
| $line++; | | $line++; |
| if (/%\{/ or /%}/) { | | if (/%\{/ or /%}/) { |
| push @to_return, "PDL_LINENO_END\n"; | | push @to_return, "PDL_LINENO_END\n"; |
| push @to_return, "PDL_LINENO_START $line \"$filename\"\n"
; | | push @to_return, "PDL_LINENO_START $line \"$filename\"\n"
; |
| } | | } |
| } | | } |
| push @to_return, "PDL_LINENO_END\n"; | | push @to_return, "PDL_LINENO_END\n"; |
| return join('', @to_return); | | return join('', @to_return); |
| } | | } |
|
| | my $LINE_RE = qr/^(\s*)PDL_LINENO_(?:START (\S+) "(.*)"|(END))$/; |
| sub _pp_linenumber_fill { | | sub _pp_linenumber_fill { |
|
| | local $_; # else get "Modification of a read-only value attempted" |
| my ($file, $text) = @_; | | my ($file, $text) = @_; |
| my (@stack, @to_return) = [$file, 1]; | | my (@stack, @to_return) = [$file, 1]; |
|
| foreach (split (/\n/, $text)) { | | my @lines = split /\n/, $text; |
| | while (defined($_ = shift @lines)) { |
| $_->[1]++ for @stack; | | $_->[1]++ for @stack; |
|
| push(@to_return, $_), next if !/^(\s*)PDL_LINENO_(?:START (\S+) "(.*)"|(END)
)$/; | | push(@to_return, $_), next if !/$LINE_RE/; |
| my ($ci, $new_line, $new_file, $is_end) = ($1, $2, $3, $4); | | my ($ci, $new_line, $new_file, $is_end) = ($1, $2, $3, $4); |
| if ($is_end) { | | if ($is_end) { |
|
| pop @stack; | | @stack = [$file, $stack[0][1]]; # as soon as another block is entered, lin |
| push @to_return, qq{$ci#line $stack[-1][1] "$stack[-1][0]"}; | | e numbers for outer blocks become meaningless |
| | if (@lines > 1 and !length($lines[0]) and $lines[1] =~ /$LINE_RE/) { |
| | $stack[-1][1]--; |
| | } else { |
| | push @to_return, qq{$ci#line $stack[-1][1] "$stack[-1][0]"} if @lines; |
| | } |
| } else { | | } else { |
| push @stack, [$new_file, $new_line-1]; | | push @stack, [$new_file, $new_line-1]; |
|
| push @to_return, qq{$ci#line @{[$stack[-1][1]+1]} "$stack[-1][0]"}; | | push @to_return, qq{$ci#line @{[$stack[-1][1]+1]} "$stack[-1][0]"} if @lin
es; |
| } | | } |
| } | | } |
| join '', map "$_\n", @to_return; | | join '', map "$_\n", @to_return; |
| } | | } |
| | |
| sub _file_same { | | sub _file_same { |
| my ($from_text, $to_file) = @_; | | my ($from_text, $to_file) = @_; |
| require File::Map; | | require File::Map; |
| File::Map::map_file(my $to_map, $to_file, '<'); | | File::Map::map_file(my $to_map, $to_file, '<'); |
| s/^[^\n]*#line[^\n]*?\n//gm for $from_text, (my $to_text = $to_map); | | s/^[^\n]*#line[^\n]*?\n//gm for $from_text, (my $to_text = $to_map); |
| | |
| skipping to change at line 1011 | | skipping to change at line 1020 |
|---|
| warn \"$warning_main\n$warning_suppression_runtime\" unless \$ENV{$envvar}; | | warn \"$warning_main\n$warning_suppression_runtime\" unless \$ENV{$envvar}; |
| EOF | | EOF |
| } | | } |
| | |
| use Carp; | | use Carp; |
| $SIG{__DIE__} = \&Carp::confess if $::PP_VERBOSE; | | $SIG{__DIE__} = \&Carp::confess if $::PP_VERBOSE; |
| | |
| my $typemap_obj; | | my $typemap_obj; |
| sub _load_typemap { | | sub _load_typemap { |
| require ExtUtils::Typemaps; | | require ExtUtils::Typemaps; |
|
| | require PDL::Core::Dev; |
| # according to MM_Unix 'privlibexp' is the right directory | | # according to MM_Unix 'privlibexp' is the right directory |
| # seems to work even on OS X (where installprivlib breaks things) | | # seems to work even on OS X (where installprivlib breaks things) |
| my $_rootdir = $Config{privlibexp}.'/ExtUtils/'; | | my $_rootdir = $Config{privlibexp}.'/ExtUtils/'; |
| # First the system typemaps.. | | # First the system typemaps.. |
| my @tm = ($_rootdir.'../../../../lib/ExtUtils/typemap', | | my @tm = ($_rootdir.'../../../../lib/ExtUtils/typemap', |
| $_rootdir.'../../../lib/ExtUtils/typemap', | | $_rootdir.'../../../lib/ExtUtils/typemap', |
| $_rootdir.'../../lib/ExtUtils/typemap', | | $_rootdir.'../../lib/ExtUtils/typemap', |
| $_rootdir.'../../../typemap', | | $_rootdir.'../../../typemap', |
| $_rootdir.'../../typemap', $_rootdir.'../typemap', | | $_rootdir.'../../typemap', $_rootdir.'../typemap', |
| $_rootdir.'typemap'); | | $_rootdir.'typemap'); |
| | |
| skipping to change at line 1045 | | skipping to change at line 1055 |
|---|
| } | | } |
| sub typemap_eval { # lifted from ExtUtils::ParseXS::Eval, ignoring eg $ALIAS | | sub typemap_eval { # lifted from ExtUtils::ParseXS::Eval, ignoring eg $ALIAS |
| my ($code, $varhash) = @_; | | my ($code, $varhash) = @_; |
| my ($var, $type, $num, $init, $printed_name, $arg, $ntype, $argoff, $subtype) | | my ($var, $type, $num, $init, $printed_name, $arg, $ntype, $argoff, $subtype) |
| = @$varhash{qw(var type num init printed_name arg ntype argoff subtype)}; | | = @$varhash{qw(var type num init printed_name arg ntype argoff subtype)}; |
| my $rv = eval qq("$code"); | | my $rv = eval qq("$code"); |
| die $@ if $@; | | die $@ if $@; |
| $rv; | | $rv; |
| } | | } |
| | |
|
| | sub pp_add_typemaps { |
| | confess "Usage: pp_add_typemaps([string|file|typemap]=>\$arg)" if @_ != 2; |
| | $typemap_obj ||= _load_typemap(); |
| | my $new_obj = $_[0] eq 'typemap' ? $_[1] : ExtUtils::Typemaps->new(@_); |
| | pp_addxs($new_obj->as_embedded_typemap); |
| | $typemap_obj->merge(typemap => $new_obj, replace => 1); |
| | } |
| | |
| sub make_xs_code { | | sub make_xs_code { |
| my($xscode_before,$xscode_after,$str, | | my($xscode_before,$xscode_after,$str, |
| $xs_c_headers, | | $xs_c_headers, |
| @bits) = @_; | | @bits) = @_; |
| my($boot,$prelude); | | my($boot,$prelude); |
| if($xs_c_headers) { | | if($xs_c_headers) { |
| $prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]); | | $prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]); |
| $boot = $xs_c_headers->[2]; | | $boot = $xs_c_headers->[2]; |
| $str .= "\n"; | | $str .= "\n"; |
| } else { | | } else { |
| | |
| skipping to change at line 1387 | | skipping to change at line 1405 |
|---|
| $pdimexpr =~ s/\$CDIM\b/i/g; | | $pdimexpr =~ s/\$CDIM\b/i/g; |
| PDL::PP::pp_line_numbers(__LINE__-1, ' | | PDL::PP::pp_line_numbers(__LINE__-1, ' |
| int i,cor; | | int i,cor; |
| '.$dimcheck.' | | '.$dimcheck.' |
| $SETNDIMS($PDL(PARENT)->ndims); | | $SETNDIMS($PDL(PARENT)->ndims); |
| $DOPRIVALLOC(); | | $DOPRIVALLOC(); |
| $PRIV(offs) = 0; | | $PRIV(offs) = 0; |
| for(i=0; i<$PDL(CHILD)->ndims; i++) { | | for(i=0; i<$PDL(CHILD)->ndims; i++) { |
| cor = '.$pdimexpr.'; | | cor = '.$pdimexpr.'; |
| $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[cor]; | | $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[cor]; |
|
| $PRIV(incs[i]) = $PDL(PARENT)->dimincs[cor]; | | $PRIV(incs)[i] = $PDL(PARENT)->dimincs[cor]; |
| } | | } |
| $SETDIMS(); | | $SETDIMS(); |
| $SETDELTABROADCASTIDS(0); | | $SETDELTABROADCASTIDS(0); |
| $PRIV(dims_redone) = 1; | | $PRIV(dims_redone) = 1; |
| '); | | '); |
| }), | | }), |
| | |
| PDL::PP::Rule->new("Code", ["EquivCPOffsCode","BadFlag"], | | PDL::PP::Rule->new("Code", ["EquivCPOffsCode","BadFlag"], |
| "create Code from EquivCPOffsCode", | | "create Code from EquivCPOffsCode", |
| # NOTE: EQUIVCPOFFS and EQUIVCPTRUNC both suffer from the macro-block | | # NOTE: EQUIVCPOFFS and EQUIVCPTRUNC both suffer from the macro-block |
| | |
| skipping to change at line 1510 | | skipping to change at line 1528 |
|---|
| sub { | | sub { |
| my ($sig, $Name, $hasp2c) = @_; | | my ($sig, $Name, $hasp2c) = @_; |
| my $noDimmedArgs = $sig->dims_count; | | my $noDimmedArgs = $sig->dims_count; |
| my $noArgs = @{$sig->names}; | | my $noArgs = @{$sig->names}; |
| # Check for 2-arg function with 0-dim signatures | | # Check for 2-arg function with 0-dim signatures |
| return 0 if !($noDimmedArgs == 0 and $noArgs == 2); | | return 0 if !($noDimmedArgs == 0 and $noArgs == 2); |
| # Check to see if output arg is _not_ explicitly typed: | | # Check to see if output arg is _not_ explicitly typed: |
| !$sig->objs->{$sig->names->[1]}{FlagTyped}; | | !$sig->objs->{$sig->names->[1]}{FlagTyped}; |
| }), | | }), |
| | |
|
| PDL::PP::Rule->new(["InplaceCode","InplaceCheck"], ["SignatureObj","Inplace"]
, | | PDL::PP::Rule->new(["InplaceCode"], ["SignatureObj","Inplace"], |
| 'Insert code (just after HdrCode) to ensure the routine can
be done inplace', | | 'Insert code (just after HdrCode) to ensure the routine can
be done inplace', |
| # insert code, after the autogenerated xs argument processing code | | # insert code, after the autogenerated xs argument processing code |
| # produced by VarArgsXSHdr and AFTER any in HdrCode | | # produced by VarArgsXSHdr and AFTER any in HdrCode |
| # - this code flags the routine as working inplace, | | # - this code flags the routine as working inplace, |
| # | | # |
| # Inplace can be supplied several values | | # Inplace can be supplied several values |
| # => 1 | | # => 1 |
| # assumes fn has an input and output ndarray (eg 'a(); [o] b();') | | # assumes fn has an input and output ndarray (eg 'a(); [o] b();') |
| # => [ 'a' ] | | # => [ 'a' ] |
| # assumes several input ndarrays in sig, so 'a' labels which | | # assumes several input ndarrays in sig, so 'a' labels which |
| | |
| skipping to change at line 1533 | | skipping to change at line 1551 |
|---|
| # input ndarray is a(), output ndarray is 'b' | | # input ndarray is a(), output ndarray is 'b' |
| sub { | | sub { |
| my ( $sig, $arg ) = @_; | | my ( $sig, $arg ) = @_; |
| return '' if !$arg; | | return '' if !$arg; |
| confess "Inplace array-ref (@$arg) > 2 elements" if ref($arg) eq "ARRAY"
and @$arg > 2; | | confess "Inplace array-ref (@$arg) > 2 elements" if ref($arg) eq "ARRAY"
and @$arg > 2; |
| # find input and output ndarrays | | # find input and output ndarrays |
| my @out = $sig->names_out; | | my @out = $sig->names_out; |
| my @in = $sig->names_in; | | my @in = $sig->names_in; |
| my $in = @in == 1 ? $in[0] : undef; | | my $in = @in == 1 ? $in[0] : undef; |
| my $out = @out == 1 ? $out[0] : undef; | | my $out = @out == 1 ? $out[0] : undef; |
|
| | my %outca = map +($_=>1), $sig->names_oca; |
| | my $noutca = grep $_, values %outca; |
| if ( ref($arg) eq "ARRAY" and @$arg) { | | if ( ref($arg) eq "ARRAY" and @$arg) { |
| $in = $$arg[0]; | | $in = $$arg[0]; |
| $out = $$arg[1] if @$arg > 1; | | $out = $$arg[1] if @$arg > 1; |
| } | | } |
| confess "ERROR: Inplace does not know name of input ndarray\n" | | confess "ERROR: Inplace does not know name of input ndarray\n" |
| unless defined $in; | | unless defined $in; |
| confess "ERROR: Inplace does not know name of output ndarray\n" | | confess "ERROR: Inplace does not know name of output ndarray\n" |
| unless defined $out; | | unless defined $out; |
|
| ( | | PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_INPLACE($in, $out, $noutca) |
| PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_INPLACE($in, $out)\n"), | | \n"); |
| PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_INPLACE_CHECK($in)\n"), | | |
| ); | | |
| }), | | }), |
| PDL::PP::Rule::Returns::EmptyString->new("InplaceCode", []), | | PDL::PP::Rule::Returns::EmptyString->new("InplaceCode", []), |
|
| PDL::PP::Rule::Returns::EmptyString->new("InplaceCheck", []), | | |
| | |
| PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [], | | PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [], |
| 'Code that will be inserted at the en
d of the autogenerated xs argument processing code VargArgsXSHdr'), | | 'Code that will be inserted at the en
d of the autogenerated xs argument processing code VargArgsXSHdr'), |
| | |
| PDL::PP::Rule->new("VarArgsXSHdr", | | PDL::PP::Rule->new("VarArgsXSHdr", |
| ["Name","SignatureObj", | | ["Name","SignatureObj", |
|
| "HdrCode","InplaceCode","InplaceCheck",\"CallCopy",\"OtherParsDefaults"], | | "HdrCode","InplaceCode",\"CallCopy",\"OtherParsDefaults"], |
| 'XS code to process input arguments based on supplied Pars argument to pp_
def; not done if GlobalNew or PMCode supplied', | | 'XS code to process input arguments based on supplied Pars argument to pp_
def; not done if GlobalNew or PMCode supplied', |
| sub { | | sub { |
| my($name,$sig, | | my($name,$sig, |
|
| $hdrcode,$inplacecode,$inplacecheck,$callcopy,$defaults) = @_; | | $hdrcode,$inplacecode,$callcopy,$defaults) = @_; |
| my $optypes = $sig->otherobjs; | | my $optypes = $sig->otherobjs; |
| my @args = @{ $sig->allnames(1) }; | | my @args = @{ $sig->allnames(1) }; |
|
| my %other = map +($_ => exists($$optypes{$_})), @args; | | my %other = map +($_ => exists($$optypes{$_})), @args; |
| if (keys %{ $defaults ||= {} } < keys %other) { | | if (keys %{ $defaults ||= {} } < keys %other) { |
| my $default_seen = ''; | | my $default_seen = ''; |
| for (@args) { | | for (@args) { |
| $default_seen = $_ if exists $defaults->{$_}; | | $default_seen = $_ if exists $defaults->{$_}; |
| confess "got default-less arg '$_' after default-ful arg '$default_s
een'" | | confess "got default-less arg '$_' after default-ful arg '$default_s
een'" |
| if $default_seen and !exists $defaults->{$_}; | | if $default_seen and !exists $defaults->{$_}; |
| } | | } |
| } | | } |
| my $ci = ' '; # current indenting | | my $ci = ' '; # current indenting |
| my %ptypes = map +($_=>$$optypes{$_} ? $$optypes{$_}->get_decl('', {VarA
rrays2Ptrs=>1}) : 'pdl *'), @args; | | my %ptypes = map +($_=>$$optypes{$_} ? $$optypes{$_}->get_decl('', {VarA
rrays2Ptrs=>1}) : 'pdl *'), @args; |
| | |
| skipping to change at line 1607 | | skipping to change at line 1623 |
|---|
| $xsargs .= "$x, "; $xsdecls .= "\n\t$ptypes{$x}$x"; | | $xsargs .= "$x, "; $xsdecls .= "\n\t$ptypes{$x}$x"; |
| $outother2cnt{$x} = $cnt if $other{$x} && $other_out{$x}; | | $outother2cnt{$x} = $cnt if $other{$x} && $other_out{$x}; |
| $cnt++; | | $cnt++; |
| } | | } |
| my $pars = join "\n",map indent("$_;",$ci), $sig->alldecls(0, 0, \%alrea
dy_read); | | my $pars = join "\n",map indent("$_;",$ci), $sig->alldecls(0, 0, \%alrea
dy_read); |
| $svdecls = join "\n", grep length, $svdecls, map indent(qq{SV *${_}_SV =
@{[defined($outother2cnt{$_})?"ST($outother2cnt{$_})":'NULL']};},$ci), $sig->ot
her_out; | | $svdecls = join "\n", grep length, $svdecls, map indent(qq{SV *${_}_SV =
@{[defined($outother2cnt{$_})?"ST($outother2cnt{$_})":'NULL']};},$ci), $sig->ot
her_out; |
| my @create = (); # The names of variables which need to be created by c
alling | | my @create = (); # The names of variables which need to be created by c
alling |
| # the 'initialize' perl routine from the correct packa
ge. | | # the 'initialize' perl routine from the correct packa
ge. |
| $ci = ' '; # Current indenting | | $ci = ' '; # Current indenting |
| # clause for reading in all variables | | # clause for reading in all variables |
|
| my $clause1 = $inplacecheck; $cnt = 0; | | my $clause1 = ''; $cnt = 0; |
| foreach my $x (@args) { | | foreach my $x (@args) { |
| if ($outca{$x}) { | | if ($outca{$x}) { |
| push @create, $x; | | push @create, $x; |
| } else { | | } else { |
| my ($setter, $type) = typemap($ptypes{$x}, 'get_inputmap'); | | my ($setter, $type) = typemap($ptypes{$x}, 'get_inputmap'); |
| $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>($ou
t{$x}||$other_out{$x} ? "${x}_SV = " : '')."ST($cnt)"}); | | $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>($ou
t{$x}||$other_out{$x} ? "${x}_SV = " : '')."ST($cnt)"}); |
| $setter =~ s/.*?(?=$x\s*=\s*)//s; # zap any declarations like wh
ichdims_count | | $setter =~ s/.*?(?=$x\s*=\s*)//s; # zap any declarations like wh
ichdims_count |
| $clause1 .= indent("$setter;\n",$ci) if !$already_read{$x}; | | $clause1 .= indent("$setter;\n",$ci) if !$already_read{$x}; |
| $cnt++; | | $cnt++; |
| } | | } |
| | |
| skipping to change at line 1669 | | skipping to change at line 1685 |
|---|
| $clause1 | | $clause1 |
| } | | } |
| $clause3$clause3_coda | | $clause3$clause3_coda |
| $hdrcode | | $hdrcode |
| $inplacecode | | $inplacecode |
| END | | END |
| }), | | }), |
| | |
| # globalnew implies internal usage, not XS | | # globalnew implies internal usage, not XS |
| PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef), | | PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef), |
|
| PDL::PP::Rule->new("VarArgsXSReturn", | | PDL::PP::Rule->new("FixArgsXSOtherOutDeclSV", |
| ["SignatureObj"], | | ["SignatureObj"], |
|
| "Generate XS trailer to return output variables or leave them as modified
input variables", | | "Generate XS to declare SVs for output OtherPars", |
| sub { | | sub { |
| my ($sig) = @_; | | my ($sig) = @_; |
|
| my @outs = $sig->names_out; # names of output ndarrays in calling order | | my $optypes = $sig->otherobjs; |
| my $clause1 = join ';', map "ST($_) = $outs[$_]_SV", 0 .. $#outs; | | my @args = @{ $sig->allnames(1) }; |
| $clause1 = PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_RETURN($clause1) | | my %other = map +($_ => exists($$optypes{$_})), @args; |
| "); | | my %outca = map +($_=>1), $sig->names_oca; |
| | my %other_out = map +($_=>1), $sig->other_out; |
| | my $ci = ' '; |
| | my $cnt = 0; my %outother2cnt; |
| | foreach my $x (grep !$outca{$_}, @args) { |
| | $outother2cnt{$x} = $cnt if $other{$x} && $other_out{$x}; |
| | $cnt++; |
| | } |
| | join "\n", map indent(qq{SV *${_}_SV = ST($outother2cnt{$_});},$ci), $si |
| | g->other_out; |
| | }), |
| | PDL::PP::Rule->new("XSOtherOutSet", |
| | ["SignatureObj"], |
| | "Generate XS to set SVs to output values for OtherPars", |
| | sub { |
| | my ($sig) = @_; |
| | my $clause1 = ''; |
| my @other_out = $sig->other_out; | | my @other_out = $sig->other_out; |
| my $optypes = $sig->otherobjs; | | my $optypes = $sig->otherobjs; |
| my %ptypes = map +($_=>$$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1}))
, @other_out; | | my %ptypes = map +($_=>$$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1}))
, @other_out; |
| for my $x (@other_out) { | | for my $x (@other_out) { |
| my ($setter, $type) = typemap($ptypes{$x}, 'get_outputmap'); | | my ($setter, $type) = typemap($ptypes{$x}, 'get_outputmap'); |
| $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>"tsv"}); | | $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>"tsv"}); |
| $clause1 = <<EOF . $clause1; | | $clause1 = <<EOF . $clause1; |
|
| { SV *tsv = NULL; | | { SV *tsv = sv_2mortal(newSV(0)); |
| $setter | | $setter |
|
| sv_setsv(${x}_SV, tsv); sv_2mortal(tsv); } | | sv_setsv(${x}_SV, tsv); } |
| EOF | | EOF |
| } | | } |
| $clause1; | | $clause1; |
| }), | | }), |
|
| | PDL::PP::Rule->new("VarArgsXSReturn", |
| | ["SignatureObj","XSOtherOutSet"], |
| | "Generate XS trailer to return output variables or leave them as modified |
| | input variables", |
| | sub { |
| | my ($sig,$other_out_set) = @_; |
| | my @outs = $sig->names_out; # names of output ndarrays in calling order |
| | my $clause1 = join ';', map "ST($_) = $outs[$_]_SV", 0 .. $#outs; |
| | $other_out_set.PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_RETURN($clau |
| | se1)"); |
| | }), |
| | |
| PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"], | | PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"], |
| sub { | | sub { |
| my($name,$sig) = @_; | | my($name,$sig) = @_; |
| my $shortpars = join ',', @{ $sig->allnames(1) }; | | my $shortpars = join ',', @{ $sig->allnames(1) }; |
| my $longpars = join "\n", map "\t$_", $sig->alldecls(1, 0); | | my $longpars = join "\n", map "\t$_", $sig->alldecls(1, 0); |
| return<<END; | | return<<END; |
| \nvoid | | \nvoid |
| $name($shortpars) | | $name($shortpars) |
| $longpars | | $longpars |
| | |
| skipping to change at line 1941 | | skipping to change at line 1982 |
|---|
| PDL::PP::pp_line_numbers __LINE__-1, join '', "$xs_c_header {\n$opening\
n", @bits, "$closing\n}\n"; | | PDL::PP::pp_line_numbers __LINE__-1, join '', "$xs_c_header {\n$opening\
n", @bits, "$closing\n}\n"; |
| }), | | }), |
| | |
| # internal usage, not XS - NewXSCHdrs only set if GlobalNew | | # internal usage, not XS - NewXSCHdrs only set if GlobalNew |
| PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], | | PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], |
| ["NewXSHdr", "NewXSCHdrs", "RunFuncCall"], | | ["NewXSHdr", "NewXSCHdrs", "RunFuncCall"], |
| "Non-varargs XS code when GlobalNew given", | | "Non-varargs XS code when GlobalNew given", |
| sub {(undef,(make_xs_code('CODE:',' XSRETURN(0);',@_))[1..2])}), | | sub {(undef,(make_xs_code('CODE:',' XSRETURN(0);',@_))[1..2])}), |
| # if PMCode supplied, no var-args stuff | | # if PMCode supplied, no var-args stuff |
| PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], | | PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], |
|
| ["PMCode","NewXSHdr", \"NewXSCHdrs", "RunFuncCall"], | | ["PMCode","NewXSHdr", \"NewXSCHdrs", qw(FixArgsXSOtherOutDeclSV RunFuncCal
l XSOtherOutSet)], |
| "Non-varargs XS code when PMCode given", | | "Non-varargs XS code when PMCode given", |
| sub {make_xs_code('CODE:',' XSRETURN(0);',@_[1..$#_])}), | | sub {make_xs_code('CODE:',' XSRETURN(0);',@_[1..$#_])}), |
| PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], | | PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], |
| [qw(VarArgsXSHdr), \"NewXSCHdrs", qw(RunFuncCall VarArgsXSReturn)], | | [qw(VarArgsXSHdr), \"NewXSCHdrs", qw(RunFuncCall VarArgsXSReturn)], |
| "Rule to print out XS code when variable argument list XS processing is en
abled", | | "Rule to print out XS code when variable argument list XS processing is en
abled", |
| sub {make_xs_code('','',@_)}), | | sub {make_xs_code('','',@_)}), |
| | |
| PDL::PP::Rule::Returns::Zero->new("NoPthread"), # assume we can pthread, unle
ss indicated otherwise | | PDL::PP::Rule::Returns::Zero->new("NoPthread"), # assume we can pthread, unle
ss indicated otherwise |
| PDL::PP::Rule->new("VTableDef", | | PDL::PP::Rule->new("VTableDef", |
| ["VTableName","ParamStructType","RedoDimsFuncName","ReadDataFuncName", | | ["VTableName","ParamStructType","RedoDimsFuncName","ReadDataFuncName", |
| "WriteBackDataFuncName","FreeFuncName", | | "WriteBackDataFuncName","FreeFuncName", |
| "SignatureObj","Affine_Ok","HaveBroadcasting","NoPthread","Name", | | "SignatureObj","Affine_Ok","HaveBroadcasting","NoPthread","Name", |
| "GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag", | | "GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag", |
| "BadFlag"], | | "BadFlag"], |
| sub { | | sub { |
| my($vname,$ptype,$rdname,$rfname,$wfname,$ffname, | | my($vname,$ptype,$rdname,$rfname,$wfname,$ffname, |
| $sig,$affine_ok,$havebroadcasting, $noPthreadFlag, $name, $gentypes, | | $sig,$affine_ok,$havebroadcasting, $noPthreadFlag, $name, $gentypes, |
| $affflag, $revflag, $flowflag, $badflag) = @_; | | $affflag, $revflag, $flowflag, $badflag) = @_; |
| my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs); | | my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs); |
|
| my $nparents = 0 + grep {! $pobjs->{$_}->{FlagW}} @$pnames; | | my $nparents = 0 + grep !$pobjs->{$_}->{FlagW}, @$pnames; |
| my $aff = ($affine_ok ? "PDL_TPDL_VAFFINE_OK" : 0); | | my $aff = ($affine_ok ? "PDL_TPDL_VAFFINE_OK" : 0); |
| my $npdls = scalar @$pnames; | | my $npdls = scalar @$pnames; |
| my $join_flags = join(", ",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ? | | my $join_flags = join(", ",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ? |
| 0 : $aff} 0..$npdls-1) || '0'; | | 0 : $aff} 0..$npdls-1) || '0'; |
| my @op_flags; | | my @op_flags; |
| push @op_flags, 'PDL_TRANS_DO_BROADCAST' if $havebroadcasting; | | push @op_flags, 'PDL_TRANS_DO_BROADCAST' if $havebroadcasting; |
| push @op_flags, 'PDL_TRANS_BADPROCESS' if $badflag; | | push @op_flags, 'PDL_TRANS_BADPROCESS' if $badflag; |
| push @op_flags, 'PDL_TRANS_BADIGNORE' if defined $badflag and !$badflag; | | push @op_flags, 'PDL_TRANS_BADIGNORE' if defined $badflag and !$badflag; |
| push @op_flags, 'PDL_TRANS_NO_PARALLEL' if $noPthreadFlag; | | push @op_flags, 'PDL_TRANS_NO_PARALLEL' if $noPthreadFlag; |
| push @op_flags, 'PDL_TRANS_OUTPUT_OTHERPAR' if $sig->other_any_out; | | push @op_flags, 'PDL_TRANS_OUTPUT_OTHERPAR' if $sig->other_any_out; |
| | | |
| End of changes. 28 change blocks. |
|---|
| 35 lines changed or deleted | | 80 lines changed or added |
|---|
"Fossies" - the Fresh Open Source Software Archive 