line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
############################################## |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
############################################## |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package PDLA::PP::PdlParObj; |
6
|
|
|
|
|
|
|
|
7
|
3
|
|
|
3
|
|
24
|
use Carp; |
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
183
|
|
8
|
3
|
|
|
3
|
|
19
|
use PDLA::Types; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
436
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
# check for bad value support |
11
|
|
|
|
|
|
|
# |
12
|
3
|
|
|
3
|
|
439
|
use PDLA::Config; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
251
|
|
13
|
|
|
|
|
|
|
my $usenan = $PDLA::Config{BADVAL_USENAN} || 0; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our %Typemap = (); |
16
|
3
|
|
|
3
|
|
21
|
use PDLA::Types ':All'; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
5008
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# build a typemap for our translation purposes |
19
|
|
|
|
|
|
|
# again from info in PDLA::Types |
20
|
|
|
|
|
|
|
for my $typ (typesrtkeys) { |
21
|
|
|
|
|
|
|
$Typemap{typefld($typ,'ppforcetype')} = { |
22
|
|
|
|
|
|
|
Ctype => typefld($typ,'ctype'), |
23
|
|
|
|
|
|
|
Cenum => typefld($typ,'sym'), |
24
|
|
|
|
|
|
|
Val => typefld($typ,'numval'), |
25
|
|
|
|
|
|
|
}; |
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# Try to load Text::Balanced |
29
|
|
|
|
|
|
|
my $hasTB = 0; |
30
|
3
|
|
|
3
|
|
1365
|
eval q{ |
|
3
|
|
|
|
|
19767
|
|
|
3
|
|
|
|
|
134
|
|
31
|
|
|
|
|
|
|
use Text::Balanced; |
32
|
|
|
|
|
|
|
$hasTB = 1; |
33
|
|
|
|
|
|
|
}; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# split regex $re separated arglist |
36
|
|
|
|
|
|
|
# but ignore bracket-protected bits |
37
|
|
|
|
|
|
|
# (i.e. text that is within matched brackets) |
38
|
|
|
|
|
|
|
# fallback to simple split if we can't find Text::Balanced |
39
|
|
|
|
|
|
|
my $prebrackreg = qr/^([^\(\{\[]*)/; |
40
|
|
|
|
|
|
|
sub splitprotected ($$) { |
41
|
0
|
|
|
0
|
0
|
0
|
my ($re,$txt) = @_; |
42
|
0
|
0
|
|
|
|
0
|
return split $re, $txt unless $hasTB; |
43
|
0
|
0
|
0
|
|
|
0
|
return () if !defined $txt || $txt =~ /^\s*$/; |
44
|
0
|
|
|
|
|
0
|
my ($got,$pre) = (1,''); |
45
|
0
|
|
|
|
|
0
|
my @chunks = (''); |
46
|
0
|
|
|
|
|
0
|
my $ct = 0; # infinite loop protection |
47
|
0
|
|
0
|
|
|
0
|
while ($got && $txt =~ /[({\[]/ && $ct++ < 1000) { |
|
|
|
0
|
|
|
|
|
48
|
|
|
|
|
|
|
# print "iteration $ct\n"; |
49
|
0
|
|
|
|
|
0
|
($got,$txt,$pre) = |
50
|
|
|
|
|
|
|
Text::Balanced::extract_bracketed($txt,'{}()[]',$prebrackreg); |
51
|
0
|
|
|
|
|
0
|
my @partialargs = split $re, $pre, -1; |
52
|
0
|
0
|
|
|
|
0
|
$chunks[-1] .= shift @partialargs if @partialargs; |
53
|
0
|
|
|
|
|
0
|
push @chunks, @partialargs; |
54
|
0
|
|
|
|
|
0
|
$chunks[-1] .= $got; |
55
|
|
|
|
|
|
|
} |
56
|
0
|
0
|
|
|
|
0
|
confess "possible infinite parse loop, splitting '$txt' " |
57
|
|
|
|
|
|
|
if $ct >= 1000; |
58
|
0
|
|
|
|
|
0
|
my @partialargs = split $re, $txt, -1; |
59
|
0
|
0
|
|
|
|
0
|
$chunks[-1] .= shift @partialargs if @partialargs; |
60
|
0
|
0
|
|
|
|
0
|
push @chunks, @partialargs if @partialargs; |
61
|
|
|
|
|
|
|
# print STDERR "args found: $#chunks\n"; |
62
|
|
|
|
|
|
|
# print STDERR "splitprotected $txt on $re: [",join('|',@chunks),"]\n"; |
63
|
0
|
|
|
|
|
0
|
return @chunks; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# null != [0] |
67
|
|
|
|
|
|
|
# - in Core. |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
#{package PDLA; |
70
|
|
|
|
|
|
|
# sub isnull { |
71
|
|
|
|
|
|
|
# my $this = shift; |
72
|
|
|
|
|
|
|
# return ($this->getndims==1 && $this->getdim(0)==0) ? 1:0 } |
73
|
|
|
|
|
|
|
#} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
1; |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
#__DATA__ |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# need for $badflag is due to hacked get_xsdatapdecl() |
80
|
|
|
|
|
|
|
# - this should disappear when (if?) things are done sensibly |
81
|
|
|
|
|
|
|
# |
82
|
|
|
|
|
|
|
my $typeregex = join '|', map {typefld($_,'ppforcetype')} typesrtkeys; |
83
|
|
|
|
|
|
|
our $pars_re = qr/^ |
84
|
|
|
|
|
|
|
\s*((?:$typeregex)[+]*|)\s* # $1: first option |
85
|
|
|
|
|
|
|
(?: |
86
|
|
|
|
|
|
|
\[([^]]*)\] # $2: The initial [option] part |
87
|
|
|
|
|
|
|
)?\s* |
88
|
|
|
|
|
|
|
(\w+) # $3: The name |
89
|
|
|
|
|
|
|
\(([^)]*)\) # $4: The indices |
90
|
|
|
|
|
|
|
/x; |
91
|
|
|
|
|
|
|
sub new { |
92
|
9
|
|
|
9
|
0
|
5315
|
my($type,$string,$number,$badflag) = @_; |
93
|
9
|
|
50
|
|
|
47
|
$badflag ||= 0; |
94
|
9
|
|
|
|
|
36
|
my $this = bless {Number => $number, BadFlag => $badflag},$type; |
95
|
|
|
|
|
|
|
# Parse the parameter string. Note that the regexes for this match were |
96
|
|
|
|
|
|
|
# originally defined here, but were moved to PDLA::PP for FullDoc parsing. |
97
|
9
|
50
|
|
|
|
73
|
$string =~ $pars_re |
98
|
|
|
|
|
|
|
or confess "Invalid pdl def $string (regex $typeregex)\n"; |
99
|
9
|
|
|
|
|
51
|
my($opt1,$opt2,$name,$inds) = ($1,$2,$3,$4); |
100
|
9
|
100
|
|
|
|
20
|
map {$_ = '' unless defined($_)} ($opt1,$opt2,$inds); # shut up -w |
|
27
|
|
|
|
|
92
|
|
101
|
9
|
50
|
|
|
|
25
|
print "PDLA: '$opt1', '$opt2', '$name', '$inds'\n" |
102
|
|
|
|
|
|
|
if $::PP_VERBOSE; |
103
|
|
|
|
|
|
|
# Set my internal variables |
104
|
9
|
|
|
|
|
35
|
$this->{Name} = $name; |
105
|
9
|
50
|
|
|
|
38
|
$this->{Flags} = [(split ',',$opt2),($opt1?$opt1:())]; |
106
|
9
|
|
|
|
|
15
|
for(@{$this->{Flags}}) { |
|
9
|
|
|
|
|
26
|
|
107
|
|
|
|
|
|
|
/^io$/ and $this->{FlagW}=1 or |
108
|
|
|
|
|
|
|
/^nc$/ and $this->{FlagNCreat}=1 or |
109
|
|
|
|
|
|
|
/^o$/ and $this->{FlagOut}=1 and $this->{FlagCreat}=1 and $this->{FlagW}=1 or |
110
|
|
|
|
|
|
|
/^oca$/ and $this->{FlagOut}=1 and $this->{FlagCreat}=1 and $this->{FlagW}=1 |
111
|
|
|
|
|
|
|
and $this->{FlagCreateAlways}=1 or |
112
|
|
|
|
|
|
|
/^t$/ and $this->{FlagTemp}=1 and $this->{FlagCreat}=1 and $this->{FlagW}=1 or |
113
|
|
|
|
|
|
|
/^phys$/ and $this->{FlagPhys} = 1 or |
114
|
1
|
0
|
50
|
|
|
35
|
/^((?:$typeregex)[+]*)$/ and $this->{Type} = $1 and $this->{FlagTyped} = 1 or |
|
|
|
50
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
115
|
|
|
|
|
|
|
confess("Invalid flag $_ given for $string\n"); |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
# if($this->{FlagPhys}) { |
118
|
|
|
|
|
|
|
# # warn("Warning: physical flag not implemented yet"); |
119
|
|
|
|
|
|
|
# } |
120
|
9
|
50
|
33
|
|
|
34
|
if ($this->{FlagTyped} && $this->{Type} =~ s/[+]$// ) { |
121
|
0
|
|
|
|
|
0
|
$this->{FlagTplus} = 1; |
122
|
|
|
|
|
|
|
} |
123
|
9
|
50
|
|
|
|
23
|
if($this->{FlagNCreat}) { |
124
|
0
|
|
|
|
|
0
|
delete $this->{FlagCreat}; |
125
|
0
|
|
|
|
|
0
|
delete $this->{FlagCreateAlways}; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
my @inds = map{ |
128
|
9
|
|
|
|
|
24
|
s/\s//g; # Remove spaces |
|
9
|
|
|
|
|
21
|
|
129
|
9
|
|
|
|
|
27
|
$_; |
130
|
|
|
|
|
|
|
} split ',', $inds; |
131
|
9
|
|
|
|
|
28
|
$this->{RawInds} = [@inds]; |
132
|
9
|
|
|
|
|
26
|
return $this; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
18
|
|
|
18
|
0
|
90
|
sub name {return (shift)->{Name}} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
sub add_inds { |
138
|
11
|
|
|
11
|
0
|
87
|
my($this,$dimsobj) = @_; |
139
|
11
|
|
|
|
|
32
|
$this->{IndObjs} = [map {$dimsobj->get_indobj_make($_)} |
140
|
11
|
|
|
|
|
19
|
@{$this->{RawInds}}]; |
|
11
|
|
|
|
|
26
|
|
141
|
11
|
|
|
|
|
24
|
my %indcount; |
142
|
|
|
|
|
|
|
$this->{IndCounts} = [ |
143
|
|
|
|
|
|
|
map { |
144
|
11
|
|
|
|
|
30
|
0+($indcount{$_->name}++); |
145
|
11
|
|
|
|
|
17
|
} @{$this->{IndObjs}} |
|
11
|
|
|
|
|
23
|
|
146
|
|
|
|
|
|
|
]; |
147
|
|
|
|
|
|
|
$this->{IndTotCounts} = [ |
148
|
|
|
|
|
|
|
map { |
149
|
11
|
|
|
|
|
23
|
($indcount{$_->name}); |
150
|
11
|
|
|
|
|
22
|
} @{$this->{IndObjs}} |
|
11
|
|
|
|
|
25
|
|
151
|
|
|
|
|
|
|
]; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# do the dimension checking for perl level threading |
156
|
|
|
|
|
|
|
# assumes that IndObjs have been created |
157
|
|
|
|
|
|
|
sub perldimcheck { |
158
|
9
|
|
|
9
|
0
|
70
|
my ($this,$pdl) = @_; |
159
|
|
|
|
|
|
|
croak ("can't create ".$this->name) if $pdl->isnull && |
160
|
9
|
50
|
66
|
|
|
51
|
!$this->{FlagCreat}; |
161
|
9
|
100
|
|
|
|
28
|
return 1 if $pdl->isnull; |
162
|
8
|
|
|
|
|
12
|
my $rdims = @{$this->{RawInds}}; |
|
8
|
|
|
|
|
17
|
|
163
|
8
|
50
|
|
|
|
35
|
croak ("not enough dimensions for ".$this->name) |
164
|
|
|
|
|
|
|
if ($pdl->threadids)[0] < $rdims; |
165
|
8
|
|
|
|
|
20
|
my @dims = $pdl->dims; |
166
|
8
|
|
|
|
|
20
|
my ($i,$ind) = (0,undef); |
167
|
8
|
|
|
|
|
12
|
for $ind (@{$this->{IndObjs}}) { |
|
8
|
|
|
|
|
18
|
|
168
|
9
|
|
|
|
|
35
|
$ind->add_value($dims[$i++]); |
169
|
|
|
|
|
|
|
} |
170
|
6
|
|
|
|
|
23
|
return 0; # not creating |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub finalcheck { |
174
|
6
|
|
|
6
|
0
|
67
|
my ($this,$pdl) = @_; |
175
|
6
|
100
|
|
|
|
24
|
return [] if $pdl->isnull; |
176
|
5
|
|
|
|
|
20
|
my @corr = (); |
177
|
5
|
|
|
|
|
15
|
my @dims = $pdl->dims; |
178
|
5
|
|
|
|
|
11
|
my ($i,$ind) = (0,undef); |
179
|
5
|
|
|
|
|
9
|
for $ind (@{$this->{IndObjs}}) { |
|
5
|
|
|
|
|
13
|
|
180
|
6
|
100
|
|
|
|
20
|
push @corr,[$i-1,$ind->{Value},$dims[$i-1]] if $dims[$i++] != $ind->{Value}; |
181
|
|
|
|
|
|
|
} |
182
|
5
|
|
|
|
|
16
|
return [@corr]; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
# get index sizes for a parameter that has to be created |
186
|
|
|
|
|
|
|
sub getcreatedims { |
187
|
1
|
|
|
1
|
0
|
14
|
my $this = shift; |
188
|
|
|
|
|
|
|
return map |
189
|
|
|
|
|
|
|
{ croak "can't create: index size ".$_->name." not initialised" |
190
|
0
|
0
|
0
|
|
|
0
|
if !defined($_->{Value}) || $_->{Value} < 1; |
191
|
1
|
|
|
|
|
2
|
$_->{Value} } @{$this->{IndObjs}}; |
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
4
|
|
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
# find the value for a given PDLA type |
196
|
|
|
|
|
|
|
sub typeval { |
197
|
0
|
|
|
0
|
0
|
0
|
my $ctype = shift; |
198
|
0
|
|
|
|
|
0
|
my @match = grep {$Typemap{$_}->{Ctype} =~ /^$ctype$/} keys(%Typemap); |
|
0
|
|
|
|
|
0
|
|
199
|
0
|
0
|
|
|
|
0
|
if ($#match < 0) { |
200
|
3
|
|
|
3
|
|
676
|
use Data::Dumper; |
|
3
|
|
|
|
|
6794
|
|
|
3
|
|
|
|
|
7366
|
|
201
|
0
|
|
|
|
|
0
|
print Dumper \%Typemap; |
202
|
0
|
|
|
|
|
0
|
croak "unknown PDLA type '$ctype'" ; |
203
|
|
|
|
|
|
|
} |
204
|
0
|
|
|
|
|
0
|
return $Typemap{$match[0]}->{Val}; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
# return the PDLA type for this pdl |
208
|
|
|
|
|
|
|
sub ctype { |
209
|
4
|
|
|
4
|
0
|
8
|
my ($this,$generic) = @_; |
210
|
4
|
50
|
|
|
|
13
|
return $generic unless $this->{FlagTyped}; |
211
|
|
|
|
|
|
|
croak "ctype: unknownn type" |
212
|
0
|
0
|
|
|
|
0
|
unless defined($Typemap{$this->{Type}}); |
213
|
0
|
|
|
|
|
0
|
my $type = $Typemap{$this->{Type}}->{Ctype}; |
214
|
0
|
0
|
|
|
|
0
|
if ($this->{FlagTplus}) { |
215
|
|
|
|
|
|
|
$type = $Typemap{$this->{Type}}->{Val} > |
216
|
|
|
|
|
|
|
PDLA::PP::PdlParObj::typeval($generic) ? |
217
|
0
|
0
|
|
|
|
0
|
$Typemap{$this->{Type}}->{Ctype} : $generic; |
218
|
|
|
|
|
|
|
} |
219
|
0
|
|
|
|
|
0
|
return $type; |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# return the enum type for a parobj; it'd better be typed |
223
|
|
|
|
|
|
|
sub cenum { |
224
|
0
|
|
|
0
|
0
|
0
|
my $this = shift; |
225
|
|
|
|
|
|
|
croak "cenum: unknown type [" . $this->{Type} . "]" |
226
|
0
|
0
|
|
|
|
0
|
unless defined($PDLA::PP::PdlParObj::Typemap{$this->{Type}}); |
227
|
0
|
|
|
|
|
0
|
return $PDLA::PP::PdlParObj::Typemap{$this->{Type}}->{Cenum}; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
5
|
|
|
5
|
0
|
6
|
sub get_nname{ my($this) = @_; |
231
|
5
|
|
|
|
|
16
|
"(\$PRIV(pdls[$this->{Number}]))"; |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
4
|
|
|
4
|
0
|
9
|
sub get_nnflag { my($this) = @_; |
235
|
4
|
|
|
|
|
16
|
"(\$PRIV(vtable->per_pdl_flags[$this->{Number}]))"; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
# XXX There might be weird backprop-of-changed stuff for [phys]. |
240
|
|
|
|
|
|
|
# |
241
|
|
|
|
|
|
|
# Have changed code to assume that, if(!$this->{FlagCreat}) |
242
|
|
|
|
|
|
|
# then __creating[] will == 0 |
243
|
|
|
|
|
|
|
# -- see make_redodims_thread() in ../PP.pm |
244
|
|
|
|
|
|
|
# |
245
|
|
|
|
|
|
|
sub get_xsnormdimchecks { |
246
|
1
|
|
|
1
|
0
|
3
|
my($this) = @_; |
247
|
1
|
|
|
|
|
3
|
my $pdl = $this->get_nname; |
248
|
1
|
|
|
|
|
2
|
my $iref = $this->{IndObjs}; |
249
|
1
|
|
|
|
|
3
|
my $ninds = 0+scalar(@$iref); |
250
|
|
|
|
|
|
|
|
251
|
1
|
|
|
|
|
2
|
my $str = ""; |
252
|
1
|
50
|
|
|
|
3
|
$str .= "if(!__creating[$this->{Number}]) {\n" if $this->{FlagCreat}; |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# Dimensional Promotion when number of dims is less than required: |
255
|
|
|
|
|
|
|
# Previous warning message now commented out, |
256
|
|
|
|
|
|
|
# which means we only need include the code if $ninds > 0 |
257
|
|
|
|
|
|
|
# |
258
|
1
|
50
|
|
|
|
3
|
if ( $ninds > 0 ) { |
259
|
|
|
|
|
|
|
$str .= " if(($pdl)->ndims < $ninds) {\n" . |
260
|
|
|
|
|
|
|
join('', map { |
261
|
1
|
|
|
|
|
5
|
my $size = $iref->[$_-1]->get_size(); |
|
1
|
|
|
|
|
5
|
|
262
|
1
|
|
|
|
|
7
|
" if (($pdl)->ndims < $_ && $size <= 1) $size = 1;\n" |
263
|
|
|
|
|
|
|
} (1..$ninds)) |
264
|
|
|
|
|
|
|
# XXX why is this here, commented, and not removed? If re-inserted, be sure to use PDLA_COMMENT |
265
|
|
|
|
|
|
|
## ." /* \$CROAK(\"Too few dimensions for argument \'$this->{Name}\'\\n\"); */\n" |
266
|
|
|
|
|
|
|
. " }\n"; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
# Now, the real check. |
270
|
1
|
|
|
|
|
2
|
my $no = 0; |
271
|
1
|
|
|
|
|
3
|
for( @$iref ) { |
272
|
1
|
|
|
|
|
2
|
my $siz = $_->get_size(); |
273
|
1
|
|
|
|
|
4
|
my $dim = "($pdl)->dims[$no]"; |
274
|
1
|
|
|
|
|
2
|
my $ndims = "($pdl)->ndims"; |
275
|
1
|
|
|
|
|
10
|
$str .= " if($siz == -1 || ($ndims > $no && $siz == 1)) {\n" . |
276
|
|
|
|
|
|
|
" $siz = $dim;\n" . |
277
|
|
|
|
|
|
|
" } else if($ndims > $no && $siz != $dim) {\n" . |
278
|
|
|
|
|
|
|
# XXX should these lines simply be removed? If re-inserted, be sure to use PDLA_COMMENT |
279
|
|
|
|
|
|
|
# " if($dim == 1) {\n" . |
280
|
|
|
|
|
|
|
# " /* Do nothing */ /* XXX Careful, increment? */" . |
281
|
|
|
|
|
|
|
# " } else {\n" . |
282
|
|
|
|
|
|
|
" if($dim != 1) {\n" . |
283
|
|
|
|
|
|
|
" \$CROAK(\"Wrong dims\\n\");\n" . |
284
|
|
|
|
|
|
|
" }\n }\n"; |
285
|
1
|
|
|
|
|
3
|
$no++; |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
|
288
|
1
|
50
|
|
|
|
4
|
$str .= "PDLA->make_physical(($pdl));\n" if $this->{FlagPhys}; |
289
|
|
|
|
|
|
|
|
290
|
1
|
50
|
|
|
|
3
|
if ( $this->{FlagCreat} ) { |
291
|
0
|
|
|
|
|
0
|
$str .= "} else {\n"; |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
# We are creating this pdl. |
294
|
0
|
|
|
|
|
0
|
$str .= " PDLA_Indx dims[".($ninds+1)."]; PDLA_COMMENT(\"Use ninds+1 to avoid smart (stupid) compilers\")"; |
295
|
|
|
|
|
|
|
$str .= join "", |
296
|
0
|
|
|
|
|
0
|
(map {"dims[$_] = ".$iref->[$_]->get_size().";"} 0 .. $#$iref); |
|
0
|
|
|
|
|
0
|
|
297
|
0
|
0
|
|
|
|
0
|
my $istemp = $this->{FlagTemp} ? 1 : 0; |
298
|
0
|
|
|
|
|
0
|
$str .="\n PDLA->thread_create_parameter(&\$PRIV(__pdlthread),$this->{Number},dims,$istemp);\n"; |
299
|
0
|
|
|
|
|
0
|
$str .= "}"; |
300
|
|
|
|
|
|
|
} |
301
|
1
|
|
|
|
|
5
|
return $str; |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
} # sub: get_xsnormdimchecks() |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
sub get_incname { |
306
|
10
|
|
|
10
|
0
|
23
|
my($this,$ind) = @_; |
307
|
10
|
50
|
|
|
|
30
|
if($this->{IndTotCounts}[$ind] > 1) { |
308
|
0
|
|
|
|
|
0
|
"__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name).$this->{IndCounts}[$ind]; |
309
|
|
|
|
|
|
|
} else { |
310
|
10
|
|
|
|
|
38
|
"__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name); |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
sub get_incdecls { |
315
|
1
|
|
|
1
|
0
|
3
|
my($this) = @_; |
316
|
1
|
50
|
|
|
|
2
|
if(scalar(@{$this->{IndObjs}}) == 0) {return "";} |
|
1
|
|
|
|
|
4
|
|
|
0
|
|
|
|
|
0
|
|
317
|
|
|
|
|
|
|
(join '',map { |
318
|
1
|
|
|
|
|
3
|
"PDLA_Indx ".($this->get_incname($_)).";"; |
319
|
1
|
|
|
|
|
3
|
} (0..$#{$this->{IndObjs}}) ) . ";" |
|
1
|
|
|
|
|
3
|
|
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
sub get_incregisters { |
323
|
3
|
|
|
3
|
0
|
10
|
my($this) = @_; |
324
|
3
|
50
|
|
|
|
5
|
if(scalar(@{$this->{IndObjs}}) == 0) {return "";} |
|
3
|
|
|
|
|
14
|
|
|
0
|
|
|
|
|
0
|
|
325
|
|
|
|
|
|
|
(join '',map { |
326
|
3
|
|
|
|
|
15
|
"register PDLA_Indx ".($this->get_incname($_))." = \$PRIV(". |
327
|
|
|
|
|
|
|
($this->get_incname($_)).");\n"; |
328
|
3
|
|
|
|
|
92
|
} (0..$#{$this->{IndObjs}}) ) |
|
3
|
|
|
|
|
71
|
|
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
sub get_incdecl_copy { |
332
|
1
|
|
|
1
|
0
|
3
|
my($this,$fromsub,$tosub) = @_; |
333
|
|
|
|
|
|
|
join '',map { |
334
|
1
|
|
|
|
|
3
|
my $iname = $this->get_incname($_); |
335
|
1
|
|
|
|
|
3
|
&$fromsub($iname)."=".&$tosub($iname).";"; |
336
|
1
|
|
|
|
|
3
|
} (0..$#{$this->{IndObjs}}) |
|
1
|
|
|
|
|
3
|
|
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub get_incsets { |
340
|
1
|
|
|
1
|
0
|
4
|
my($this,$str) = @_; |
341
|
1
|
|
|
|
|
2
|
my $no=0; |
342
|
|
|
|
|
|
|
(join '',map { |
343
|
|
|
|
|
|
|
"if($str->ndims <= $_ || $str->dims[$_] <= 1) |
344
|
|
|
|
|
|
|
\$PRIV(".($this->get_incname($_)).") = 0; else |
345
|
|
|
|
|
|
|
\$PRIV(".($this->get_incname($_)). |
346
|
|
|
|
|
|
|
") = ".($this->{FlagPhys}? |
347
|
1
|
50
|
|
|
|
6
|
"$str->dimincs[$_];" : |
348
|
|
|
|
|
|
|
"PDLA_REPRINC($str,$_);"); |
349
|
1
|
|
|
|
|
2
|
} (0..$#{$this->{IndObjs}}) ) |
|
1
|
|
|
|
|
3
|
|
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
# Print an access part. |
353
|
|
|
|
|
|
|
sub do_access { |
354
|
0
|
|
|
0
|
0
|
0
|
my($this,$inds,$context) = @_; |
355
|
0
|
|
|
|
|
0
|
my $pdl = $this->{Name}; |
356
|
|
|
|
|
|
|
# Parse substitutions into hash |
357
|
|
|
|
|
|
|
my %subst = map |
358
|
0
|
0
|
|
|
|
0
|
{/^\s*(\w+)\s*=>\s*(\S*)\s*$/ or confess "Invalid subst $_\n"; ($1,$2)} |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
359
|
|
|
|
|
|
|
splitprotected ',',$inds; |
360
|
|
|
|
|
|
|
# Generate the text |
361
|
0
|
|
|
|
|
0
|
my $text; |
362
|
0
|
|
|
|
|
0
|
$text = "(${pdl}_datap)"."["; |
363
|
|
|
|
|
|
|
$text .= join '+','0',map { |
364
|
0
|
|
|
|
|
0
|
$this->do_indterm($pdl,$_,\%subst,$context); |
365
|
0
|
|
|
|
|
0
|
} (0..$#{$this->{IndObjs}}); |
|
0
|
|
|
|
|
0
|
|
366
|
0
|
|
|
|
|
0
|
$text .= "]"; |
367
|
|
|
|
|
|
|
# If not all substitutions made, the user probably made a spelling |
368
|
|
|
|
|
|
|
# error. Barf. |
369
|
0
|
0
|
|
|
|
0
|
if(scalar(keys %subst) != 0) { |
370
|
0
|
|
|
|
|
0
|
confess("Substitutions left: ".(join ',',keys %subst)."\n"); |
371
|
|
|
|
|
|
|
} |
372
|
0
|
|
|
|
|
0
|
return "$text PDLA_COMMENT(\"ACCESS($access)\") "; |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
sub has_dim { |
376
|
0
|
|
|
0
|
0
|
0
|
my($this,$ind) = @_; |
377
|
0
|
|
|
|
|
0
|
my $h = 0; |
378
|
0
|
|
|
|
|
0
|
for(@{$this->{IndObjs}}) { |
|
0
|
|
|
|
|
0
|
|
379
|
0
|
0
|
|
|
|
0
|
$h++ if $_->name eq $ind; |
380
|
|
|
|
|
|
|
} |
381
|
0
|
|
|
|
|
0
|
return $h; |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
sub do_resize { |
385
|
0
|
|
|
0
|
0
|
0
|
my($this,$ind,$size) = @_; |
386
|
0
|
|
|
|
|
0
|
my @c;my $index = 0; |
|
0
|
|
|
|
|
0
|
|
387
|
0
|
|
|
|
|
0
|
for(@{$this->{IndObjs}}) { |
|
0
|
|
|
|
|
0
|
|
388
|
0
|
0
|
|
|
|
0
|
push @c,$index if $_->name eq $ind; $index ++; |
|
0
|
|
|
|
|
0
|
|
389
|
|
|
|
|
|
|
} |
390
|
0
|
|
|
|
|
0
|
my $pdl = $this->get_nname; |
391
|
0
|
|
|
|
|
0
|
return (join '',map {"$pdl->dims[$_] = $size;\n"} @c). |
|
0
|
|
|
|
|
0
|
|
392
|
|
|
|
|
|
|
"PDLA->resize_defaultincs($pdl);PDLA->allocdata($pdl);". |
393
|
|
|
|
|
|
|
$this->get_xsdatapdecl(undef,1); |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
sub do_pdlaccess { |
397
|
0
|
|
|
0
|
0
|
0
|
my($this) = @_; |
398
|
0
|
|
|
|
|
0
|
return '$PRIV(pdls['.$this->{Number}.'])'; |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
sub do_pointeraccess { |
403
|
0
|
|
|
0
|
0
|
0
|
my($this) = @_; |
404
|
0
|
|
|
|
|
0
|
return $this->{Name}."_datap"; |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
sub do_physpointeraccess { |
408
|
0
|
|
|
0
|
0
|
0
|
my($this) = @_; |
409
|
0
|
|
|
|
|
0
|
return $this->{Name}."_physdatap"; |
410
|
|
|
|
|
|
|
} |
411
|
|
|
|
|
|
|
|
412
|
0
|
|
|
0
|
0
|
0
|
sub do_indterm { my($this,$pdl,$ind,$subst,$context) = @_; |
413
|
|
|
|
|
|
|
# Get informed |
414
|
0
|
|
|
|
|
0
|
my $indname = $this->{IndObjs}[$ind]->name; |
415
|
0
|
|
|
|
|
0
|
my $indno = $this->{IndCounts}[$ind]; |
416
|
0
|
|
|
|
|
0
|
my $indtot = $this->{IndTotCounts}[$ind]; |
417
|
|
|
|
|
|
|
# See if substitutions |
418
|
0
|
0
|
|
|
|
0
|
my $substname = ($indtot>1 ? $indname.$indno : $indname); |
419
|
0
|
0
|
|
|
|
0
|
my $incname = $indname.($indtot>1 ? $indno : ""); |
420
|
0
|
|
|
|
|
0
|
my $index; |
421
|
0
|
0
|
|
|
|
0
|
if(defined $subst->{$substname}) {$index = delete $subst->{$substname};} |
|
0
|
|
|
|
|
0
|
|
422
|
|
|
|
|
|
|
else { |
423
|
|
|
|
|
|
|
# No => get the one from the nearest context. |
424
|
0
|
|
|
|
|
0
|
for(reverse @$context) { |
425
|
0
|
0
|
|
|
|
0
|
if($_->[0] eq $indname) {$index = $_->[1]; last;} |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
} |
428
|
0
|
0
|
|
|
|
0
|
if(!defined $index) {confess "Access Index not found: $pdl, $ind, $indname |
429
|
0
|
|
|
|
|
0
|
On stack:".(join ' ',map {"($_->[0],$_->[1])"} @$context)."\n" ;} |
|
0
|
|
|
|
|
0
|
|
430
|
|
|
|
|
|
|
# return "\$PRIV(".($this->get_incname($ind))."*". $index .")"; |
431
|
|
|
|
|
|
|
# Now we have them in register variables -> no PRIV |
432
|
|
|
|
|
|
|
return ("(".($this->get_incname($ind))."*". |
433
|
0
|
|
|
|
|
0
|
"PP_INDTERM(".$this->{IndObjs}[$ind]->get_size().", $index))"); |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
# XXX hacked to create a variable containing the bad value for |
437
|
|
|
|
|
|
|
# this piddle. |
438
|
|
|
|
|
|
|
# This is a HACK (Doug Burke 07/08/00) |
439
|
|
|
|
|
|
|
# XXX |
440
|
|
|
|
|
|
|
# |
441
|
|
|
|
|
|
|
sub get_xsdatapdecl { |
442
|
4
|
|
|
4
|
0
|
10
|
my($this,$genlooptype,$asgnonly) = @_; |
443
|
4
|
|
|
|
|
6
|
my $type; |
444
|
4
|
|
|
|
|
11
|
my $pdl = $this->get_nname; |
445
|
4
|
|
|
|
|
9
|
my $flag = $this->get_nnflag; |
446
|
4
|
|
|
|
|
14
|
my $name = $this->{Name}; |
447
|
4
|
50
|
|
|
|
16
|
$type = $this->ctype($genlooptype) if defined $genlooptype; |
448
|
4
|
50
|
|
|
|
13
|
my $declini = ($asgnonly ? "" : "\t$type *"); |
449
|
4
|
50
|
|
|
|
12
|
my $cast = ($type ? "($type *)" : ""); |
450
|
|
|
|
|
|
|
# ThreadLoop does this for us. |
451
|
|
|
|
|
|
|
# return "$declini ${name}_datap = ($cast((${_})->data)) + (${_})->offs;\n"; |
452
|
|
|
|
|
|
|
|
453
|
4
|
|
|
|
|
17
|
my $str = "$declini ${name}_datap = ($cast(PDLA_REPRP_TRANS($pdl,$flag)));\n" . |
454
|
|
|
|
|
|
|
"$declini ${name}_physdatap = ($cast($pdl->data));\n"; |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
# assuming we always need this |
457
|
|
|
|
|
|
|
# - may not be true - eg if $asgnonly ?? |
458
|
|
|
|
|
|
|
# - not needed for floating point types when using NaN as bad values |
459
|
4
|
0
|
33
|
|
|
11
|
if ( $this->{BadFlag} and $type and |
|
|
|
0
|
|
|
|
|
|
|
|
33
|
|
|
|
|
460
|
|
|
|
|
|
|
( $usenan == 0 or $type !~ /^PDLA_(Float|Double)$/ ) ) { |
461
|
0
|
|
|
|
|
0
|
my $cname = $type; $cname =~ s/^PDLA_//; |
|
0
|
|
|
|
|
0
|
|
462
|
0
|
|
|
|
|
0
|
$str .= "\t$type ${name}_badval = 0;\n"; |
463
|
0
|
|
|
|
|
0
|
$str .= "\tPDLA_Anyval ${name}_anyval_badval = PDLA->get_pdl_badvalue($pdl);\n"; |
464
|
0
|
|
|
|
|
0
|
$str .= "\tANYVAL_TO_CTYPE(${name}_badval, ${type}, ${name}_anyval_badval);\n"; |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
|
467
|
4
|
|
|
|
|
355
|
return "$str\n"; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
1; |