line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
##################################################################### |
2
|
|
|
|
|
|
|
##################################################################### |
3
|
|
|
|
|
|
|
## |
4
|
|
|
|
|
|
|
## |
5
|
|
|
|
|
|
|
## Here starts the actual thing. |
6
|
|
|
|
|
|
|
## |
7
|
|
|
|
|
|
|
## This is way too messy and uncommented. Still. :( |
8
|
|
|
|
|
|
|
# |
9
|
|
|
|
|
|
|
# DJB August 24 2006 |
10
|
|
|
|
|
|
|
# begin cleaning up the code so that it all runs under use strict |
11
|
|
|
|
|
|
|
# DJB August 31 2006 |
12
|
|
|
|
|
|
|
# moved to use objects for the rule table (ie defvar) in the |
13
|
|
|
|
|
|
|
# hope it's more declarative (since the addition of "::" to |
14
|
|
|
|
|
|
|
# a statement makes it so much-more meaningful :-) |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
# How to convert from the old deftbl format to the new, object-based, |
18
|
|
|
|
|
|
|
# system: |
19
|
|
|
|
|
|
|
# |
20
|
|
|
|
|
|
|
# What used to be, in $PDL::PP::deftbl |
21
|
|
|
|
|
|
|
# [["Name1"], ["Name2"], $ref_to_sub]] |
22
|
|
|
|
|
|
|
# is now |
23
|
|
|
|
|
|
|
# PDL::PP::Rule->new("Name1", "Name2", $ref_to_sub) |
24
|
|
|
|
|
|
|
# where Name1 represents the target of the rule, Name2 the condition, |
25
|
|
|
|
|
|
|
# and the subroutine reference is the routine called when the rule is |
26
|
|
|
|
|
|
|
# applied. |
27
|
|
|
|
|
|
|
# |
28
|
|
|
|
|
|
|
# If their is no condition, the argument can be left out of the call |
29
|
|
|
|
|
|
|
# (unless there is a doc string), so |
30
|
|
|
|
|
|
|
# [["Name1"], [], $ref_to_sub]] |
31
|
|
|
|
|
|
|
# becomes |
32
|
|
|
|
|
|
|
# PDL::PP::Rule->new("Name1", $ref_to_sub) |
33
|
|
|
|
|
|
|
# |
34
|
|
|
|
|
|
|
# The target and conditions can also be an array reference, so |
35
|
|
|
|
|
|
|
# [["Name1"], ["Name2","Name3"], $ref_to_sub]] |
36
|
|
|
|
|
|
|
# [["Name1","Name2"], ["Name3"], $ref_to_sub]] |
37
|
|
|
|
|
|
|
# [["Name1","Name2"], ["Name3","Name4"], $ref_to_sub]] |
38
|
|
|
|
|
|
|
# become, respectively |
39
|
|
|
|
|
|
|
# PDL::PP::Rule->new("Name1", ["Name2","Name3"], $ref_to_sub) |
40
|
|
|
|
|
|
|
# PDL::PP::Rule->new(["Name1","Name2"], "Name3", $ref_to_sub) |
41
|
|
|
|
|
|
|
# PDL::PP::Rule->new(["Name1","Name2"], ["Name3","Name4], $ref_to_sub) |
42
|
|
|
|
|
|
|
# |
43
|
|
|
|
|
|
|
# If the old rule had a document string, this is placed between |
44
|
|
|
|
|
|
|
# the condition and the subroutine reference. To make processing |
45
|
|
|
|
|
|
|
# simpler, if a doc string exists then the condition must also |
46
|
|
|
|
|
|
|
# be supplied, even if it is just [] (ie no condition). |
47
|
|
|
|
|
|
|
# |
48
|
|
|
|
|
|
|
# There are specialized rules for common situations. The rules for the |
49
|
|
|
|
|
|
|
# target, condition, and doc arguments hold from the base class (ie |
50
|
|
|
|
|
|
|
# whether scalar or array values are used, ...) |
51
|
|
|
|
|
|
|
# |
52
|
|
|
|
|
|
|
# Return a constant: |
53
|
|
|
|
|
|
|
# |
54
|
|
|
|
|
|
|
# PDL::PP::Rule::Returns->new($targets [,$conditions [,$doc]], $value) |
55
|
|
|
|
|
|
|
# is used to return a constant. So |
56
|
|
|
|
|
|
|
# [["Name1"], [], sub { "foo" }] |
57
|
|
|
|
|
|
|
# becomes |
58
|
|
|
|
|
|
|
# PDL::PP::Rule::Returns->new("Name1", "foo") |
59
|
|
|
|
|
|
|
# |
60
|
|
|
|
|
|
|
# This class is specialized since there are some common return values: |
61
|
|
|
|
|
|
|
# PDL::PP::Rule::Returns::Zero->new($targets [,$conditions [,$doc]]) |
62
|
|
|
|
|
|
|
# PDL::PP::Rule::Returns::One->new($targets [,$conditions [,$doc]]) |
63
|
|
|
|
|
|
|
# PDL::PP::Rule::Returns::EmptyString->new($targets [,$conditions [,$doc]]) |
64
|
|
|
|
|
|
|
# PDL::PP::Rule::Returns::NULL->new($targets [,$conditions [,$doc]]) |
65
|
|
|
|
|
|
|
# which return 0, 1, "", and "NULL" respectively |
66
|
|
|
|
|
|
|
# |
67
|
|
|
|
|
|
|
# The InsertName class exists to allow you to return something like |
68
|
|
|
|
|
|
|
# "foobar" |
69
|
|
|
|
|
|
|
# The old rules |
70
|
|
|
|
|
|
|
# [["Foo"], ["Name"], sub { return "_pdl_$_[0]_bar"; }] |
71
|
|
|
|
|
|
|
# [["Foo"], ["Name","Arg2"], sub { return "_pdl_$_[0]_bar"; }] |
72
|
|
|
|
|
|
|
# become |
73
|
|
|
|
|
|
|
# PDL::PP::Rule::InsertName->new("Foo", '_pdl_${name}_bar') |
74
|
|
|
|
|
|
|
# PDL::PP::Rule::InsertName->new("Foo", "Arg2", '_pdl_${name}_bar') |
75
|
|
|
|
|
|
|
# Note that the Name argument is automatically used as a condition, so |
76
|
|
|
|
|
|
|
# it does not need to be supplied, and the return value should be |
77
|
|
|
|
|
|
|
# given as a single-quoted string and use the $name variable |
78
|
|
|
|
|
|
|
# |
79
|
|
|
|
|
|
|
# The Substitute rule replaces dollar-signed macros ($P(), $ISBAD(), etc) |
80
|
|
|
|
|
|
|
# with the low-level C code to perform the macro. |
81
|
|
|
|
|
|
|
# |
82
|
|
|
|
|
|
|
# The Substitute class replaces the dosubst rule. The old rule |
83
|
|
|
|
|
|
|
# [["NewXSCoerceMustSubs"], ["NewXSCoerceMustSub1","NewXSSymTab","Name"], |
84
|
|
|
|
|
|
|
# \&dosubst] |
85
|
|
|
|
|
|
|
# becomes |
86
|
|
|
|
|
|
|
# PDL::PP::Rule::Substitute("NewXSCoerceMustSubs", "NewXSCoerceMustSub1") |
87
|
|
|
|
|
|
|
# |
88
|
|
|
|
|
|
|
# PDL::PP::Rule::Substitute->new($target,$condition) |
89
|
|
|
|
|
|
|
# $target and $condition must be scalars. |
90
|
|
|
|
|
|
|
# |
91
|
|
|
|
|
|
|
# Implicit conditions are NewXSSymTab and Name |
92
|
|
|
|
|
|
|
# |
93
|
|
|
|
|
|
|
# The Substitute:Usual class replaces the dousualsubsts rule. The old rule |
94
|
|
|
|
|
|
|
# [["CacheBadFlagInit"], ["CacheBadFlagInitNS","NewXSSymTab","Name"], |
95
|
|
|
|
|
|
|
# \&dousualsubsts], |
96
|
|
|
|
|
|
|
# becomes |
97
|
|
|
|
|
|
|
# PDL::PP::Rule::Substitute::Usual->new("CacheBadFlagInit", "CacheBadFlagInitNS") |
98
|
|
|
|
|
|
|
# |
99
|
|
|
|
|
|
|
# PDL::PP::Rule::Substitute::Usual->new($target, $condition) |
100
|
|
|
|
|
|
|
# $target and $condition must be scalars. |
101
|
|
|
|
|
|
|
# |
102
|
|
|
|
|
|
|
# Implicit conditions are NewXSSymTab and Name |
103
|
|
|
|
|
|
|
# |
104
|
|
|
|
|
|
|
# The MakeComp rule replaces the subst_makecomp routine. The old rule |
105
|
|
|
|
|
|
|
# [["MakeCompiledRepr"], ["MakeComp","CompNames","CompObjs"], |
106
|
|
|
|
|
|
|
# sub {subst_makecomp("COMP",@_)}] |
107
|
|
|
|
|
|
|
# becomes |
108
|
|
|
|
|
|
|
# PDL::PP::Rule::MakeComp->new("MakeCompiledRepr", ["MakeComp","CompNames","CompObjs"], |
109
|
|
|
|
|
|
|
# "COMP") |
110
|
|
|
|
|
|
|
# PDL::PP::Rule::MakeComp->new($target,$conditions,$symbol) |
111
|
|
|
|
|
|
|
# $target and $symbol must be scalars. |
112
|
|
|
|
|
|
|
# |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
# Notes: |
115
|
|
|
|
|
|
|
# InsertName could become a subclass of Insert since there are |
116
|
|
|
|
|
|
|
# a few rules that just insert conditions into a text string. |
117
|
|
|
|
|
|
|
# |
118
|
|
|
|
|
|
|
# Substitute, Substitute::Usual, MakeComp classes feel a bit |
119
|
|
|
|
|
|
|
# ugly. See next point. Also the get_std_childparent method is |
120
|
|
|
|
|
|
|
# a bit of a hack. |
121
|
|
|
|
|
|
|
# |
122
|
|
|
|
|
|
|
# DJB thinks that the code fragments themselves could be objects |
123
|
|
|
|
|
|
|
# since they should 'know' what needs doing to them (eg the |
124
|
|
|
|
|
|
|
# substitutions). Not sure whether it would really clarify things. |
125
|
|
|
|
|
|
|
# |
126
|
|
|
|
|
|
|
# To do: |
127
|
|
|
|
|
|
|
# wrap_vfn could propbably be moved into a class. |
128
|
|
|
|
|
|
|
# |
129
|
|
|
|
|
|
|
# move the PDL::PP::Rule and subclasses into their own file? |
130
|
|
|
|
|
|
|
# |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
package PDL::PP::Rule; |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
use strict; |
135
|
|
|
|
|
|
|
require PDL::Core::Dev; |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
use Carp; |
138
|
|
|
|
|
|
|
our @CARP_NOT; |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
my $INVALID_OTHERPARS_RE = qr/^(?:magicno|flags|vtable|freeproc|bvalflag|has_badvalue|badvalue|pdls|__datatype)\z/; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
use overload ("\"\"" => \&PDL::PP::Rule::stringify); |
143
|
|
|
|
|
|
|
sub stringify { |
144
|
|
|
|
|
|
|
my $self = shift; |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
my $str = ref $self; |
147
|
|
|
|
|
|
|
if ("PDL::PP::Rule" eq $str) { |
148
|
|
|
|
|
|
|
$str = "Rule"; |
149
|
|
|
|
|
|
|
} else { |
150
|
|
|
|
|
|
|
$str =~ s/PDL::PP::Rule:://; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
$str = "($str) "; |
153
|
|
|
|
|
|
|
$str .= exists $self->{doc} ? |
154
|
|
|
|
|
|
|
$self->{doc} : join(",", @{$self->{targets}}); |
155
|
|
|
|
|
|
|
return $str; |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
# Takes two args: the calling object and the message, but we only care |
159
|
|
|
|
|
|
|
# about the message: |
160
|
|
|
|
|
|
|
sub report ($$) { print $_[1] if $::PP_VERBOSE; } |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# Very limited error checking. |
163
|
|
|
|
|
|
|
# Allow scalars for targets and conditions to be optional |
164
|
|
|
|
|
|
|
# |
165
|
|
|
|
|
|
|
# At present you have to have a conditions argument if you supply |
166
|
|
|
|
|
|
|
# a doc string |
167
|
|
|
|
|
|
|
# |
168
|
|
|
|
|
|
|
# It seems strange to make the subroutine reference an optional |
169
|
|
|
|
|
|
|
# argument but this is being used to transition to a slightly-different |
170
|
|
|
|
|
|
|
# object design |
171
|
|
|
|
|
|
|
# |
172
|
|
|
|
|
|
|
sub new { |
173
|
|
|
|
|
|
|
my $class = shift; |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
my $self = {}; |
176
|
|
|
|
|
|
|
bless $self, $class; |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
my $usage = "Usage: PDL::PP::Rule->new(\$targets[,\$conditions[,\$doc],] [,\$ref])\n"; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
# handle arguments |
181
|
|
|
|
|
|
|
my $nargs = $#_; |
182
|
|
|
|
|
|
|
die $usage if $nargs < 0 or $nargs > 3; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
my $targets = shift; |
185
|
|
|
|
|
|
|
$targets = [$targets] unless ref $targets eq "ARRAY"; |
186
|
|
|
|
|
|
|
$self->{targets} = $targets; |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
if ($#_ != -1) { |
189
|
|
|
|
|
|
|
if (ref $_[-1] eq "CODE") { |
190
|
|
|
|
|
|
|
$self->{ref} = pop; |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
my ($conditions,$doc) = @_; |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
if (defined $conditions) { |
196
|
|
|
|
|
|
|
$conditions = [$conditions] unless ref $conditions eq "ARRAY"; |
197
|
|
|
|
|
|
|
} else { |
198
|
|
|
|
|
|
|
$conditions = []; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
$self->{conditions} = $conditions; |
201
|
|
|
|
|
|
|
$self->{doc} = $doc if defined $doc; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
return $self; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
# $rule->check_if_targets_exist($pars); |
208
|
|
|
|
|
|
|
# |
209
|
|
|
|
|
|
|
# Returns 1 if any of the targets exist in $pars, 0 otherwise. |
210
|
|
|
|
|
|
|
# A return value of 1 means that the rule should not be applied. |
211
|
|
|
|
|
|
|
# |
212
|
|
|
|
|
|
|
# Not 100% happy with use of report here. Needs re-thinking. |
213
|
|
|
|
|
|
|
# |
214
|
|
|
|
|
|
|
sub check_if_targets_exist { |
215
|
|
|
|
|
|
|
my $self = shift; |
216
|
|
|
|
|
|
|
my $pars = shift; |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
my $targets = $self->{targets}; |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
foreach my $target (@$targets) { |
221
|
|
|
|
|
|
|
if (exists $pars->{$target}) { |
222
|
|
|
|
|
|
|
$self->report("--skipping since TARGET $target exists\n"); |
223
|
|
|
|
|
|
|
return 1; |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
return 0; |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
# $rule->check_if_conditions_exist($pars); |
230
|
|
|
|
|
|
|
# |
231
|
|
|
|
|
|
|
# Returns 1 if all of the required conditions exist in $pars, 0 otherwise. |
232
|
|
|
|
|
|
|
# A return value of 0 means that the rule should not be applied. |
233
|
|
|
|
|
|
|
# |
234
|
|
|
|
|
|
|
# Not 100% happy with use of report here. Needs re-thinking. |
235
|
|
|
|
|
|
|
# |
236
|
|
|
|
|
|
|
sub check_if_conditions_exist { |
237
|
|
|
|
|
|
|
my $self = shift; |
238
|
|
|
|
|
|
|
my $pars = shift; |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
my $conditions = $self->{conditions}; |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
foreach my $condition (@$conditions) { |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
# skip if not a required condition |
245
|
|
|
|
|
|
|
next if substr($condition,0,1) eq "_"; |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
unless (exists $pars->{$condition}) { |
248
|
|
|
|
|
|
|
$self->report("--skipping since CONDITION $condition does not exist\n"); |
249
|
|
|
|
|
|
|
return 0; |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
return 1; |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# $rule->is_valid($pars); |
257
|
|
|
|
|
|
|
# |
258
|
|
|
|
|
|
|
# Returns 1 if the rule should be applied (ie no targets already |
259
|
|
|
|
|
|
|
# exist in $pars and all the required conditions exist in $pars), |
260
|
|
|
|
|
|
|
# otherwise 0. |
261
|
|
|
|
|
|
|
# |
262
|
|
|
|
|
|
|
sub is_valid { |
263
|
|
|
|
|
|
|
my $self = shift; |
264
|
|
|
|
|
|
|
my $pars = shift; |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
return 0 if $self->check_if_targets_exist($pars); |
267
|
|
|
|
|
|
|
return 0 unless $self->check_if_conditions_exist($pars); |
268
|
|
|
|
|
|
|
return 1; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# my @args = $self->extract_args($pars); |
272
|
|
|
|
|
|
|
# |
273
|
|
|
|
|
|
|
# If this method is called we assume that |
274
|
|
|
|
|
|
|
# $self->check_if_conditions_exist($pars) |
275
|
|
|
|
|
|
|
# returns 1. |
276
|
|
|
|
|
|
|
# |
277
|
|
|
|
|
|
|
sub extract_args { |
278
|
|
|
|
|
|
|
my $self = shift; |
279
|
|
|
|
|
|
|
my $pars = shift; |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
my $conditions = $self->{conditions}; |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
my @args; |
284
|
|
|
|
|
|
|
foreach (@$conditions) { |
285
|
|
|
|
|
|
|
# make a copy of each condition so that any changes to it are not |
286
|
|
|
|
|
|
|
# also made to the original array! |
287
|
|
|
|
|
|
|
my $condition = $_; |
288
|
|
|
|
|
|
|
# Remove any possible underscores (which indicate optional conditions): |
289
|
|
|
|
|
|
|
$condition =~ s/^_//; |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
# Note: This will *not* create $pars->{$condition} if it did not already |
292
|
|
|
|
|
|
|
# exist: |
293
|
|
|
|
|
|
|
push @args, $pars->{$condition}; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
return @args; |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
# Apply the rule using the supplied $pars hash reference. |
300
|
|
|
|
|
|
|
# |
301
|
|
|
|
|
|
|
sub apply { |
302
|
|
|
|
|
|
|
my $self = shift; |
303
|
|
|
|
|
|
|
my $pars = shift; |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
carp "Unable to apply rule $self as there is no subroutine reference!" |
306
|
|
|
|
|
|
|
unless exists $self->{ref}; |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
my $targets = $self->{targets}; |
309
|
|
|
|
|
|
|
my $conditions = $self->{conditions}; |
310
|
|
|
|
|
|
|
my $ref = $self->{ref}; |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
$self->report("Applying: $self\n"); |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
# Is the rule valid? |
315
|
|
|
|
|
|
|
# |
316
|
|
|
|
|
|
|
return unless $self->is_valid($pars); |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# Create the argument array for the routine. |
319
|
|
|
|
|
|
|
# |
320
|
|
|
|
|
|
|
my @args = $self->extract_args($pars); |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
# Run this rule's subroutine: |
323
|
|
|
|
|
|
|
my @retval = $self->{ref}(@args); |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
# Check for any inconsistencies: |
326
|
|
|
|
|
|
|
confess "Internal error: rule '$self' returned " . (1+$#retval) |
327
|
|
|
|
|
|
|
. " items and expected " . (1+$#$targets) |
328
|
|
|
|
|
|
|
unless $#retval == $#$targets; |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
$self->report("--setting:"); |
331
|
|
|
|
|
|
|
foreach my $target (@$targets) { |
332
|
|
|
|
|
|
|
$self->report(" $target"); |
333
|
|
|
|
|
|
|
confess "Cannot have multiple meanings for target $target!" |
334
|
|
|
|
|
|
|
if exists $pars->{$target}; |
335
|
|
|
|
|
|
|
my $result = shift @retval; |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
# The following test suggests that things could/should be |
338
|
|
|
|
|
|
|
# improved in the code generation. |
339
|
|
|
|
|
|
|
# |
340
|
|
|
|
|
|
|
if (defined $result and $result eq 'DO NOT SET!!') { |
341
|
|
|
|
|
|
|
$self->report (" is 'DO NOT SET!!'"); |
342
|
|
|
|
|
|
|
} else { |
343
|
|
|
|
|
|
|
$pars->{$target} = $result; |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
$self->report("\n"); |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
package PDL::PP::Rule::Croak; |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
# Croaks if all of the input variables are defined. Use this to identify |
353
|
|
|
|
|
|
|
# incompatible arguments. |
354
|
|
|
|
|
|
|
our @ISA = qw(PDL::PP::Rule); |
355
|
|
|
|
|
|
|
use Carp; |
356
|
|
|
|
|
|
|
our @CARP_NOT; |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
sub new { |
360
|
|
|
|
|
|
|
croak('Usage: PDL::PP::Ruel::Croak->new(["incompatible", "arguments"], "Croaking message")') |
361
|
|
|
|
|
|
|
unless @_ == 3; |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
my $class = shift; |
364
|
|
|
|
|
|
|
my $self = $class->SUPER::new([], @_); |
365
|
|
|
|
|
|
|
return bless $self, $class; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
sub apply { |
369
|
|
|
|
|
|
|
my ($self, $pars) = @_; |
370
|
|
|
|
|
|
|
croak($self->{doc}) if $self->is_valid($pars); |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
package PDL::PP::Rule::Returns; |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
use strict; |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
use Carp; |
378
|
|
|
|
|
|
|
our @CARP_NOT; |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
##use PDL::PP::Rule; |
381
|
|
|
|
|
|
|
our @ISA = qw (PDL::PP::Rule); |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
# This class does not treat return values of "DO NOT SET!!" |
384
|
|
|
|
|
|
|
# as special. |
385
|
|
|
|
|
|
|
# |
386
|
|
|
|
|
|
|
sub new { |
387
|
|
|
|
|
|
|
my $class = shift; |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
my $value = pop; |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
my @args = @_; |
392
|
|
|
|
|
|
|
my $self = $class->SUPER::new(@args); |
393
|
|
|
|
|
|
|
bless $self, $class; |
394
|
|
|
|
|
|
|
$self->{"returns.value"} = $value; |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
my $targets = $self->{targets}; |
397
|
|
|
|
|
|
|
croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!" |
398
|
|
|
|
|
|
|
unless $#$targets == 0; |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
return $self; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
sub apply { |
404
|
|
|
|
|
|
|
my $self = shift; |
405
|
|
|
|
|
|
|
my $pars = shift; |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
carp "Unable to apply rule $self as there is no return value!" |
408
|
|
|
|
|
|
|
unless exists $self->{"returns.value"}; |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
my $target = $self->{targets}->[0]; |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
$self->report("Applying: $self\n"); |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
# Is the rule valid? |
415
|
|
|
|
|
|
|
# |
416
|
|
|
|
|
|
|
return unless $self->is_valid($pars); |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
# Set the value |
419
|
|
|
|
|
|
|
# |
420
|
|
|
|
|
|
|
$self->report ("--setting: $target\n"); |
421
|
|
|
|
|
|
|
$pars->{$target} = $self->{"returns.value"}; |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
package PDL::PP::Rule::Returns::Zero; |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
use strict; |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
##use PDL::PP::Rule::Returns; |
429
|
|
|
|
|
|
|
our @ISA = qw (PDL::PP::Rule::Returns); |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
sub new { |
432
|
|
|
|
|
|
|
my $class = shift; |
433
|
|
|
|
|
|
|
my @args = @_; |
434
|
|
|
|
|
|
|
my $self = $class->SUPER::new(@args,0); |
435
|
|
|
|
|
|
|
bless $self, $class; |
436
|
|
|
|
|
|
|
return $self; |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
package PDL::PP::Rule::Returns::One; |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
use strict; |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
##use PDL::PP::Rule::Returns; |
444
|
|
|
|
|
|
|
our @ISA = qw (PDL::PP::Rule::Returns); |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
sub new { |
447
|
|
|
|
|
|
|
my $class = shift; |
448
|
|
|
|
|
|
|
my @args = @_; |
449
|
|
|
|
|
|
|
my $self = $class->SUPER::new(@args,1); |
450
|
|
|
|
|
|
|
bless $self, $class; |
451
|
|
|
|
|
|
|
return $self; |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
package PDL::PP::Rule::Returns::EmptyString; |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
use strict; |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
##use PDL::PP::Rule::Returns; |
459
|
|
|
|
|
|
|
our @ISA = qw (PDL::PP::Rule::Returns); |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
sub new { |
462
|
|
|
|
|
|
|
my $class = shift; |
463
|
|
|
|
|
|
|
my @args = @_; |
464
|
|
|
|
|
|
|
my $self = $class->SUPER::new(@args,""); |
465
|
|
|
|
|
|
|
bless $self, $class; |
466
|
|
|
|
|
|
|
return $self; |
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
package PDL::PP::Rule::Returns::NULL; |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
use strict; |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
##use PDL::PP::Rule::Returns; |
474
|
|
|
|
|
|
|
our @ISA = qw (PDL::PP::Rule::Returns); |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
sub new { |
477
|
|
|
|
|
|
|
my $class = shift; |
478
|
|
|
|
|
|
|
my @args = @_; |
479
|
|
|
|
|
|
|
my $self = $class->SUPER::new(@args,"NULL"); |
480
|
|
|
|
|
|
|
bless $self, $class; |
481
|
|
|
|
|
|
|
return $self; |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
package PDL::PP::Rule::InsertName; |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
use strict; |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
use Carp; |
489
|
|
|
|
|
|
|
our @CARP_NOT; |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
##use PDL::PP::Rule; |
492
|
|
|
|
|
|
|
our @ISA = qw (PDL::PP::Rule); |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
# This class does not treat return values of "DO NOT SET!!" |
495
|
|
|
|
|
|
|
# as special. |
496
|
|
|
|
|
|
|
# |
497
|
|
|
|
|
|
|
sub new { |
498
|
|
|
|
|
|
|
my $class = shift; |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
my $value = pop; |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
my @args = @_; |
503
|
|
|
|
|
|
|
my $self = $class->SUPER::new(@args); |
504
|
|
|
|
|
|
|
bless $self, $class; |
505
|
|
|
|
|
|
|
$self->{"insertname.value"} = $value; |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
# Generate a defaul doc string |
508
|
|
|
|
|
|
|
unless (exists $self->{doc}) { |
509
|
|
|
|
|
|
|
$self->{doc} = 'Sets ' . $self->{targets}->[0] |
510
|
|
|
|
|
|
|
. ' to "' . $value . '"'; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
my $targets = $self->{targets}; |
514
|
|
|
|
|
|
|
croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!" |
515
|
|
|
|
|
|
|
unless $#$targets == 0; |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
# we add "Name" as the first condition |
518
|
|
|
|
|
|
|
# |
519
|
|
|
|
|
|
|
my $conditions = $self->{conditions}; |
520
|
|
|
|
|
|
|
unshift @$conditions, "Name"; |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
return $self; |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
sub apply { |
526
|
|
|
|
|
|
|
my $self = shift; |
527
|
|
|
|
|
|
|
my $pars = shift; |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
carp "Unable to apply rule $self as there is no return value!" |
530
|
|
|
|
|
|
|
unless exists $self->{"insertname.value"}; |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
$self->report("Applying: $self\n"); |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
# Is the rule valid? |
535
|
|
|
|
|
|
|
# |
536
|
|
|
|
|
|
|
return unless $self->is_valid($pars); |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
# Set the value |
539
|
|
|
|
|
|
|
# |
540
|
|
|
|
|
|
|
my $target = $self->{targets}->[0]; |
541
|
|
|
|
|
|
|
my $name = $pars->{Name}; |
542
|
|
|
|
|
|
|
$self->report ("--setting: $target (name=$name)\n"); |
543
|
|
|
|
|
|
|
$pars->{$target} = eval "return \"" . $self->{"insertname.value"} . "\";"; |
544
|
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
# Poor name. This is the old "dosubst" routine |
547
|
|
|
|
|
|
|
# |
548
|
|
|
|
|
|
|
# PDL::PP::Rule->new("NewXSCoerceMustSubs", ["NewXSCoerceMustSub1","NewXSSymTab","Name"], |
549
|
|
|
|
|
|
|
# \&dosubst), |
550
|
|
|
|
|
|
|
# |
551
|
|
|
|
|
|
|
# PDL::PP::Rule::Substitute->new($target,$condition) |
552
|
|
|
|
|
|
|
# $target and $condition must be scalars. |
553
|
|
|
|
|
|
|
# |
554
|
|
|
|
|
|
|
# Implicit conditions are NewXSSymTab and Name |
555
|
|
|
|
|
|
|
# |
556
|
|
|
|
|
|
|
package PDL::PP::Rule::Substitute; |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
use strict; |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
use Carp; |
561
|
|
|
|
|
|
|
our @CARP_NOT; |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
##use PDL::PP::Rule; |
564
|
|
|
|
|
|
|
our @ISA = qw (PDL::PP::Rule); |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
# Probably want this directly in the apply routine but leave as is for now |
567
|
|
|
|
|
|
|
# |
568
|
|
|
|
|
|
|
sub dosubst_private { |
569
|
|
|
|
|
|
|
my ($src,$symtab,$name) = @_; |
570
|
|
|
|
|
|
|
my $ret = (ref $src ? $src->[0] : $src); |
571
|
|
|
|
|
|
|
my %syms = ( |
572
|
|
|
|
|
|
|
((ref $src) ? %{$src->[1]} : ()), |
573
|
|
|
|
|
|
|
PRIV => sub {return "".$symtab->get_symname('_PDL_ThisTrans'). |
574
|
|
|
|
|
|
|
"->$_[0]"}, |
575
|
|
|
|
|
|
|
CROAK => sub {PDL::PP::pp_line_numbers(__LINE__, "PDL->pdl_barf(\"Error in $name:\" $_[0])")}, |
576
|
84
|
|
|
|
|
|
NAME => sub {return $name}, |
577
|
|
|
|
|
|
|
MODULE => sub {return $::PDLMOD}, |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
SETPDLSTATEBAD => sub { PDL::PP::pp_line_numbers(__LINE__, "$_[0]\->state |= PDL_BADVAL") }, |
580
|
2
|
0
|
|
|
|
|
SETPDLSTATEGOOD => sub { PDL::PP::pp_line_numbers(__LINE__, "$_[0]\->state &= ~PDL_BADVAL") }, |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
581
|
2
|
|
|
|
|
|
ISPDLSTATEBAD => sub { PDL::PP::pp_line_numbers(__LINE__, "(($_[0]\->state & PDL_BADVAL) > 0)") }, |
582
|
0
|
0
|
|
|
|
|
ISPDLSTATEGOOD => sub { PDL::PP::pp_line_numbers(__LINE__, "(($_[0]\->state & PDL_BADVAL) == 0)") }, |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
583
|
93
|
50
|
|
|
|
|
BADFLAGCACHE => sub { PDL::PP::pp_line_numbers(__LINE__, "badflag_cache") }, |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
584
|
55
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
585
|
55
|
|
|
|
|
|
SETREVERSIBLE => sub { |
586
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, "if($_[0]) \$PRIV(flags) |= PDL_ITRANS_REVERSIBLE;\n" . |
587
|
0
|
|
|
|
|
|
" else \$PRIV(flags) &= ~PDL_ITRANS_REVERSIBLE;\n") |
588
|
|
|
|
|
|
|
}, |
589
|
|
|
|
|
|
|
); |
590
|
|
|
|
|
|
|
while( |
591
|
|
|
|
|
|
|
$ret =~ s/\$(\w+)\(([^()]*)\)/ |
592
|
|
|
|
|
|
|
(defined $syms{$1} or |
593
|
|
|
|
|
|
|
confess("$1 not defined in '$ret'!")) and |
594
|
|
|
|
|
|
|
(&{$syms{$1}}($2))/ge |
595
|
|
|
|
|
|
|
) {}; |
596
|
|
|
|
|
|
|
$ret; |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
sub new { |
600
|
|
|
|
|
|
|
my $class = shift; |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
die "Usage: PDL::PP::Rule::Substitute->new(\$target,\$condition);" |
603
|
|
|
|
|
|
|
unless $#_ == 1; |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
my $target = shift; |
606
|
|
|
|
|
|
|
my $condition = shift; |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
die "\$target must be a scalar for PDL::PP::Rule->Substitute" if ref $target; |
609
|
|
|
|
|
|
|
die "\$condition must be a scalar for PDL::PP::Rule->Substitute" if ref $condition; |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
my $self = $class->SUPER::new($target, [$condition, "NewXSSymTab", "Name"], |
612
|
|
|
|
|
|
|
\&dosubst_private); |
613
|
|
|
|
|
|
|
bless $self, $class; |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
return $self; |
616
|
|
|
|
|
|
|
} |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
# Poor name. This is the old "dousualsubsts" routine |
619
|
|
|
|
|
|
|
# |
620
|
|
|
|
|
|
|
# PDL::PP::Rule->new("CacheBadFlagInit", ["CacheBadFlagInitNS","NewXSSymTab","Name"], |
621
|
|
|
|
|
|
|
# \&dousualsubsts), |
622
|
|
|
|
|
|
|
# |
623
|
|
|
|
|
|
|
# PDL::PP::Rule::Substitute::Usual->new($target, $condition) |
624
|
|
|
|
|
|
|
# $target and $condition must be scalars. |
625
|
|
|
|
|
|
|
# |
626
|
|
|
|
|
|
|
# Implicit conditions are NewXSSymTab and Name |
627
|
|
|
|
|
|
|
# |
628
|
|
|
|
|
|
|
# Need to think about @std_childparent as it is also used by |
629
|
|
|
|
|
|
|
# other bits of code. At the moment provide a class method |
630
|
|
|
|
|
|
|
# to access the array but there has to be better ways of |
631
|
|
|
|
|
|
|
# doing this. |
632
|
|
|
|
|
|
|
# |
633
|
|
|
|
|
|
|
package PDL::PP::Rule::Substitute::Usual; |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
use strict; |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
use Carp; |
638
|
|
|
|
|
|
|
our @CARP_NOT; |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
##use PDL::PP::Rule; |
641
|
|
|
|
|
|
|
our @ISA = qw (PDL::PP::Rule::Substitute); |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
# This is a copy of the main one for now. Need a better solution. |
644
|
|
|
|
|
|
|
# |
645
|
|
|
|
|
|
|
my @std_childparent = ( |
646
|
|
|
|
|
|
|
CHILD => sub {PDL::PP::pp_line_numbers(__LINE__, '$PRIV(pdls[1]->'.(join ',',@_).")")}, |
647
|
|
|
|
|
|
|
PARENT => sub {PDL::PP::pp_line_numbers(__LINE__, '$PRIV(pdls[0]->'.(join ',',@_).")")}, |
648
|
|
|
|
|
|
|
CHILD_P => sub {PDL::PP::pp_line_numbers(__LINE__, '$PRIV(pdls[1]->'.(join ',',@_).")")}, |
649
|
|
|
|
|
|
|
PARENT_P => sub {PDL::PP::pp_line_numbers(__LINE__, '$PRIV(pdls[0]->'.(join ',',@_).")")}, |
650
|
|
|
|
|
|
|
CHILD_PTR => sub {PDL::PP::pp_line_numbers(__LINE__, '$PRIV(pdls[1])')}, |
651
|
|
|
|
|
|
|
PARENT_PTR => sub {PDL::PP::pp_line_numbers(__LINE__, '$PRIV(pdls[0])')}, |
652
|
|
|
|
|
|
|
COMP => sub {PDL::PP::pp_line_numbers(__LINE__, '$PRIV('.(join ',',@_).")")} |
653
|
|
|
|
|
|
|
); |
654
|
|
|
|
|
|
|
|
655
|
0
|
0
|
|
|
|
|
sub get_std_childparent { return @std_childparent; } |
|
|
0
|
|
|
|
|
|
656
|
0
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
sub new { |
658
|
|
|
|
|
|
|
my $class = shift; |
659
|
0
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
my @args = @_; |
661
|
|
|
|
|
|
|
my $self = $class->SUPER::new(@args); |
662
|
|
|
|
|
|
|
bless $self, $class; |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
return $self; |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
# We modify the arguments from the conditions to include the |
668
|
|
|
|
|
|
|
# extra information |
669
|
|
|
|
|
|
|
# |
670
|
|
|
|
|
|
|
# We simplify the base-class version since we assume that all |
671
|
|
|
|
|
|
|
# conditions are required here. |
672
|
|
|
|
|
|
|
# |
673
|
|
|
|
|
|
|
sub extract_args { |
674
|
|
|
|
|
|
|
my $self = shift; |
675
|
|
|
|
|
|
|
my $pars = shift; |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
# The conditions are [, NewXSSymTab, Name] |
678
|
|
|
|
|
|
|
# |
679
|
|
|
|
|
|
|
my $code = $pars->{$self->{conditions}[0]}; |
680
|
|
|
|
|
|
|
my $symtab = $pars->{$self->{conditions}[1]}; |
681
|
|
|
|
|
|
|
my $name = $pars->{$self->{conditions}[2]}; |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
return ([$code,{@std_childparent}],$symtab,$name); |
684
|
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
# Poor name. This is the old "subst_makecomp" routine |
687
|
|
|
|
|
|
|
# |
688
|
|
|
|
|
|
|
# PDL::PP::Rule->new("MakeCompiledRepr", ["MakeComp","CompNames","CompObjs"], |
689
|
|
|
|
|
|
|
# sub {subst_makecomp("COMP",@_)}), |
690
|
|
|
|
|
|
|
# |
691
|
|
|
|
|
|
|
# PDL::PP::Rule::MakeComp->new($target,$conditions,$symbol) |
692
|
|
|
|
|
|
|
# $target and $symbol must be scalars. |
693
|
|
|
|
|
|
|
# |
694
|
|
|
|
|
|
|
package PDL::PP::Rule::MakeComp; |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
use strict; |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
use Carp; |
699
|
|
|
|
|
|
|
our @CARP_NOT; |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
##use PDL::PP::Rule; |
702
|
|
|
|
|
|
|
our @ISA = qw (PDL::PP::Rule); |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
# This is a copy of the main one for now. Need a better solution. |
705
|
|
|
|
|
|
|
# |
706
|
|
|
|
|
|
|
my @std_redodims = ( |
707
|
|
|
|
|
|
|
SETNDIMS => sub {PDL::PP::pp_line_numbers(__LINE__, "PDL->reallocdims(__it,$_[0])")}, |
708
|
|
|
|
|
|
|
SETDIMS => sub {PDL::PP::pp_line_numbers(__LINE__, "PDL->setdims_careful(__it)")}, |
709
|
|
|
|
|
|
|
SETDELTATHREADIDS => sub {PDL::PP::pp_line_numbers(__LINE__, ' |
710
|
|
|
|
|
|
|
{int __ind; PDL->reallocthreadids($CHILD_PTR(), |
711
|
|
|
|
|
|
|
$PARENT(nthreadids)); |
712
|
|
|
|
|
|
|
for(__ind=0; __ind<$PARENT(nthreadids)+1; __ind++) { |
713
|
|
|
|
|
|
|
$CHILD(threadids[__ind]) = |
714
|
|
|
|
|
|
|
$PARENT(threadids[__ind]) + ('.$_[0].'); |
715
|
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
|
')}); |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
##sub get_std_redodims { return @std_redodims; } |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
# Probably want this directly in the apply routine but leave as is for now |
722
|
|
|
|
|
|
|
# |
723
|
|
|
|
|
|
|
sub subst_makecomp_private { |
724
|
|
|
|
|
|
|
my($which,$mc,$cn,$co) = @_; |
725
|
|
|
|
|
|
|
return [$mc,{ |
726
|
|
|
|
|
|
|
# @::std_childparent, |
727
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual::get_std_childparent(), |
728
|
|
|
|
|
|
|
($cn ? |
729
|
|
|
|
|
|
|
(('DO'.$which.'DIMS') => sub {PDL::PP::pp_line_numbers(__LINE__, join '', |
730
|
|
|
|
|
|
|
map{$$co{$_}->need_malloc ? |
731
|
|
|
|
|
|
|
$$co{$_}->get_malloc('$PRIV('.$_.')') : |
732
|
|
|
|
|
|
|
()} @$cn)}) : |
733
|
|
|
|
|
|
|
() |
734
|
|
|
|
|
|
|
), |
735
|
|
|
|
|
|
|
($which eq "PRIV" ? |
736
|
|
|
|
|
|
|
@std_redodims : ()), |
737
|
|
|
|
|
|
|
}, |
738
|
|
|
|
|
|
|
]; |
739
|
|
|
|
|
|
|
} |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
sub new { |
742
|
|
|
|
|
|
|
my $class = shift; |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
die "Usage: PDL::PP::Rule::MakeComp->new(\$target,\$conditions,\$symbol);" |
745
|
|
|
|
|
|
|
unless $#_ == 2; |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
my $target = shift; |
748
|
|
|
|
|
|
|
my $condition = shift; |
749
|
|
|
|
|
|
|
my $symbol = shift; |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
die "\$target must be a scalar for PDL::PP::Rule->MakeComp" if ref $target; |
752
|
|
|
|
|
|
|
die "\$symbol must be a scalar for PDL::PP::Rule->MakeComp" if ref $symbol; |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
my $self = $class->SUPER::new($target, $condition, |
755
|
|
|
|
|
|
|
\&subst_makecomp_private); |
756
|
|
|
|
|
|
|
bless $self, $class; |
757
|
|
|
|
|
|
|
$self->{"makecomp.value"} = $symbol; |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
return $self; |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
# We modify the arguments from the conditions to include the |
763
|
|
|
|
|
|
|
# extra information |
764
|
|
|
|
|
|
|
# |
765
|
|
|
|
|
|
|
# We simplify the base-class version since we assume that all |
766
|
|
|
|
|
|
|
# conditions are required here. |
767
|
|
|
|
|
|
|
# |
768
|
|
|
|
|
|
|
sub extract_args { |
769
|
|
|
|
|
|
|
my $self = shift; |
770
|
|
|
|
|
|
|
my $pars = shift; |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
# The conditions are [, conditions...] |
773
|
|
|
|
|
|
|
# - could use slicing here |
774
|
|
|
|
|
|
|
# |
775
|
|
|
|
|
|
|
my @args = ($self->{"makecomp.value"}); |
776
|
|
|
|
|
|
|
foreach my $condition (@{$self->{conditions}}) { |
777
|
|
|
|
|
|
|
push @args, $pars->{$condition}; |
778
|
|
|
|
|
|
|
} |
779
|
|
|
|
|
|
|
return @args; |
780
|
|
|
|
|
|
|
} |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
package PDL::PP; |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
use strict; |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
our $VERSION = "2.3"; |
787
|
|
|
|
|
|
|
$VERSION = eval $VERSION; |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
use PDL::Types ':All'; |
790
|
|
|
|
|
|
|
use Config; |
791
|
|
|
|
|
|
|
use FileHandle; |
792
|
|
|
|
|
|
|
use Exporter; |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
use Data::Dumper; |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
@PDL::PP::EXPORT = qw/pp_addhdr pp_addpm pp_bless pp_def pp_done pp_add_boot |
799
|
|
|
|
|
|
|
pp_add_exported pp_addxs pp_add_isa pp_export_nothing |
800
|
|
|
|
|
|
|
pp_core_importList pp_beginwrap pp_setversion |
801
|
|
|
|
|
|
|
pp_addbegin pp_boundscheck pp_line_numbers |
802
|
|
|
|
|
|
|
pp_deprecate_module/; |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
$PP::boundscheck = 1; |
805
|
|
|
|
|
|
|
$::PP_VERBOSE = 0; |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
$PDL::PP::done = 0; # pp_done has not been called yet |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
END { |
810
|
|
|
|
|
|
|
#you can uncomment this for testing, but this should remain |
811
|
|
|
|
|
|
|
#commented in production code. This causes pp_done to be called |
812
|
|
|
|
|
|
|
#even when a .pd file aborts with die(), potentially bypassing |
813
|
|
|
|
|
|
|
#problem code when build is re-attempted. Having this commented |
814
|
|
|
|
|
|
|
#means we are a bit more strict: a module must call pp_done in |
815
|
|
|
|
|
|
|
#order to have .xs and .pm files written. |
816
|
|
|
|
|
|
|
# pp_done() unless $PDL::PP::done; |
817
|
|
|
|
|
|
|
} |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
use Carp; |
820
|
|
|
|
|
|
|
our @CARP_NOT; |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
# check for bad value support |
823
|
|
|
|
|
|
|
use PDL::Config; |
824
|
|
|
|
|
|
|
my $bvalflag = $PDL::Config{WITH_BADVAL} || 0; |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
my $ntypes = $#PDL::Types::names; |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
sub nopm { $::PDLPACK eq 'NONE' } # flag that we don't want to generate a PM |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
sub import { |
831
|
|
|
|
|
|
|
my ($mod,$modname, $packname, $prefix, $callpack) = @_; |
832
|
|
|
|
|
|
|
# Allow for users to not specify the packname |
833
|
|
|
|
|
|
|
($packname, $prefix, $callpack) = ($modname, $packname, $prefix) |
834
|
|
|
|
|
|
|
if ($packname =~ m|/|); |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
$::PDLMOD=$modname; $::PDLPACK=$packname; $::PDLPREF=$prefix; |
837
|
|
|
|
|
|
|
$::CALLPACK = defined $callpack ? $callpack : $::PDLMOD; |
838
|
|
|
|
|
|
|
$::PDLOBJ = "PDL"; # define pp-funcs in this package |
839
|
|
|
|
|
|
|
$::PDLXS=""; |
840
|
|
|
|
|
|
|
$::PDLBEGIN=""; |
841
|
|
|
|
|
|
|
$::PDLPMROUT=""; |
842
|
|
|
|
|
|
|
for ('Top','Bot','Middle') { $::PDLPM{$_}="" } |
843
|
|
|
|
|
|
|
@::PDLPMISA=('PDL::Exporter', 'DynaLoader'); |
844
|
|
|
|
|
|
|
@::PDL_IFBEGINWRAP = ('',''); |
845
|
|
|
|
|
|
|
$::PDLVERSIONSET = ''; |
846
|
|
|
|
|
|
|
$::PDLMODVERSION = undef; |
847
|
|
|
|
|
|
|
$::DOCUMENTED = 0; |
848
|
|
|
|
|
|
|
$::PDLCOREIMPORT = ""; #import list from core, defaults to everything, i.e. use Core |
849
|
|
|
|
|
|
|
# could be set to () for importing nothing from core. or qw/ barf / for |
850
|
|
|
|
|
|
|
# importing barf only. |
851
|
|
|
|
|
|
|
@_=("PDL::PP"); |
852
|
|
|
|
|
|
|
goto &Exporter::import; |
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
# query/set boundschecking |
857
|
|
|
|
|
|
|
# if on the generated XS code will have optional boundschecking |
858
|
|
|
|
|
|
|
# that can be turned on/off at runtime(!) using |
859
|
|
|
|
|
|
|
# __PACKAGE__::set_boundscheck(arg); # arg should be 0/1 |
860
|
|
|
|
|
|
|
# if off code is speed optimized and no runtime boundschecking |
861
|
|
|
|
|
|
|
# can be performed |
862
|
|
|
|
|
|
|
# ON by default |
863
|
|
|
|
|
|
|
sub pp_boundscheck { |
864
|
|
|
|
|
|
|
my $ret = $PP::boundscheck; |
865
|
|
|
|
|
|
|
$PP::boundscheck = $_[0] if $#_ > -1; |
866
|
|
|
|
|
|
|
return $ret; |
867
|
|
|
|
|
|
|
} |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
sub pp_beginwrap { |
870
|
|
|
|
|
|
|
@::PDL_IFBEGINWRAP = ('BEGIN {','}'); |
871
|
|
|
|
|
|
|
} |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
sub pp_setversion { |
874
|
|
|
|
|
|
|
my ($ver) = @_; |
875
|
|
|
|
|
|
|
$::PDLMODVERSION = '$VERSION'; |
876
|
|
|
|
|
|
|
$::PDLVERSIONSET = "\$$::PDLPACK\::VERSION = $ver;"; |
877
|
|
|
|
|
|
|
} |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
sub pp_addhdr { |
880
|
|
|
|
|
|
|
my ($hdr) = @_; |
881
|
|
|
|
|
|
|
$::PDLXSC .= $hdr; |
882
|
|
|
|
|
|
|
} |
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
sub pp_addpm { |
885
|
|
|
|
|
|
|
my $pm = shift; |
886
|
|
|
|
|
|
|
my $pos; |
887
|
|
|
|
|
|
|
if (ref $pm) { |
888
|
|
|
|
|
|
|
my $opt = $pm; |
889
|
|
|
|
|
|
|
$pm = shift; |
890
|
|
|
|
|
|
|
croak "unknown option" unless defined $opt->{At} && |
891
|
|
|
|
|
|
|
$opt->{At} =~ /^(Top|Bot|Middle)$/; |
892
|
|
|
|
|
|
|
$pos = $opt->{At}; |
893
|
|
|
|
|
|
|
} else { |
894
|
|
|
|
|
|
|
$pos = 'Middle'; |
895
|
|
|
|
|
|
|
} |
896
|
|
|
|
|
|
|
$::PDLPM{$pos} .= "$pm\n\n"; |
897
|
|
|
|
|
|
|
} |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
sub pp_add_exported { |
900
|
|
|
|
|
|
|
# my ($this,$exp) = @_; |
901
|
|
|
|
|
|
|
my $exp = join ' ', @_; # get rid of this silly $this argument |
902
|
|
|
|
|
|
|
$::PDLPMROUT .= $exp." "; |
903
|
|
|
|
|
|
|
} |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
sub pp_addbegin { |
906
|
|
|
|
|
|
|
my ($cmd) = @_; |
907
|
|
|
|
|
|
|
if ($cmd =~ /^\s*BOOT\s*$/) { |
908
|
|
|
|
|
|
|
pp_beginwrap; |
909
|
|
|
|
|
|
|
} else { |
910
|
|
|
|
|
|
|
$::PDLBEGIN .= $cmd."\n"; |
911
|
|
|
|
|
|
|
} |
912
|
|
|
|
|
|
|
} |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
# Sub to call to export nothing (i.e. for building OO package/object) |
915
|
|
|
|
|
|
|
sub pp_export_nothing { |
916
|
|
|
|
|
|
|
$::PDLPMROUT = ' '; |
917
|
|
|
|
|
|
|
} |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
sub pp_add_isa { |
920
|
|
|
|
|
|
|
push @::PDLPMISA,@_; |
921
|
|
|
|
|
|
|
} |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
sub pp_add_boot { |
924
|
|
|
|
|
|
|
my ($boot) = @_; |
925
|
|
|
|
|
|
|
$::PDLXSBOOT .= $boot." "; |
926
|
|
|
|
|
|
|
} |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
sub pp_bless{ |
929
|
|
|
|
|
|
|
my($new_package)=@_; |
930
|
|
|
|
|
|
|
$::PDLOBJ = $new_package; |
931
|
|
|
|
|
|
|
} |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
# sub to call to set the import list from core on the 'Use Core' line in the .pm file. |
934
|
|
|
|
|
|
|
# set to '()' to not import anything from Core, or 'qw/ barf /' to import barf. |
935
|
|
|
|
|
|
|
sub pp_core_importList{ |
936
|
|
|
|
|
|
|
$::PDLCOREIMPORT = $_[0]; |
937
|
|
|
|
|
|
|
} |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
sub printxs { |
940
|
|
|
|
|
|
|
shift; |
941
|
|
|
|
|
|
|
$::PDLXS .= join'',@_; |
942
|
|
|
|
|
|
|
} |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
sub pp_addxs { |
945
|
|
|
|
|
|
|
PDL::PP->printxs("\nMODULE = $::PDLMOD PACKAGE = $::CALLPACK\n\n", |
946
|
|
|
|
|
|
|
@_, |
947
|
|
|
|
|
|
|
"\nMODULE = $::PDLMOD PACKAGE = $::PDLOBJ\n\n"); |
948
|
|
|
|
|
|
|
} |
949
|
|
|
|
|
|
|
|
950
|
|
|
|
|
|
|
# inserts #line directives into source text. Use like this: |
951
|
|
|
|
|
|
|
# ... |
952
|
|
|
|
|
|
|
# FirstKey => ..., |
953
|
|
|
|
|
|
|
# Code => pp_line_numbers(__LINE__, $x . $y . $c), |
954
|
|
|
|
|
|
|
# OtherKey => ... |
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
sub pp_line_numbers ($$) { |
957
|
|
|
|
|
|
|
my ($line, $string) = @_; |
958
|
|
|
|
|
|
|
# The line needs to be incremented by one for the bookkeeping to work |
959
|
|
|
|
|
|
|
$line++; |
960
|
|
|
|
|
|
|
# Get the source filename using caller() |
961
|
|
|
|
|
|
|
my (undef, $filename) = caller; |
962
|
|
|
|
|
|
|
# Escape backslashes: |
963
|
|
|
|
|
|
|
$filename =~ s/\\/\\\\/g; |
964
|
|
|
|
|
|
|
my @to_return = "\n#line $line \"$filename\"\n"; |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
# Look for threadloops and loops and add # line directives |
967
|
|
|
|
|
|
|
foreach (split (/\n/, $string)) { |
968
|
|
|
|
|
|
|
# Always add the current line. |
969
|
|
|
|
|
|
|
s/^=/ =/; # so doesn't look like POD |
970
|
|
|
|
|
|
|
push @to_return, "$_\n"; |
971
|
|
|
|
|
|
|
# If we need to add a # line directive, do so after incrementing |
972
|
|
|
|
|
|
|
$line++; |
973
|
|
|
|
|
|
|
if (/%\{/ or /%}/) { |
974
|
|
|
|
|
|
|
push @to_return, "#line $line \"$filename\"\n"; |
975
|
|
|
|
|
|
|
} |
976
|
|
|
|
|
|
|
} |
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
return join('', @to_return); |
979
|
|
|
|
|
|
|
} |
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
sub printxsc { |
982
|
|
|
|
|
|
|
shift; |
983
|
|
|
|
|
|
|
$::PDLXSC .= join '',@_; |
984
|
|
|
|
|
|
|
} |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
sub pp_done { |
987
|
|
|
|
|
|
|
return if $PDL::PP::done; # do only once! |
988
|
|
|
|
|
|
|
$PDL::PP::done = 1; |
989
|
|
|
|
|
|
|
$::FUNCSPOD = $::DOCUMENTED ? "\n\n=head1 FUNCTIONS\n\n\n\n=cut\n\n\n" |
990
|
|
|
|
|
|
|
: ''; |
991
|
|
|
|
|
|
|
print "DONE!\n" if $::PP_VERBOSE; |
992
|
|
|
|
|
|
|
print "Inline running PDL::PP version $PDL::PP::VERSION...\n" if nopm(); |
993
|
|
|
|
|
|
|
(my $fh = FileHandle->new(">$::PDLPREF.xs")) or die "Couldn't open xs file\n"; |
994
|
|
|
|
|
|
|
my $pdl_boot = PDL::Core::Dev::PDL_BOOT('PDL', $::PDLMOD); # don't hardcode in more than one place |
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
$fh->print(pp_line_numbers(__LINE__, qq% |
997
|
|
|
|
|
|
|
/* |
998
|
|
|
|
|
|
|
* THIS FILE WAS GENERATED BY PDL::PP! Do not modify! |
999
|
|
|
|
|
|
|
*/ |
1000
|
|
|
|
|
|
|
|
1001
|
|
|
|
|
|
|
#define PDL_COMMENT(comment) |
1002
|
|
|
|
|
|
|
PDL_COMMENT("This preprocessor symbol is used to add commentary in the PDL ") |
1003
|
|
|
|
|
|
|
PDL_COMMENT("autogenerated code. Normally, one would use typical C-style ") |
1004
|
|
|
|
|
|
|
PDL_COMMENT("multiline comments (i.e. /* comment */). However, because such ") |
1005
|
|
|
|
|
|
|
PDL_COMMENT("comments do not nest, it's not possible for PDL::PP users to ") |
1006
|
|
|
|
|
|
|
PDL_COMMENT("comment-out sections of code using multiline comments, as is ") |
1007
|
|
|
|
|
|
|
PDL_COMMENT("often the practice when debugging, for example. So, when you ") |
1008
|
|
|
|
|
|
|
PDL_COMMENT("see something like this: ") |
1009
|
|
|
|
|
|
|
PDL_COMMENT(" ") |
1010
|
|
|
|
|
|
|
PDL_COMMENT("Memory access") |
1011
|
|
|
|
|
|
|
PDL_COMMENT(" ") |
1012
|
|
|
|
|
|
|
PDL_COMMENT("just think of it as a C multiline comment like: ") |
1013
|
|
|
|
|
|
|
PDL_COMMENT(" ") |
1014
|
|
|
|
|
|
|
PDL_COMMENT(" /* Memory access */ ") |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
#include "EXTERN.h" |
1017
|
|
|
|
|
|
|
#include "perl.h" |
1018
|
|
|
|
|
|
|
#include "XSUB.h" |
1019
|
|
|
|
|
|
|
#include "pdl.h" |
1020
|
|
|
|
|
|
|
#include "pdlcore.h" |
1021
|
|
|
|
|
|
|
static Core* PDL; PDL_COMMENT("Structure hold core C functions") |
1022
|
|
|
|
|
|
|
static int __pdl_debugging = 0; |
1023
|
|
|
|
|
|
|
static int __pdl_boundscheck = 0; |
1024
|
|
|
|
|
|
|
static SV* CoreSV; PDL_COMMENT("Gets pointer to perl var holding core structure") |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
#if ! $PP::boundscheck |
1027
|
|
|
|
|
|
|
# define PP_INDTERM(max, at) at |
1028
|
|
|
|
|
|
|
#else |
1029
|
|
|
|
|
|
|
# define PP_INDTERM(max, at) (__pdl_boundscheck? PDL->safe_indterm(max,at, __FILE__, __LINE__) : at) |
1030
|
|
|
|
|
|
|
#endif |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
$::PDLXSC |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
MODULE = $::PDLMOD PACKAGE = $::PDLMOD |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
PROTOTYPES: ENABLE |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
int |
1039
|
|
|
|
|
|
|
set_debugging(i) |
1040
|
|
|
|
|
|
|
int i; |
1041
|
|
|
|
|
|
|
CODE: |
1042
|
|
|
|
|
|
|
RETVAL = __pdl_debugging; |
1043
|
|
|
|
|
|
|
__pdl_debugging = i; |
1044
|
|
|
|
|
|
|
OUTPUT: |
1045
|
|
|
|
|
|
|
RETVAL |
1046
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
int |
1048
|
|
|
|
|
|
|
set_boundscheck(i) |
1049
|
|
|
|
|
|
|
int i; |
1050
|
|
|
|
|
|
|
CODE: |
1051
|
|
|
|
|
|
|
if (! $PP::boundscheck) |
1052
|
|
|
|
|
|
|
warn("Bounds checking is disabled for $::PDLMOD"); |
1053
|
|
|
|
|
|
|
RETVAL = __pdl_boundscheck; |
1054
|
|
|
|
|
|
|
__pdl_boundscheck = i; |
1055
|
|
|
|
|
|
|
OUTPUT: |
1056
|
|
|
|
|
|
|
RETVAL |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
|
MODULE = $::PDLMOD PACKAGE = $::PDLOBJ |
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
$::PDLXS |
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
BOOT: |
1064
|
|
|
|
|
|
|
|
1065
|
|
|
|
|
|
|
PDL_COMMENT("Get pointer to structure of core shared C routines") |
1066
|
|
|
|
|
|
|
PDL_COMMENT("make sure PDL::Core is loaded") |
1067
|
|
|
|
|
|
|
$pdl_boot |
1068
|
|
|
|
|
|
|
$::PDLXSBOOT |
1069
|
|
|
|
|
|
|
%)); |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
unless (nopm) { |
1072
|
|
|
|
|
|
|
$::PDLPMISA = "'".join("','",@::PDLPMISA)."'"; |
1073
|
|
|
|
|
|
|
$::PDLBEGIN = "BEGIN {\n$::PDLBEGIN\n}" |
1074
|
|
|
|
|
|
|
unless $::PDLBEGIN =~ /^\s*$/; |
1075
|
|
|
|
|
|
|
($fh = FileHandle->new(">$::PDLPREF.pm")) or die "Couldn't open pm file\n"; |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
$fh->print(qq% |
1078
|
|
|
|
|
|
|
# |
1079
|
|
|
|
|
|
|
# GENERATED WITH PDL::PP! Don't modify! |
1080
|
|
|
|
|
|
|
# |
1081
|
|
|
|
|
|
|
package $::PDLPACK; |
1082
|
|
|
|
|
|
|
|
1083
|
|
|
|
|
|
|
\@EXPORT_OK = qw( $::PDLPMROUT); |
1084
|
|
|
|
|
|
|
\%EXPORT_TAGS = (Func=>[\@EXPORT_OK]); |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
use PDL::Core$::PDLCOREIMPORT; |
1087
|
|
|
|
|
|
|
use PDL::Exporter; |
1088
|
|
|
|
|
|
|
use DynaLoader; |
1089
|
|
|
|
|
|
|
|
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
$::PDL_IFBEGINWRAP[0] |
1092
|
|
|
|
|
|
|
$::PDLVERSIONSET |
1093
|
|
|
|
|
|
|
\@ISA = ( $::PDLPMISA ); |
1094
|
|
|
|
|
|
|
push \@PDL::Core::PP, __PACKAGE__; |
1095
|
|
|
|
|
|
|
bootstrap $::PDLMOD $::PDLMODVERSION; |
1096
|
|
|
|
|
|
|
$::PDL_IFBEGINWRAP[-1] |
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
$::PDLBEGIN |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
$::PDLPM{Top} |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
$::FUNCSPOD |
1103
|
|
|
|
|
|
|
|
1104
|
|
|
|
|
|
|
$::PDLPM{Middle}; |
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
$::PDLPM{Bot} |
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
# Exit with OK status |
1109
|
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
|
1; |
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
%); # end of print |
1113
|
|
|
|
|
|
|
} # unless (nopm) {... |
1114
|
|
|
|
|
|
|
} # end pp_done |
1115
|
|
|
|
|
|
|
|
1116
|
|
|
|
|
|
|
sub pp_def { |
1117
|
|
|
|
|
|
|
my($name,%obj) = @_; |
1118
|
|
|
|
|
|
|
|
1119
|
|
|
|
|
|
|
print "*** Entering pp_def for $name\n" if $::PP_VERBOSE; |
1120
|
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
|
# See if the 'name' is multiline, in which case we extract the |
1122
|
|
|
|
|
|
|
# name and add the FullDoc field |
1123
|
|
|
|
|
|
|
if ($name =~ /\n/) { |
1124
|
|
|
|
|
|
|
my $fulldoc = $name; |
1125
|
|
|
|
|
|
|
# See if the very first thing is a word. That is going to be the |
1126
|
|
|
|
|
|
|
# name of the function under consideration |
1127
|
|
|
|
|
|
|
if ($fulldoc =~ s/^(\w+)//) { |
1128
|
|
|
|
|
|
|
$name = $1; |
1129
|
|
|
|
|
|
|
} |
1130
|
|
|
|
|
|
|
elsif ($fulldoc =~ /=head2 (\w+)/) { |
1131
|
|
|
|
|
|
|
$name = $1; |
1132
|
|
|
|
|
|
|
} |
1133
|
|
|
|
|
|
|
else { |
1134
|
|
|
|
|
|
|
croak('Unable to extract name'); |
1135
|
|
|
|
|
|
|
} |
1136
|
|
|
|
|
|
|
$obj{FullDoc} = $fulldoc; |
1137
|
|
|
|
|
|
|
} |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
$obj{Name} = $name; |
1140
|
|
|
|
|
|
|
translate(\%obj,$PDL::PP::deftbl); |
1141
|
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
|
print "Output of translate for $name:\n" . Dumper(\%obj) . "\n" |
1143
|
|
|
|
|
|
|
if exists $obj{Dump} and $obj{Dump} and $::PP_VERBOSE; |
1144
|
|
|
|
|
|
|
|
1145
|
|
|
|
|
|
|
croak("ERROR: No FreeFunc for pp_def=$name!\n") |
1146
|
|
|
|
|
|
|
unless exists $obj{FreeFunc}; # and $obj{FreeFunc}; |
1147
|
|
|
|
|
|
|
|
1148
|
|
|
|
|
|
|
PDL::PP->printxsc(join "\n\n",@obj{'StructDecl','RedoDimsFunc', |
1149
|
|
|
|
|
|
|
'CopyFunc', |
1150
|
|
|
|
|
|
|
'ReadDataFunc','WriteBackDataFunc', |
1151
|
|
|
|
|
|
|
'FreeFunc', |
1152
|
|
|
|
|
|
|
'FooFunc', |
1153
|
|
|
|
|
|
|
'VTableDef','NewXSInPrelude', |
1154
|
|
|
|
|
|
|
} |
1155
|
|
|
|
|
|
|
); |
1156
|
|
|
|
|
|
|
PDL::PP->printxs($obj{NewXSCode}); |
1157
|
|
|
|
|
|
|
pp_add_boot($obj{XSBootCode} . $obj{BootSetNewXS}); |
1158
|
|
|
|
|
|
|
PDL::PP->pp_add_exported($name); |
1159
|
|
|
|
|
|
|
PDL::PP::pp_addpm("\n".$obj{PdlDoc}."\n") if $obj{PdlDoc}; |
1160
|
|
|
|
|
|
|
PDL::PP::pp_addpm($obj{PMCode}); |
1161
|
|
|
|
|
|
|
PDL::PP::pp_addpm($obj{PMFunc}."\n"); |
1162
|
|
|
|
|
|
|
|
1163
|
|
|
|
|
|
|
print "*** Leaving pp_def for $name\n" if $::PP_VERBOSE; |
1164
|
|
|
|
|
|
|
} |
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
# marks this module as deprecated. This handles the user warnings, and adds a |
1167
|
|
|
|
|
|
|
# notice into the documentation. Can take a {infavor => "newmodule"} option |
1168
|
|
|
|
|
|
|
sub pp_deprecate_module |
1169
|
|
|
|
|
|
|
{ |
1170
|
|
|
|
|
|
|
my $options; |
1171
|
|
|
|
|
|
|
if( ref $_[0] eq 'HASH' ) { $options = shift; } |
1172
|
|
|
|
|
|
|
else { $options = { @_ }; } |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
my $infavor; |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
if( $options && ref $options eq 'HASH' && $options->{infavor} ) |
1177
|
|
|
|
|
|
|
{ |
1178
|
|
|
|
|
|
|
$infavor = $options->{infavor}; |
1179
|
|
|
|
|
|
|
} |
1180
|
|
|
|
|
|
|
|
1181
|
|
|
|
|
|
|
my $mod = $::PDLMOD; |
1182
|
|
|
|
|
|
|
my $envvar = 'PDL_SUPPRESS_DEPRECATION_WARNING__' . uc $mod; |
1183
|
|
|
|
|
|
|
$envvar =~ s/::/_/g; |
1184
|
|
|
|
|
|
|
|
1185
|
|
|
|
|
|
|
my $warning_main = |
1186
|
|
|
|
|
|
|
"$mod is deprecated."; |
1187
|
|
|
|
|
|
|
$warning_main .= |
1188
|
|
|
|
|
|
|
" Please use $infavor instead." if $infavor; |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
my $warning_suppression_runtime = |
1191
|
|
|
|
|
|
|
"This module will be removed in the future; please update your code.\n" . |
1192
|
|
|
|
|
|
|
"Set the environment variable $envvar\n" . |
1193
|
|
|
|
|
|
|
"to suppress this warning\n"; |
1194
|
|
|
|
|
|
|
|
1195
|
|
|
|
|
|
|
my $warning_suppression_pod = |
1196
|
|
|
|
|
|
|
"A warning will be generated at runtime upon a C |
1197
|
|
|
|
|
|
|
"This warning can be suppressed by setting the $envvar\n" . |
1198
|
|
|
|
|
|
|
"environment variable\n"; |
1199
|
|
|
|
|
|
|
|
1200
|
|
|
|
|
|
|
my $deprecation_notice = <
|
1201
|
|
|
|
|
|
|
XXX=head1 DEPRECATION NOTICE |
1202
|
|
|
|
|
|
|
|
1203
|
|
|
|
|
|
|
$warning_main |
1204
|
|
|
|
|
|
|
$warning_suppression_pod |
1205
|
|
|
|
|
|
|
|
1206
|
|
|
|
|
|
|
XXX=cut |
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
EOF |
1209
|
|
|
|
|
|
|
$deprecation_notice =~ s/^XXX=/=/gms; |
1210
|
|
|
|
|
|
|
pp_addpm( {At => 'Top'}, $deprecation_notice ); |
1211
|
|
|
|
|
|
|
|
1212
|
|
|
|
|
|
|
pp_addpm {At => 'Top'}, <
|
1213
|
|
|
|
|
|
|
warn \"$warning_main\n$warning_suppression_runtime\" unless \$ENV{$envvar}; |
1214
|
|
|
|
|
|
|
EOF |
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
|
1217
|
|
|
|
|
|
|
} |
1218
|
|
|
|
|
|
|
|
1219
|
|
|
|
|
|
|
# Worst memleaks: not freeing things at redodims or |
1220
|
|
|
|
|
|
|
# final free time (thread, dimmed things). |
1221
|
|
|
|
|
|
|
|
1222
|
|
|
|
|
|
|
use Carp; |
1223
|
|
|
|
|
|
|
$SIG{__DIE__} = sub {print Carp::longmess(@_); die;} |
1224
|
|
|
|
|
|
|
if $::PP_VERBOSE; # seems to give us trouble with 5.6.1 |
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
use PDL::PP::Signature; |
1227
|
|
|
|
|
|
|
use PDL::PP::Dims; |
1228
|
|
|
|
|
|
|
use PDL::PP::CType; |
1229
|
|
|
|
|
|
|
use PDL::PP::XS; |
1230
|
|
|
|
|
|
|
use PDL::PP::SymTab; |
1231
|
|
|
|
|
|
|
use PDL::PP::PDLCode; |
1232
|
|
|
|
|
|
|
|
1233
|
|
|
|
|
|
|
$|=1; |
1234
|
|
|
|
|
|
|
|
1235
|
|
|
|
|
|
|
# |
1236
|
|
|
|
|
|
|
# This is ripped from xsubpp to ease the parsing of the typemap. |
1237
|
|
|
|
|
|
|
# |
1238
|
|
|
|
|
|
|
our $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ; |
1239
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
sub ValidProtoString ($) |
1241
|
|
|
|
|
|
|
{ |
1242
|
|
|
|
|
|
|
my($string) = @_ ; |
1243
|
|
|
|
|
|
|
|
1244
|
|
|
|
|
|
|
if ( $string =~ /^$proto_re+$/ ) { |
1245
|
|
|
|
|
|
|
return $string ; |
1246
|
|
|
|
|
|
|
} |
1247
|
|
|
|
|
|
|
|
1248
|
|
|
|
|
|
|
return 0 ; |
1249
|
|
|
|
|
|
|
} |
1250
|
|
|
|
|
|
|
|
1251
|
|
|
|
|
|
|
sub C_string ($) |
1252
|
|
|
|
|
|
|
{ |
1253
|
|
|
|
|
|
|
my($string) = @_ ; |
1254
|
|
|
|
|
|
|
|
1255
|
|
|
|
|
|
|
$string =~ s[\\][\\\\]g ; |
1256
|
|
|
|
|
|
|
$string ; |
1257
|
|
|
|
|
|
|
} |
1258
|
|
|
|
|
|
|
|
1259
|
|
|
|
|
|
|
sub TrimWhitespace |
1260
|
|
|
|
|
|
|
{ |
1261
|
|
|
|
|
|
|
$_[0] =~ s/^\s+|\s+$//go ; |
1262
|
|
|
|
|
|
|
} |
1263
|
|
|
|
|
|
|
sub TidyType |
1264
|
|
|
|
|
|
|
{ |
1265
|
|
|
|
|
|
|
local ($_) = @_ ; |
1266
|
|
|
|
|
|
|
|
1267
|
|
|
|
|
|
|
# rationalise any '*' by joining them into bunches and removing whitespace |
1268
|
|
|
|
|
|
|
s#\s*(\*+)\s*#$1#g; |
1269
|
|
|
|
|
|
|
s#(\*+)# $1 #g ; |
1270
|
|
|
|
|
|
|
|
1271
|
|
|
|
|
|
|
# change multiple whitespace into a single space |
1272
|
|
|
|
|
|
|
s/\s+/ /g ; |
1273
|
|
|
|
|
|
|
|
1274
|
|
|
|
|
|
|
# trim leading & trailing whitespace |
1275
|
|
|
|
|
|
|
TrimWhitespace($_) ; |
1276
|
|
|
|
|
|
|
|
1277
|
|
|
|
|
|
|
$_ ; |
1278
|
|
|
|
|
|
|
} |
1279
|
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
|
1282
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1283
|
|
|
|
|
|
|
# Typemap handling in PP. |
1284
|
|
|
|
|
|
|
# |
1285
|
|
|
|
|
|
|
# This subroutine does limited input typemap conversion. |
1286
|
|
|
|
|
|
|
# Given a variable name (to set), its type, and the source |
1287
|
|
|
|
|
|
|
# for the variable, returns the correct input typemap entry. |
1288
|
|
|
|
|
|
|
# Original version: D. Hunt 4/13/00 - Current version J. Brinchmann (06/05/05) |
1289
|
|
|
|
|
|
|
# |
1290
|
|
|
|
|
|
|
# This is an extended typemap handler from the one earlier written by |
1291
|
|
|
|
|
|
|
# Doug Hunt. It should work exactly as the older version, but with extensions. |
1292
|
|
|
|
|
|
|
# Instead of handling a few special cases explicitly we now use Perl's |
1293
|
|
|
|
|
|
|
# built-in typemap handling using code taken straight from xsubpp. |
1294
|
|
|
|
|
|
|
# |
1295
|
|
|
|
|
|
|
# I have infact kept the old part of the code here because I belive any |
1296
|
|
|
|
|
|
|
# subsequent hackers might find it very helpful to refer to this code to |
1297
|
|
|
|
|
|
|
# understand what the following does. So here goes: |
1298
|
|
|
|
|
|
|
# |
1299
|
|
|
|
|
|
|
# ------------ OLD TYPEMAP PARSING: ------------------------ |
1300
|
|
|
|
|
|
|
# |
1301
|
|
|
|
|
|
|
# # Note that I now just look at the basetype. I don't |
1302
|
|
|
|
|
|
|
# # test whether it is a pointer to the base type or not. |
1303
|
|
|
|
|
|
|
# # This is done because it is simpler and I know that the otherpars |
1304
|
|
|
|
|
|
|
# # belong to a restricted set of types. I know a char will really |
1305
|
|
|
|
|
|
|
# # be a char *, for example. I also know that an SV will be an SV *. |
1306
|
|
|
|
|
|
|
# # yes, but how about catching syntax errors in OtherPars (CS)? |
1307
|
|
|
|
|
|
|
# # shouldn't we really parse the perl typemap (we can steal the code |
1308
|
|
|
|
|
|
|
# # from xsubpp)? |
1309
|
|
|
|
|
|
|
# |
1310
|
|
|
|
|
|
|
# my $OLD_PARSING=0; |
1311
|
|
|
|
|
|
|
# if ($OLD_PARSING) { |
1312
|
|
|
|
|
|
|
# my %typemap = (char => "(char *)SvPV($arg,PL_na)", |
1313
|
|
|
|
|
|
|
# short => "(short)SvIV($arg)", |
1314
|
|
|
|
|
|
|
# int => "(int)SvIV($arg)", |
1315
|
|
|
|
|
|
|
# long => "(long)SvIV($arg)", |
1316
|
|
|
|
|
|
|
# double => "(double)SvNV($arg)", |
1317
|
|
|
|
|
|
|
# float => "(float)SvNV($arg)", |
1318
|
|
|
|
|
|
|
# SV => "$arg", |
1319
|
|
|
|
|
|
|
# ); |
1320
|
|
|
|
|
|
|
# my $basetype = $type->{Base}; |
1321
|
|
|
|
|
|
|
# $basetype =~ s/\s+//g; # get rid of whitespace |
1322
|
|
|
|
|
|
|
# |
1323
|
|
|
|
|
|
|
# die "Cannot find $basetype in my (small) typemap" unless exists($typemap{$basetype}); |
1324
|
|
|
|
|
|
|
# return ($typemap{$basetype}); |
1325
|
|
|
|
|
|
|
# } |
1326
|
|
|
|
|
|
|
# |
1327
|
|
|
|
|
|
|
#--------- END OF THE OLD CODE --------------- |
1328
|
|
|
|
|
|
|
# |
1329
|
|
|
|
|
|
|
# The code loads the typemap from the Perl typemap using the loading logic of |
1330
|
|
|
|
|
|
|
# xsubpp. Do note that I made the assumption that |
1331
|
|
|
|
|
|
|
# $Config{}installprivlib}/ExtUtils was the right root directory for the search. |
1332
|
|
|
|
|
|
|
# This could break on some systems? |
1333
|
|
|
|
|
|
|
# |
1334
|
|
|
|
|
|
|
# Also I do _not_ parse the Typemap argument from ExtUtils::MakeMaker because I don't |
1335
|
|
|
|
|
|
|
# know how to catch it here! This would be good to fix! It does look for a file |
1336
|
|
|
|
|
|
|
# called typemap in the current directory however. |
1337
|
|
|
|
|
|
|
# |
1338
|
|
|
|
|
|
|
# The parsing of the typemap is mechanical and taken straight from xsubpp and |
1339
|
|
|
|
|
|
|
# the resulting hash lookup is then used to convert the input type to the |
1340
|
|
|
|
|
|
|
# necessary outputs (as seen in the old code above) |
1341
|
|
|
|
|
|
|
# |
1342
|
|
|
|
|
|
|
# JB 06/05/05 |
1343
|
|
|
|
|
|
|
# |
1344
|
|
|
|
|
|
|
sub typemap { |
1345
|
|
|
|
|
|
|
my $oname = shift; |
1346
|
|
|
|
|
|
|
my $type = shift; |
1347
|
|
|
|
|
|
|
my $arg = shift; |
1348
|
|
|
|
|
|
|
|
1349
|
|
|
|
|
|
|
# |
1350
|
|
|
|
|
|
|
# Modification to parse Perl's typemap here. |
1351
|
|
|
|
|
|
|
# |
1352
|
|
|
|
|
|
|
# The default search path for the typemap taken from xsubpp. It seems it is |
1353
|
|
|
|
|
|
|
# necessary to prepend the installprivlib/ExtUtils directory to find the typemap. |
1354
|
|
|
|
|
|
|
# It is not clear to me how this is to be done. |
1355
|
|
|
|
|
|
|
# |
1356
|
|
|
|
|
|
|
my ($typemap, $mode, $junk, $current, %input_expr, |
1357
|
|
|
|
|
|
|
%proto_letter, %output_expr, %type_kind); |
1358
|
|
|
|
|
|
|
|
1359
|
|
|
|
|
|
|
# according to MM_Unix 'privlibexp' is the right directory |
1360
|
|
|
|
|
|
|
# seems to work even on OS X (where installprivlib breaks things) |
1361
|
|
|
|
|
|
|
# if this does not work portably we should split out the typemap finding code |
1362
|
|
|
|
|
|
|
# and make it as complex as necessary + save the typemap location |
1363
|
|
|
|
|
|
|
# in the PDL::Config hash |
1364
|
|
|
|
|
|
|
my $_rootdir = $Config{privlibexp}.'/ExtUtils/'; |
1365
|
|
|
|
|
|
|
# print "_rootdir set to '$_rootdir'\n"; |
1366
|
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
|
# First the system typemaps.. |
1368
|
|
|
|
|
|
|
my @tm = ($_rootdir.'../../../../lib/ExtUtils/typemap', |
1369
|
|
|
|
|
|
|
$_rootdir.'../../../lib/ExtUtils/typemap', |
1370
|
|
|
|
|
|
|
$_rootdir.'../../lib/ExtUtils/typemap', |
1371
|
|
|
|
|
|
|
$_rootdir.'../../../typemap', |
1372
|
|
|
|
|
|
|
$_rootdir.'../../typemap', $_rootdir.'../typemap', |
1373
|
|
|
|
|
|
|
$_rootdir.'typemap'); |
1374
|
|
|
|
|
|
|
# Finally tag onto the end, the current directory typemap. Ideally we should here pick |
1375
|
|
|
|
|
|
|
# up the TYPEMAPS flag from ExtUtils::MakeMaker, but a) I don't know how and b) |
1376
|
|
|
|
|
|
|
# it is only a slight inconvenience hopefully! |
1377
|
|
|
|
|
|
|
# |
1378
|
|
|
|
|
|
|
# Note that the OUTPUT typemap is unlikely to be of use here, but I have kept |
1379
|
|
|
|
|
|
|
# the source code from xsubpp for tidiness. |
1380
|
|
|
|
|
|
|
push @tm, 'typemap'; |
1381
|
|
|
|
|
|
|
my $foundtm = 0; |
1382
|
|
|
|
|
|
|
foreach $typemap (@tm) { |
1383
|
|
|
|
|
|
|
next unless -f $typemap ; |
1384
|
|
|
|
|
|
|
# skip directories, binary files etc. |
1385
|
|
|
|
|
|
|
warn("Warning: ignoring non-text typemap file '$typemap'\n"), next |
1386
|
|
|
|
|
|
|
unless -T $typemap ; |
1387
|
|
|
|
|
|
|
$foundtm = 1; |
1388
|
|
|
|
|
|
|
open(TYPEMAP, $typemap) |
1389
|
|
|
|
|
|
|
or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; |
1390
|
|
|
|
|
|
|
$mode = 'Typemap'; |
1391
|
|
|
|
|
|
|
$junk = "" ; |
1392
|
|
|
|
|
|
|
$current = \$junk; |
1393
|
|
|
|
|
|
|
while () { |
1394
|
|
|
|
|
|
|
next if /^\s*#/; |
1395
|
|
|
|
|
|
|
my $line_no = $. + 1; |
1396
|
|
|
|
|
|
|
if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } |
1397
|
|
|
|
|
|
|
if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } |
1398
|
|
|
|
|
|
|
if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } |
1399
|
|
|
|
|
|
|
if ($mode eq 'Typemap') { |
1400
|
|
|
|
|
|
|
chomp; |
1401
|
|
|
|
|
|
|
my $line = $_ ; |
1402
|
|
|
|
|
|
|
TrimWhitespace($_) ; |
1403
|
|
|
|
|
|
|
# skip blank lines and comment lines |
1404
|
|
|
|
|
|
|
next if /^$/ or /^#/ ; |
1405
|
|
|
|
|
|
|
my($t_type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or |
1406
|
|
|
|
|
|
|
warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; |
1407
|
|
|
|
|
|
|
$t_type = TidyType($t_type) ; |
1408
|
|
|
|
|
|
|
$type_kind{$t_type} = $kind ; |
1409
|
|
|
|
|
|
|
# prototype defaults to '$' |
1410
|
|
|
|
|
|
|
$proto = "\$" unless $proto ; |
1411
|
|
|
|
|
|
|
warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") |
1412
|
|
|
|
|
|
|
unless ValidProtoString($proto) ; |
1413
|
|
|
|
|
|
|
$proto_letter{$t_type} = C_string($proto) ; |
1414
|
|
|
|
|
|
|
} |
1415
|
|
|
|
|
|
|
elsif (/^\s/) { |
1416
|
|
|
|
|
|
|
$$current .= $_; |
1417
|
|
|
|
|
|
|
} |
1418
|
|
|
|
|
|
|
elsif ($mode eq 'Input') { |
1419
|
|
|
|
|
|
|
s/\s+$//; |
1420
|
|
|
|
|
|
|
$input_expr{$_} = ''; |
1421
|
|
|
|
|
|
|
$current = \$input_expr{$_}; |
1422
|
|
|
|
|
|
|
} |
1423
|
|
|
|
|
|
|
else { |
1424
|
|
|
|
|
|
|
s/\s+$//; |
1425
|
|
|
|
|
|
|
$output_expr{$_} = ''; |
1426
|
|
|
|
|
|
|
$current = \$output_expr{$_}; |
1427
|
|
|
|
|
|
|
} |
1428
|
|
|
|
|
|
|
} |
1429
|
|
|
|
|
|
|
close(TYPEMAP); |
1430
|
|
|
|
|
|
|
} |
1431
|
|
|
|
|
|
|
carp "**CRITICAL** PP found no typemap in $_rootdir/typemap; this will cause problems..." |
1432
|
|
|
|
|
|
|
unless $foundtm; |
1433
|
|
|
|
|
|
|
|
1434
|
|
|
|
|
|
|
# |
1435
|
|
|
|
|
|
|
# Do checks... |
1436
|
|
|
|
|
|
|
# |
1437
|
|
|
|
|
|
|
# First reconstruct the type declaration to look up in type_kind |
1438
|
|
|
|
|
|
|
my $full_type=TidyType($type->get_decl('')); # Skip the variable name |
1439
|
|
|
|
|
|
|
die "The type =$full_type= does not have a typemap entry!\n" unless exists($type_kind{$full_type}); |
1440
|
|
|
|
|
|
|
my $typemap_kind = $type_kind{$full_type}; |
1441
|
|
|
|
|
|
|
# Look up the conversion from the INPUT typemap. Note that we need to do some |
1442
|
|
|
|
|
|
|
# massaging of this. |
1443
|
|
|
|
|
|
|
my $input = $input_expr{$typemap_kind}; |
1444
|
|
|
|
|
|
|
# Remove all before =: |
1445
|
|
|
|
|
|
|
$input =~ s/^(.*?)=\s*//; # This should not be very expensive |
1446
|
|
|
|
|
|
|
# Replace $arg with $arg |
1447
|
|
|
|
|
|
|
$input =~ s/\$arg/$arg/; |
1448
|
|
|
|
|
|
|
# And type with $full_type |
1449
|
|
|
|
|
|
|
$input =~ s/\$type/$full_type/; |
1450
|
|
|
|
|
|
|
|
1451
|
|
|
|
|
|
|
return ($input); |
1452
|
|
|
|
|
|
|
} |
1453
|
|
|
|
|
|
|
|
1454
|
|
|
|
|
|
|
|
1455
|
|
|
|
|
|
|
sub identity2priv { |
1456
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, ' |
1457
|
|
|
|
|
|
|
int i; |
1458
|
|
|
|
|
|
|
$SETNDIMS($PARENT(ndims)); |
1459
|
|
|
|
|
|
|
for(i=0; i<$CHILD(ndims); i++) { |
1460
|
|
|
|
|
|
|
$CHILD(dims[i]) = $PARENT(dims[i]); |
1461
|
|
|
|
|
|
|
} |
1462
|
|
|
|
|
|
|
$SETDIMS(); |
1463
|
|
|
|
|
|
|
$SETDELTATHREADIDS(0); |
1464
|
|
|
|
|
|
|
'); |
1465
|
|
|
|
|
|
|
} |
1466
|
|
|
|
|
|
|
|
1467
|
|
|
|
|
|
|
sub pdimexpr2priv { |
1468
|
|
|
|
|
|
|
my($pdimexpr,$hdr,$dimcheck) = @_; |
1469
|
|
|
|
|
|
|
$pdimexpr =~ s/\$CDIM\b/i/g; |
1470
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, ' |
1471
|
|
|
|
|
|
|
int i,cor; |
1472
|
|
|
|
|
|
|
'.$dimcheck.' |
1473
|
|
|
|
|
|
|
$SETNDIMS($PARENT(ndims)); |
1474
|
|
|
|
|
|
|
$DOPRIVDIMS(); |
1475
|
|
|
|
|
|
|
$PRIV(offs) = 0; |
1476
|
|
|
|
|
|
|
for(i=0; i<$CHILD(ndims); i++) { |
1477
|
|
|
|
|
|
|
cor = '.$pdimexpr.'; |
1478
|
|
|
|
|
|
|
$CHILD(dims[i]) = $PARENT(dims[cor]); |
1479
|
|
|
|
|
|
|
$PRIV(incs[i]) = $PARENT(dimincs[cor]); |
1480
|
|
|
|
|
|
|
|
1481
|
|
|
|
|
|
|
} |
1482
|
|
|
|
|
|
|
$SETDIMS(); |
1483
|
|
|
|
|
|
|
$SETDELTATHREADIDS(0); |
1484
|
|
|
|
|
|
|
'); |
1485
|
|
|
|
|
|
|
} |
1486
|
|
|
|
|
|
|
|
1487
|
|
|
|
|
|
|
# something to do with copying values between parent and children |
1488
|
|
|
|
|
|
|
# |
1489
|
|
|
|
|
|
|
# we can NOT assume that PARENT and CHILD have the same type, |
1490
|
|
|
|
|
|
|
# hence the version for bad code |
1491
|
|
|
|
|
|
|
# |
1492
|
|
|
|
|
|
|
# NOTE: we use the same code for 'good' and 'bad' cases - it's |
1493
|
|
|
|
|
|
|
# just that when we use it for 'bad' data, we have to change the |
1494
|
|
|
|
|
|
|
# definition of the EQUIVCPOFFS macro - see the Code rule |
1495
|
|
|
|
|
|
|
# |
1496
|
|
|
|
|
|
|
sub equivcpoffscode { |
1497
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, |
1498
|
|
|
|
|
|
|
'PDL_Indx i; |
1499
|
|
|
|
|
|
|
for(i=0; i<$CHILD_P(nvals); i++) { |
1500
|
|
|
|
|
|
|
$EQUIVCPOFFS(i,i); |
1501
|
|
|
|
|
|
|
}'); |
1502
|
|
|
|
|
|
|
|
1503
|
|
|
|
|
|
|
} # sub: equivcpoffscode() |
1504
|
|
|
|
|
|
|
|
1505
|
|
|
|
|
|
|
# Pars -> ParNames, Parobjs |
1506
|
|
|
|
|
|
|
# |
1507
|
|
|
|
|
|
|
# XXX |
1508
|
|
|
|
|
|
|
# - the need for BadFlag is due to hacked get_xsdatapdecl() |
1509
|
|
|
|
|
|
|
# in PP/PdlParObj and because the PdlParObjs are created by |
1510
|
|
|
|
|
|
|
# PDL::PP::Signature (Doug Burke 07/08/00) |
1511
|
|
|
|
|
|
|
sub Pars_nft { |
1512
|
|
|
|
|
|
|
my($str,$badflag) = @_; |
1513
|
|
|
|
|
|
|
my $sig = PDL::PP::Signature->new($str,$badflag); |
1514
|
|
|
|
|
|
|
return ($sig->names,$sig->objs,1); |
1515
|
|
|
|
|
|
|
} |
1516
|
|
|
|
|
|
|
|
1517
|
|
|
|
|
|
|
# ParNames,Parobjs -> DimObjs |
1518
|
|
|
|
|
|
|
sub ParObjs_DimObjs { |
1519
|
|
|
|
|
|
|
my($pnames,$pobjs) = @_; |
1520
|
|
|
|
|
|
|
my ($dimobjs) = PDL::PP::PdlDimsObj->new(); |
1521
|
|
|
|
|
|
|
for(@$pnames) { |
1522
|
|
|
|
|
|
|
$pobjs->{$_}->add_inds($dimobjs); |
1523
|
|
|
|
|
|
|
} |
1524
|
|
|
|
|
|
|
return ($dimobjs); |
1525
|
|
|
|
|
|
|
} |
1526
|
|
|
|
|
|
|
|
1527
|
|
|
|
|
|
|
# Eliminate whitespace entries |
1528
|
|
|
|
|
|
|
sub nospacesplit {map {/^\s*$/?():$_} split $_[0],$_[1]} |
1529
|
|
|
|
|
|
|
|
1530
|
|
|
|
|
|
|
sub OtherPars_nft { |
1531
|
|
|
|
|
|
|
my($otherpars,$dimobjs) = @_; |
1532
|
|
|
|
|
|
|
my(@names,%types,$type); |
1533
|
|
|
|
|
|
|
# support 'int ndim => n;' syntax |
1534
|
|
|
|
|
|
|
for (nospacesplit ';',$otherpars) { |
1535
|
|
|
|
|
|
|
if (/^\s*([^=]+)\s*=>\s*(\S+)\s*$/) { |
1536
|
|
|
|
|
|
|
my ($ctype,$dim) = ($1,$2); |
1537
|
|
|
|
|
|
|
$ctype =~ s/(\S+)\s+$/$1/; # get rid of trailing ws |
1538
|
|
|
|
|
|
|
print "OtherPars: setting dim '$dim' from '$ctype'\n" if $::PP_VERBOSE; |
1539
|
|
|
|
|
|
|
$type = C::Type->new(undef,$ctype); |
1540
|
|
|
|
|
|
|
croak "can't set unknown dimension" |
1541
|
|
|
|
|
|
|
unless defined($dimobjs->{$dim}); |
1542
|
|
|
|
|
|
|
$dimobjs->{$dim}->set_from($type); |
1543
|
|
|
|
|
|
|
} elsif(/^\s*pdl\s+\*\s*(\w+)$/) { |
1544
|
|
|
|
|
|
|
# It is a piddle -> make it a controlling one. |
1545
|
|
|
|
|
|
|
die("Not supported yet"); |
1546
|
|
|
|
|
|
|
} else { |
1547
|
|
|
|
|
|
|
$type = C::Type->new(undef,$_); |
1548
|
|
|
|
|
|
|
} |
1549
|
|
|
|
|
|
|
my $name = $type->protoname; |
1550
|
|
|
|
|
|
|
if ($name =~ /$INVALID_OTHERPARS_RE/) { |
1551
|
|
|
|
|
|
|
croak "Invalid OtherPars name: $name"; |
1552
|
|
|
|
|
|
|
} |
1553
|
|
|
|
|
|
|
push @names,$name; |
1554
|
|
|
|
|
|
|
$types{$name} = $type; |
1555
|
|
|
|
|
|
|
} |
1556
|
|
|
|
|
|
|
return (\@names,\%types); |
1557
|
|
|
|
|
|
|
} |
1558
|
|
|
|
|
|
|
|
1559
|
|
|
|
|
|
|
sub NXArgs { |
1560
|
|
|
|
|
|
|
my($parnames,$parobjs,$onames,$oobjs) = @_; |
1561
|
|
|
|
|
|
|
my $pdltype = C::Type->new(undef,"pdl *__foo__"); |
1562
|
|
|
|
|
|
|
my $nxargs = [ |
1563
|
|
|
|
|
|
|
( map {[$_,$pdltype]} @$parnames ), |
1564
|
|
|
|
|
|
|
( map {[$_,$oobjs->{$_}]} @$onames ) |
1565
|
|
|
|
|
|
|
]; |
1566
|
|
|
|
|
|
|
return $nxargs; |
1567
|
|
|
|
|
|
|
} |
1568
|
|
|
|
|
|
|
|
1569
|
|
|
|
|
|
|
# XXX |
1570
|
|
|
|
|
|
|
# - the need for BadFlag is due to hacked get_xsdatapdecl() |
1571
|
|
|
|
|
|
|
# in PP/PdlParObj and because the PdlParObjs are created by |
1572
|
|
|
|
|
|
|
# PDL::PP::Signature (Doug Burke 07/08/00) |
1573
|
|
|
|
|
|
|
sub NewParentChildPars { |
1574
|
|
|
|
|
|
|
my($p2child,$name,$badflag) = @_; |
1575
|
|
|
|
|
|
|
return (Pars_nft("PARENT(); [oca]CHILD();",$badflag),0,"${name}_NN"); |
1576
|
|
|
|
|
|
|
} |
1577
|
|
|
|
|
|
|
|
1578
|
|
|
|
|
|
|
# XXX |
1579
|
|
|
|
|
|
|
# - the need for BadFlag is due to hacked get_xsdatapdecl() |
1580
|
|
|
|
|
|
|
# in PP/PdlParObj and because the PdlParObjs are created by |
1581
|
|
|
|
|
|
|
# PDL::PP::Signature (Doug Burke 07/08/00) |
1582
|
|
|
|
|
|
|
# |
1583
|
|
|
|
|
|
|
# however, it looks like this isn't being used anymore, |
1584
|
|
|
|
|
|
|
# so commenting out. |
1585
|
|
|
|
|
|
|
# |
1586
|
|
|
|
|
|
|
#sub ParentChildPars { |
1587
|
|
|
|
|
|
|
# my($p2child,$name,$badflag) = @_; |
1588
|
|
|
|
|
|
|
# return (Pars_nft("PARENT(); [oca]CHILD();",$badflag),0,"${name}_XX", |
1589
|
|
|
|
|
|
|
# " |
1590
|
|
|
|
|
|
|
# *$name = \\&PDL::$name; |
1591
|
|
|
|
|
|
|
# sub PDL::$name { |
1592
|
|
|
|
|
|
|
# my \$this = shift; |
1593
|
|
|
|
|
|
|
# my \$foo=\$this->null; |
1594
|
|
|
|
|
|
|
# PDL::${name}_XX(\$this,\$foo,\@_); |
1595
|
|
|
|
|
|
|
# \$foo |
1596
|
|
|
|
|
|
|
# } |
1597
|
|
|
|
|
|
|
# "); |
1598
|
|
|
|
|
|
|
#} |
1599
|
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
|
sub mkstruct { |
1601
|
|
|
|
|
|
|
my($pnames,$pobjs,$comp,$priv,$name) = @_; |
1602
|
|
|
|
|
|
|
my $npdls = $#$pnames+1; |
1603
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, qq{typedef struct $name { |
1604
|
|
|
|
|
|
|
PDL_TRANS_START($npdls); |
1605
|
|
|
|
|
|
|
$priv |
1606
|
|
|
|
|
|
|
$comp |
1607
|
|
|
|
|
|
|
char __ddone; PDL_COMMENT("Dims done") |
1608
|
|
|
|
|
|
|
} $name;}); |
1609
|
|
|
|
|
|
|
} |
1610
|
|
|
|
|
|
|
|
1611
|
|
|
|
|
|
|
sub def_vtable { |
1612
|
|
|
|
|
|
|
my($vname,$sname,$rdname,$rfname,$wfname,$cpfname,$ffname, |
1613
|
|
|
|
|
|
|
$pnames,$pobjs,$affine_ok,$foofname) = @_; |
1614
|
|
|
|
|
|
|
my $nparents = 0 + grep {! $pobjs->{$_}->{FlagW}} @$pnames; |
1615
|
|
|
|
|
|
|
my $aff = ($affine_ok ? "PDL_TPDL_VAFFINE_OK" : 0); |
1616
|
|
|
|
|
|
|
my $npdls = scalar @$pnames; |
1617
|
|
|
|
|
|
|
my $join_flags = join",",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ? |
1618
|
|
|
|
|
|
|
0 : $aff} 0..$npdls-1; |
1619
|
|
|
|
|
|
|
if($Config{cc} eq 'cl') { |
1620
|
|
|
|
|
|
|
$join_flags = '""' if $join_flags eq ''; |
1621
|
|
|
|
|
|
|
} |
1622
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, "static char ${vname}_flags[] = |
1623
|
|
|
|
|
|
|
{ ". $join_flags . "}; |
1624
|
|
|
|
|
|
|
pdl_transvtable $vname = { |
1625
|
|
|
|
|
|
|
0,0, $nparents, $npdls, ${vname}_flags, |
1626
|
|
|
|
|
|
|
$rdname, $rfname, $wfname, |
1627
|
|
|
|
|
|
|
$ffname,NULL,NULL,$cpfname, |
1628
|
|
|
|
|
|
|
sizeof($sname),\"$vname\" |
1629
|
|
|
|
|
|
|
};"); |
1630
|
|
|
|
|
|
|
} |
1631
|
|
|
|
|
|
|
|
1632
|
|
|
|
|
|
|
sub sort_pnobjs { |
1633
|
|
|
|
|
|
|
my($pnames,$pobjs) = @_; |
1634
|
|
|
|
|
|
|
my (@nn); |
1635
|
|
|
|
|
|
|
for(@$pnames) { push ( @nn, $_ ) unless $pobjs->{$_}{FlagW}; } |
1636
|
|
|
|
|
|
|
for(@$pnames) { push ( @nn, $_ ) if $pobjs->{$_}{FlagW}; } |
1637
|
|
|
|
|
|
|
my $no = 0; |
1638
|
|
|
|
|
|
|
for(@nn) { $pobjs->{$_}{Number} = $no++; } |
1639
|
|
|
|
|
|
|
return (\@nn,$pobjs); |
1640
|
|
|
|
|
|
|
} |
1641
|
|
|
|
|
|
|
|
1642
|
|
|
|
|
|
|
# XXX __privtrans explicit :( |
1643
|
|
|
|
|
|
|
sub wrap_vfn { |
1644
|
|
|
|
|
|
|
my($code,$hdrinfo,$rout,$p2child,$name) = @_; |
1645
|
|
|
|
|
|
|
my $type = ($name eq "copy" ? "pdl_trans *" : "void"); |
1646
|
|
|
|
|
|
|
my $sname = $hdrinfo->{StructName}; |
1647
|
|
|
|
|
|
|
my $oargs = ($name eq "foo" ? ",int i1,int i2,int i3" : ""); |
1648
|
|
|
|
|
|
|
|
1649
|
|
|
|
|
|
|
# print "$rout\_$name: $p2child\n"; |
1650
|
|
|
|
|
|
|
my $p2decl = ''; |
1651
|
|
|
|
|
|
|
# Put p2child in simple boolean context rather than strict numerical equality |
1652
|
|
|
|
|
|
|
if ( $p2child ) { |
1653
|
|
|
|
|
|
|
$p2decl = |
1654
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, "pdl *__it = ((pdl_trans_affine *)(__tr))->pdls[1]; pdl *__parent = __tr->pdls[0];"); |
1655
|
|
|
|
|
|
|
if ( $name eq "redodims" ) { |
1656
|
|
|
|
|
|
|
$p2decl .= ' |
1657
|
|
|
|
|
|
|
if (__parent->hdrsv && (__parent->state & PDL_HDRCPY)) { |
1658
|
|
|
|
|
|
|
PDL_COMMENT("call the perl routine _hdr_copy.") |
1659
|
|
|
|
|
|
|
int count; |
1660
|
|
|
|
|
|
|
|
1661
|
|
|
|
|
|
|
dSP; |
1662
|
|
|
|
|
|
|
ENTER ; |
1663
|
|
|
|
|
|
|
SAVETMPS ; |
1664
|
|
|
|
|
|
|
PUSHMARK(SP) ; |
1665
|
|
|
|
|
|
|
XPUSHs( sv_mortalcopy((SV*)__parent->hdrsv) ); |
1666
|
|
|
|
|
|
|
PUTBACK ; |
1667
|
|
|
|
|
|
|
count = call_pv("PDL::_hdr_copy",G_SCALAR); |
1668
|
|
|
|
|
|
|
SPAGAIN ; |
1669
|
|
|
|
|
|
|
if(count != 1) |
1670
|
|
|
|
|
|
|
croak("PDL::_hdr_copy didn\'t return a single value - please report this bug (B)."); |
1671
|
|
|
|
|
|
|
|
1672
|
|
|
|
|
|
|
{ PDL_COMMENT("convenience block for tmp var") |
1673
|
|
|
|
|
|
|
SV *tmp = (SV *) POPs ; |
1674
|
|
|
|
|
|
|
__it->hdrsv = (void*) tmp; |
1675
|
|
|
|
|
|
|
if(tmp != &PL_sv_undef ) |
1676
|
|
|
|
|
|
|
(void)SvREFCNT_inc(tmp); |
1677
|
|
|
|
|
|
|
} |
1678
|
|
|
|
|
|
|
|
1679
|
|
|
|
|
|
|
__it->state |= PDL_HDRCPY; |
1680
|
|
|
|
|
|
|
|
1681
|
|
|
|
|
|
|
FREETMPS ; |
1682
|
|
|
|
|
|
|
LEAVE ; |
1683
|
|
|
|
|
|
|
} |
1684
|
|
|
|
|
|
|
'; |
1685
|
|
|
|
|
|
|
} |
1686
|
|
|
|
|
|
|
} # if: $p2child == 1 |
1687
|
|
|
|
|
|
|
|
1688
|
|
|
|
|
|
|
qq|$type $rout(pdl_trans *__tr $oargs) { |
1689
|
|
|
|
|
|
|
int __dim; |
1690
|
|
|
|
|
|
|
$sname *__privtrans = ($sname *) __tr; |
1691
|
|
|
|
|
|
|
$p2decl |
1692
|
|
|
|
|
|
|
{ |
1693
|
|
|
|
|
|
|
$code |
1694
|
|
|
|
|
|
|
} |
1695
|
|
|
|
|
|
|
} |
1696
|
|
|
|
|
|
|
|; |
1697
|
|
|
|
|
|
|
|
1698
|
|
|
|
|
|
|
} # sub: wrap_vfn() |
1699
|
|
|
|
|
|
|
|
1700
|
|
|
|
|
|
|
sub makesettrans { |
1701
|
|
|
|
|
|
|
my($pnames,$pobjs,$symtab) = @_; |
1702
|
|
|
|
|
|
|
my $trans = $symtab->get_symname('_PDL_ThisTrans'); |
1703
|
|
|
|
|
|
|
my $no=0; |
1704
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, (join '',map { |
1705
|
55
|
|
|
|
|
|
"$trans->pdls[".($no++)."] = $_;\n" |
1706
|
0
|
|
|
|
|
|
} @$pnames). |
1707
|
5
|
|
|
|
|
|
"PDL->make_trans_mutual((pdl_trans *)$trans);\n"); |
1708
|
7
|
|
|
|
|
|
} |
1709
|
42
|
|
|
|
|
|
|
1710
|
1
|
|
|
|
|
|
sub CopyOtherPars { |
1711
|
|
|
|
|
|
|
my($onames,$otypes,$symtab) = @_; my $repr; |
1712
|
|
|
|
|
|
|
my $sname = $symtab->get_symname('_PDL_ThisTrans'); |
1713
|
|
|
|
|
|
|
for(@$onames) { |
1714
|
|
|
|
|
|
|
$repr .= $otypes->{$_}->get_copy("$_","$sname->$_"); |
1715
|
|
|
|
|
|
|
} |
1716
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $repr); |
1717
|
0
|
|
|
|
|
|
} |
1718
|
|
|
|
|
|
|
|
1719
|
|
|
|
|
|
|
sub mkxscat { |
1720
|
|
|
|
|
|
|
my($glb,$xs_c_headers,$hdr,@bits) = @_; |
1721
|
|
|
|
|
|
|
my($boot,$prelude,$str); |
1722
|
|
|
|
|
|
|
if($glb) { |
1723
|
|
|
|
|
|
|
$prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]); |
1724
|
|
|
|
|
|
|
$boot = $xs_c_headers->[3]; |
1725
|
|
|
|
|
|
|
$str = "$hdr\n"; |
1726
|
|
|
|
|
|
|
} else { |
1727
|
|
|
|
|
|
|
my $xscode = join '' => @bits; |
1728
|
|
|
|
|
|
|
$str = "$hdr CODE:\n { $xscode XSRETURN(0);\n}\n\n"; |
1729
|
|
|
|
|
|
|
} |
1730
|
|
|
|
|
|
|
$str =~ s/(\s*\n)+/\n/g; |
1731
|
|
|
|
|
|
|
(PDL::PP::pp_line_numbers(__LINE__, $str),$boot,$prelude) |
1732
|
|
|
|
|
|
|
} |
1733
|
|
|
|
|
|
|
|
1734
|
43
|
|
|
|
|
|
sub mkVarArgsxscat { |
1735
|
|
|
|
|
|
|
my($glb,$xs_c_headers,$hdr,@bits) = @_; |
1736
|
43
|
|
|
|
|
|
my($boot,$prelude,$str); |
1737
|
43
|
|
|
|
|
|
if($glb) { |
1738
|
0
|
|
|
|
|
|
$prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]); |
1739
|
|
|
|
|
|
|
$boot = $xs_c_headers->[3]; |
1740
|
43
|
|
|
|
|
|
$str = "$hdr\n"; |
1741
|
|
|
|
|
|
|
} else { |
1742
|
43
|
|
|
|
|
|
my $xscode = join '' => @bits; |
1743
|
|
|
|
|
|
|
$str = "$hdr \n { $xscode \n}\n\n"; |
1744
|
43
|
0
|
|
|
|
|
} |
1745
|
|
|
|
|
|
|
$str =~ s/(\s*\n)+/\n/g; |
1746
|
43
|
0
|
|
|
|
|
(PDL::PP::pp_line_numbers(__LINE__, $str),$boot,$prelude) |
1747
|
|
|
|
|
|
|
} |
1748
|
1
|
0
|
|
|
|
|
|
1749
|
|
|
|
|
|
|
|
1750
|
|
|
|
|
|
|
sub MakeNows { |
1751
|
|
|
|
|
|
|
my($pnames, $symtab) = @_; |
1752
|
|
|
|
|
|
|
my $str = "\n"; |
1753
|
|
|
|
|
|
|
for(@$pnames) { $str .= "$_ = PDL->make_now($_);\n"; } |
1754
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $str); |
1755
|
|
|
|
|
|
|
} |
1756
|
|
|
|
|
|
|
|
1757
|
|
|
|
|
|
|
sub Sym2Loc { PDL::PP::pp_line_numbers(__LINE__, $_[0]->decl_locals()) } |
1758
|
|
|
|
|
|
|
|
1759
|
|
|
|
|
|
|
sub MkPrivStructInit { |
1760
|
|
|
|
|
|
|
my( $symtab, $vtable, $affflag, $nopdlthread ) = @_; |
1761
|
|
|
|
|
|
|
my $sname = $symtab->get_symname('_PDL_ThisTrans'); |
1762
|
|
|
|
|
|
|
|
1763
|
|
|
|
|
|
|
my $ci = ' '; |
1764
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, |
1765
|
55
|
|
|
|
|
|
"\n${ci}$sname = malloc(sizeof(*$sname)); memset($sname, 0, sizeof(*$sname));\n" . |
1766
|
55
|
|
|
|
|
|
($nopdlthread ? "" : "${ci}PDL_THR_CLRMAGIC(&$sname->__pdlthread);\n") . |
1767
|
55
|
|
|
|
|
|
"${ci}PDL_TR_SETMAGIC($sname);\n" . |
1768
|
55
|
|
|
|
|
|
"${ci}$sname->flags = $affflag;\n" . |
1769
|
55
|
|
|
|
|
|
"${ci}$sname->__ddone = 0;\n" . |
1770
|
55
|
|
|
|
|
|
"${ci}$sname->vtable = &$vtable;\n" . |
1771
|
55
|
|
|
|
|
|
"${ci}$sname->freeproc = PDL->trans_mallocfreeproc;\n") |
1772
|
|
|
|
|
|
|
|
1773
|
|
|
|
|
|
|
} # sub: MkPrivStructInit() |
1774
|
|
|
|
|
|
|
|
1775
|
|
|
|
|
|
|
sub MkDefSyms { |
1776
|
|
|
|
|
|
|
return SymTab->new( |
1777
|
|
|
|
|
|
|
_PDL_ThisTrans => ["__privtrans",C::Type->new(undef,"$_[0] *foo")], |
1778
|
|
|
|
|
|
|
); |
1779
|
|
|
|
|
|
|
} |
1780
|
|
|
|
|
|
|
|
1781
|
|
|
|
|
|
|
sub AddArgsyms { |
1782
|
|
|
|
|
|
|
my($symtab,$args) = @_; |
1783
|
|
|
|
|
|
|
$symtab->add_params( |
1784
|
|
|
|
|
|
|
map {($_->[0],$_->[0])} @$args |
1785
|
|
|
|
|
|
|
); |
1786
|
|
|
|
|
|
|
return $symtab; |
1787
|
|
|
|
|
|
|
} |
1788
|
|
|
|
|
|
|
|
1789
|
|
|
|
|
|
|
sub indent($$) { |
1790
|
|
|
|
|
|
|
my ($text,$ind) = @_; |
1791
|
|
|
|
|
|
|
$text =~ s/^(.*)$/$ind$1/mg; |
1792
|
|
|
|
|
|
|
return $text; |
1793
|
|
|
|
|
|
|
} |
1794
|
|
|
|
|
|
|
|
1795
|
|
|
|
|
|
|
# This subroutine generates the XS code needed to call the perl 'initialize' |
1796
|
|
|
|
|
|
|
# routine in order to create new output PDLs |
1797
|
|
|
|
|
|
|
sub callPerlInit { |
1798
|
|
|
|
|
|
|
my $names = shift; # names of variables to initialize |
1799
|
|
|
|
|
|
|
my $ci = shift; # current indenting |
1800
|
|
|
|
|
|
|
my $callcopy = $#_ > -1 ? shift : 0; |
1801
|
|
|
|
|
|
|
my $ret = ''; |
1802
|
|
|
|
|
|
|
|
1803
|
|
|
|
|
|
|
foreach my $name (@$names) { |
1804
|
|
|
|
|
|
|
unless ($callcopy) { $ret .= << "EOC"} |
1805
|
|
|
|
|
|
|
|
1806
|
|
|
|
|
|
|
if (strcmp(objname,"PDL") == 0) { PDL_COMMENT("shortcut if just PDL") |
1807
|
|
|
|
|
|
|
$name\_SV = sv_newmortal(); |
1808
|
|
|
|
|
|
|
$name = PDL->null(); |
1809
|
|
|
|
|
|
|
PDL->SetSV_PDL($name\_SV,$name); |
1810
|
|
|
|
|
|
|
if (bless_stash) $name\_SV = sv_bless($name\_SV, bless_stash); |
1811
|
|
|
|
|
|
|
} else { |
1812
|
|
|
|
|
|
|
PUSHMARK(SP); |
1813
|
|
|
|
|
|
|
XPUSHs(sv_2mortal(newSVpv(objname, 0))); |
1814
|
|
|
|
|
|
|
PUTBACK; |
1815
|
|
|
|
|
|
|
perl_call_method(\"initialize\", G_SCALAR); |
1816
|
|
|
|
|
|
|
SPAGAIN; |
1817
|
|
|
|
|
|
|
$name\_SV = POPs; |
1818
|
|
|
|
|
|
|
PUTBACK; |
1819
|
|
|
|
|
|
|
$name = PDL->SvPDLV($name\_SV); |
1820
|
|
|
|
|
|
|
} |
1821
|
|
|
|
|
|
|
|
1822
|
|
|
|
|
|
|
EOC |
1823
|
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
|
else { $ret .= << "EOD" } |
1825
|
|
|
|
|
|
|
|
1826
|
|
|
|
|
|
|
if (strcmp(objname,"PDL") == 0) { PDL_COMMENT("shortcut if just PDL") |
1827
|
|
|
|
|
|
|
$name\_SV = sv_newmortal(); |
1828
|
|
|
|
|
|
|
$name = PDL->null(); |
1829
|
|
|
|
|
|
|
PDL->SetSV_PDL($name\_SV,$name); |
1830
|
|
|
|
|
|
|
if (bless_stash) $name\_SV = sv_bless($name\_SV, bless_stash); |
1831
|
|
|
|
|
|
|
} else { |
1832
|
|
|
|
|
|
|
/* XXX should these commented lines be removed? See also a 8 lines down */ |
1833
|
|
|
|
|
|
|
/* warn("possibly relying on deprecated automatic copy call in derived class\n") |
1834
|
|
|
|
|
|
|
warn("please modify your initialize method to avoid future problems\n"); |
1835
|
|
|
|
|
|
|
*/ |
1836
|
|
|
|
|
|
|
PUSHMARK(SP); |
1837
|
|
|
|
|
|
|
XPUSHs(parent); |
1838
|
|
|
|
|
|
|
PUTBACK; |
1839
|
|
|
|
|
|
|
perl_call_method(\"copy\", G_SCALAR); |
1840
|
|
|
|
|
|
|
/* perl_call_method(\"initialize\", G_SCALAR); */ |
1841
|
|
|
|
|
|
|
SPAGAIN; |
1842
|
|
|
|
|
|
|
$name\_SV = POPs; |
1843
|
|
|
|
|
|
|
PUTBACK; |
1844
|
|
|
|
|
|
|
$name = PDL->SvPDLV($name\_SV); |
1845
|
|
|
|
|
|
|
} |
1846
|
|
|
|
|
|
|
EOD |
1847
|
|
|
|
|
|
|
|
1848
|
|
|
|
|
|
|
} # doreach: $name |
1849
|
|
|
|
|
|
|
|
1850
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, indent($ret,$ci)); |
1851
|
12
|
|
|
|
|
|
|
1852
|
24
|
50
|
|
|
|
|
} #sub callPerlInit() |
|
|
50
|
|
|
|
|
|
1853
|
12
|
|
|
|
|
|
|
1854
|
24
|
|
|
|
|
|
# This subroutine is called when no 'otherpars' exist. |
1855
|
19
|
50
|
|
|
|
|
# This writes an XS header which handles variable argument lists, |
|
|
50
|
|
|
|
|
|
1856
|
|
|
|
|
|
|
# thus avoiding the perl layer in calling the routine. D. Hunt 4/11/00 |
1857
|
0
|
0
|
|
|
|
|
# |
|
|
0
|
|
|
|
|
|
1858
|
0
|
0
|
|
|
|
|
# The use of 'DO NOT SET!!' looks ugly. |
|
|
0
|
|
|
|
|
|
1859
|
0
|
|
|
|
|
|
# |
1860
|
0
|
|
|
|
|
|
# Removing useless use of hasp2child in this function. DCM Sept 12, 2011 |
1861
|
0
|
|
|
|
|
|
sub VarArgsXSHdr { |
1862
|
0
|
|
|
|
|
|
my($name,$xsargs,$parobjs,$optypes,#$hasp2child, |
1863
|
0
|
|
|
|
|
|
$pmcode,$hdrcode,$inplacecode,$globalnew,$callcopy,$bitwise) = @_; |
1864
|
12
|
|
|
|
|
|
|
1865
|
|
|
|
|
|
|
# Don't do var args processing if the user has pre-defined pmcode |
1866
|
|
|
|
|
|
|
return 'DO NOT SET!!' if ($pmcode); |
1867
|
|
|
|
|
|
|
|
1868
|
0
|
|
|
|
|
|
# don't generate a HDR if globalnew is set |
1869
|
|
|
|
|
|
|
# globalnew implies internal usage, not XS |
1870
|
|
|
|
|
|
|
return undef if $globalnew; |
1871
|
|
|
|
|
|
|
|
1872
|
|
|
|
|
|
|
my $ci = ' '; # current indenting |
1873
|
|
|
|
|
|
|
my $pars = join "\n",map {$ci.$_->[1]->get_decl($_->[0]).";"} @$xsargs; |
1874
|
|
|
|
|
|
|
|
1875
|
|
|
|
|
|
|
my @args = map { $_->[0] } @$xsargs; |
1876
|
|
|
|
|
|
|
my %out = map { $_ => exists($$parobjs{$_}) |
1877
|
|
|
|
|
|
|
&& exists($$parobjs{$_}{FlagOut}) |
1878
|
|
|
|
|
|
|
&& !exists($$parobjs{$_}{FlagCreateAlways})} |
1879
|
|
|
|
|
|
|
@args; |
1880
|
|
|
|
|
|
|
my %outca = map { $_ => exists($$parobjs{$_}) |
1881
|
|
|
|
|
|
|
&& exists($$parobjs{$_}{FlagOut}) |
1882
|
|
|
|
|
|
|
&& exists($$parobjs{$_}{FlagCreateAlways})} |
1883
|
|
|
|
|
|
|
@args; |
1884
|
|
|
|
|
|
|
my %tmp = map { $_ => exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagTemp}) } @args; |
1885
|
|
|
|
|
|
|
my %other = map { $_ => exists($$optypes{$_}) } @args; |
1886
|
|
|
|
|
|
|
|
1887
|
|
|
|
|
|
|
# remember, othervars *are* input vars |
1888
|
|
|
|
|
|
|
my $nout = (grep { $_ } values %out); |
1889
|
|
|
|
|
|
|
my $noutca = (grep { $_ } values %outca); |
1890
|
|
|
|
|
|
|
my $nother = (grep { $_ } values %other); |
1891
|
|
|
|
|
|
|
my $ntmp = (grep { $_ } values %tmp); |
1892
|
|
|
|
|
|
|
my $ntot = @args; |
1893
|
|
|
|
|
|
|
my $nmaxonstack = $ntot - $noutca; |
1894
|
|
|
|
|
|
|
my $nin = $ntot - ($nout + $noutca + $ntmp); |
1895
|
|
|
|
|
|
|
my $ninout = $nin + $nout; |
1896
|
|
|
|
|
|
|
my $nallout = $nout + $noutca; |
1897
|
|
|
|
|
|
|
my $usageargs = join (",", @args); |
1898
|
|
|
|
|
|
|
|
1899
|
|
|
|
|
|
|
$ci = ' '; # Current indenting |
1900
|
|
|
|
|
|
|
|
1901
|
|
|
|
|
|
|
# Generate declarations for SV * variables corresponding to pdl * output variables. |
1902
|
|
|
|
|
|
|
# These are used in creating output and temp variables. One variable (ex: SV * outvar1_SV;) |
1903
|
|
|
|
|
|
|
# is needed for each output and output create always argument |
1904
|
|
|
|
|
|
|
my $svdecls = join ("\n", map { "${ci}SV *${_}_SV;" } grep { $out{$_} || $outca{$_} || $tmp{$_} } @args); |
1905
|
|
|
|
|
|
|
|
1906
|
|
|
|
|
|
|
my @create = (); # The names of variables which need to be created by calling |
1907
|
|
|
|
|
|
|
# the 'initialize' perl routine from the correct package. |
1908
|
|
|
|
|
|
|
|
1909
|
|
|
|
|
|
|
$ci = ' '; # Current indenting |
1910
|
|
|
|
|
|
|
|
1911
|
|
|
|
|
|
|
# clause for reading in all variables |
1912
|
|
|
|
|
|
|
my $clause1 = ''; my $cnt = 0; |
1913
|
|
|
|
|
|
|
foreach my $i ( 0 .. $#args ) { |
1914
|
|
|
|
|
|
|
my $x = $args[$i]; |
1915
|
|
|
|
|
|
|
if ($other{$x}) { # other par |
1916
|
|
|
|
|
|
|
$clause1 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n"; |
1917
|
|
|
|
|
|
|
$cnt++; |
1918
|
|
|
|
|
|
|
} elsif ($outca{$x}) { |
1919
|
|
|
|
|
|
|
push (@create, $x); |
1920
|
|
|
|
|
|
|
} else { |
1921
|
|
|
|
|
|
|
$clause1 .= "$ci$x = PDL->SvPDLV(ST($cnt));\n"; |
1922
|
|
|
|
|
|
|
$cnt++; |
1923
|
|
|
|
|
|
|
} |
1924
|
|
|
|
|
|
|
} |
1925
|
|
|
|
|
|
|
|
1926
|
|
|
|
|
|
|
# Add code for creating output variables via call to 'initialize' perl routine |
1927
|
|
|
|
|
|
|
$clause1 .= callPerlInit (\@create, $ci, $callcopy); |
1928
|
|
|
|
|
|
|
@create = (); |
1929
|
|
|
|
|
|
|
|
1930
|
|
|
|
|
|
|
# clause for reading in input and output vars and creating temps |
1931
|
|
|
|
|
|
|
my $clause2; |
1932
|
|
|
|
|
|
|
# skip this clause if there are no temps |
1933
|
|
|
|
|
|
|
if ($nmaxonstack == $ninout) { |
1934
|
|
|
|
|
|
|
$clause2 = ''; |
1935
|
|
|
|
|
|
|
} else { |
1936
|
|
|
|
|
|
|
$clause2 = "\n else if (items == $ninout) { PDL_COMMENT(\"all but temps on stack, read in output, create temps\")" . |
1937
|
|
|
|
|
|
|
" nreturn = $noutca;\n"; |
1938
|
|
|
|
|
|
|
|
1939
|
|
|
|
|
|
|
$cnt = 0; |
1940
|
|
|
|
|
|
|
foreach my $i ( 0 .. $#args ) { |
1941
|
|
|
|
|
|
|
my $x = $args[$i]; |
1942
|
|
|
|
|
|
|
if ($other{$x}) { |
1943
|
|
|
|
|
|
|
$clause2 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n"; |
1944
|
|
|
|
|
|
|
$cnt++; |
1945
|
|
|
|
|
|
|
} elsif ($tmp{$x} || $outca{$x}) { |
1946
|
|
|
|
|
|
|
# a temporary or always create variable |
1947
|
|
|
|
|
|
|
push (@create, $x); |
1948
|
|
|
|
|
|
|
} else { # an input or output variable |
1949
|
|
|
|
|
|
|
$clause2 .= "$ci$x = PDL->SvPDLV(ST($cnt));\n"; |
1950
|
|
|
|
|
|
|
$cnt++; |
1951
|
|
|
|
|
|
|
} |
1952
|
|
|
|
|
|
|
} |
1953
|
|
|
|
|
|
|
|
1954
|
|
|
|
|
|
|
# Add code for creating output variables via call to 'initialize' perl routine |
1955
|
|
|
|
|
|
|
$clause2 .= callPerlInit (\@create, $ci, $callcopy); |
1956
|
|
|
|
|
|
|
$clause2 .= "}\n"; |
1957
|
|
|
|
|
|
|
@create = (); |
1958
|
|
|
|
|
|
|
|
1959
|
|
|
|
|
|
|
} |
1960
|
|
|
|
|
|
|
|
1961
|
|
|
|
|
|
|
# clause for reading in input and creating output and temp vars |
1962
|
|
|
|
|
|
|
my $clause3 = ''; |
1963
|
|
|
|
|
|
|
$cnt = 0; |
1964
|
|
|
|
|
|
|
foreach my $i ( 0 .. $#args ) { |
1965
|
|
|
|
|
|
|
my $x = $args[$i]; |
1966
|
|
|
|
|
|
|
if ($other{$x}) { |
1967
|
|
|
|
|
|
|
$clause3 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n"; |
1968
|
|
|
|
|
|
|
$cnt++; |
1969
|
|
|
|
|
|
|
} elsif ($out{$x} || $tmp{$x} || $outca{$x}) { |
1970
|
|
|
|
|
|
|
push (@create, $x); |
1971
|
|
|
|
|
|
|
} else { |
1972
|
|
|
|
|
|
|
$clause3 .= "$ci$x = PDL->SvPDLV(ST($cnt));\n"; |
1973
|
|
|
|
|
|
|
$cnt++; |
1974
|
|
|
|
|
|
|
} |
1975
|
|
|
|
|
|
|
} |
1976
|
|
|
|
|
|
|
|
1977
|
|
|
|
|
|
|
# Add code for creating output variables via call to 'initialize' perl routine |
1978
|
|
|
|
|
|
|
$clause3 .= callPerlInit (\@create, $ci, $callcopy); @create = (); |
1979
|
|
|
|
|
|
|
|
1980
|
|
|
|
|
|
|
# Bitwise ops may get five args |
1981
|
|
|
|
|
|
|
my $bitwise_cond = $bitwise ? " || items == 5" : ''; |
1982
|
|
|
|
|
|
|
|
1983
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, <
|
1984
|
|
|
|
|
|
|
|
1985
|
|
|
|
|
|
|
void |
1986
|
12
|
|
|
|
|
|
$name(...) |
1987
|
|
|
|
|
|
|
PREINIT: |
1988
|
12
|
|
|
|
|
|
char *objname = "PDL"; /* XXX maybe that class should actually depend on the value set |
1989
|
|
|
|
|
|
|
by pp_bless ? (CS) */ |
1990
|
|
|
|
|
|
|
HV *bless_stash = 0; |
1991
|
12
|
|
|
|
|
|
SV *parent = 0; |
1992
|
|
|
|
|
|
|
int nreturn; |
1993
|
|
|
|
|
|
|
$svdecls |
1994
|
|
|
|
|
|
|
$pars |
1995
|
|
|
|
|
|
|
|
1996
|
|
|
|
|
|
|
PPCODE: |
1997
|
|
|
|
|
|
|
|
1998
|
|
|
|
|
|
|
{ |
1999
|
|
|
|
|
|
|
PDL_COMMENT("Check if you can get a package name for this input value. ") |
2000
|
|
|
|
|
|
|
PDL_COMMENT("It can be either a PDL (SVt_PVMG) or a hash which is a ") |
2001
|
|
|
|
|
|
|
PDL_COMMENT("derived PDL subclass (SVt_PVHV) ") |
2002
|
|
|
|
|
|
|
|
2003
|
|
|
|
|
|
|
if (SvROK(ST(0)) && ((SvTYPE(SvRV(ST(0))) == SVt_PVMG) || (SvTYPE(SvRV(ST(0))) == SVt_PVHV))) { |
2004
|
|
|
|
|
|
|
parent = ST(0); |
2005
|
|
|
|
|
|
|
if (sv_isobject(parent)){ |
2006
|
|
|
|
|
|
|
bless_stash = SvSTASH(SvRV(ST(0))); |
2007
|
|
|
|
|
|
|
objname = HvNAME((bless_stash)); PDL_COMMENT("The package to bless output vars into is taken from the first input var") |
2008
|
|
|
|
|
|
|
} |
2009
|
|
|
|
|
|
|
} |
2010
|
|
|
|
|
|
|
if (items == $nmaxonstack) { PDL_COMMENT("all variables on stack, read in output and temp vars") |
2011
|
|
|
|
|
|
|
nreturn = $noutca; |
2012
|
|
|
|
|
|
|
$clause1 |
2013
|
|
|
|
|
|
|
} |
2014
|
|
|
|
|
|
|
$clause2 |
2015
|
|
|
|
|
|
|
else if (items == $nin$bitwise_cond) { PDL_COMMENT("only input variables on stack, create outputs and temps") |
2016
|
|
|
|
|
|
|
nreturn = $nallout; |
2017
|
|
|
|
|
|
|
$clause3 |
2018
|
|
|
|
|
|
|
} |
2019
|
|
|
|
|
|
|
|
2020
|
|
|
|
|
|
|
else { |
2021
|
|
|
|
|
|
|
croak (\"Usage: PDL::$name($usageargs) (you may leave temporaries or output variables out of list)\"); |
2022
|
|
|
|
|
|
|
} |
2023
|
|
|
|
|
|
|
} |
2024
|
|
|
|
|
|
|
{ |
2025
|
|
|
|
|
|
|
$hdrcode |
2026
|
|
|
|
|
|
|
$inplacecode |
2027
|
|
|
|
|
|
|
} |
2028
|
|
|
|
|
|
|
END |
2029
|
|
|
|
|
|
|
|
2030
|
|
|
|
|
|
|
} # sub: VarArgsXSHdr() |
2031
|
|
|
|
|
|
|
|
2032
|
|
|
|
|
|
|
# This subroutine produces the code which returns output variables |
2033
|
|
|
|
|
|
|
# or leaves them as modified input variables. D. Hunt 4/10/00 |
2034
|
|
|
|
|
|
|
sub VarArgsXSReturn { |
2035
|
|
|
|
|
|
|
my($xsargs, $parobjs, $globalnew ) = @_; |
2036
|
|
|
|
|
|
|
|
2037
|
|
|
|
|
|
|
# don't generate a HDR if globalnew is set |
2038
|
|
|
|
|
|
|
# globalnew implies internal usage, not XS |
2039
|
|
|
|
|
|
|
return undef if $globalnew; |
2040
|
|
|
|
|
|
|
|
2041
|
|
|
|
|
|
|
# names of output variables (in calling order) |
2042
|
|
|
|
|
|
|
my @outs; |
2043
|
|
|
|
|
|
|
|
2044
|
|
|
|
|
|
|
# beware of existance tests like this: $$parobjs{$arg->[0]}{FlagOut} ! |
2045
|
|
|
|
|
|
|
# this will cause $$parobjs{$arg->[0]} to spring into existance even if $$parobjs{$arg->[0]}{FlagOut} |
2046
|
|
|
|
|
|
|
# does not exist!! |
2047
|
|
|
|
|
|
|
foreach my $arg (@$xsargs) { |
2048
|
|
|
|
|
|
|
my $x = $arg->[0]; |
2049
|
|
|
|
|
|
|
push (@outs, $x) if (exists ($$parobjs{$x}) and exists ($$parobjs{$x}{FlagOut})); |
2050
|
|
|
|
|
|
|
} |
2051
|
|
|
|
|
|
|
|
2052
|
|
|
|
|
|
|
my $ci = ' '; # Current indenting |
2053
|
|
|
|
|
|
|
|
2054
|
|
|
|
|
|
|
my $clause1 = ''; |
2055
|
|
|
|
|
|
|
foreach my $i ( 0 .. $#outs ) { |
2056
|
|
|
|
|
|
|
$clause1 .= ($ci x 2) . "ST($i) = $outs[$i]_SV;\n"; |
2057
|
|
|
|
|
|
|
} |
2058
|
|
|
|
|
|
|
|
2059
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, <<"END") |
2060
|
12
|
50
|
|
|
|
|
${ci}if (nreturn) { |
|
|
50
|
|
|
|
|
|
2061
|
12
|
50
|
|
|
|
|
${ci} if (nreturn > 0) EXTEND (SP, nreturn ); |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2062
|
12
|
|
|
|
|
|
$clause1 |
2063
|
12
|
|
|
|
|
|
${ci} XSRETURN(nreturn); |
2064
|
|
|
|
|
|
|
${ci}} else { |
2065
|
0
|
|
|
|
|
|
${ci} XSRETURN(0); |
2066
|
|
|
|
|
|
|
${ci}} |
2067
|
|
|
|
|
|
|
END |
2068
|
|
|
|
|
|
|
|
2069
|
|
|
|
|
|
|
} # sub: VarArgsXSReturn() |
2070
|
|
|
|
|
|
|
|
2071
|
|
|
|
|
|
|
|
2072
|
|
|
|
|
|
|
sub XSCHdrs { |
2073
|
|
|
|
|
|
|
my($name,$pars,$gname) = @_; |
2074
|
|
|
|
|
|
|
# Hmmm, do we need $shortpars at all? |
2075
|
|
|
|
|
|
|
#my $shortpars = join ',',map {$_->[0]} @$pars; |
2076
|
|
|
|
|
|
|
my $longpars = join ",",map {$_->[1]->get_decl($_->[0])} @$pars; |
2077
|
|
|
|
|
|
|
return ["void $name($longpars) {","}","", |
2078
|
|
|
|
|
|
|
"PDL->$gname = $name;"]; |
2079
|
|
|
|
|
|
|
} |
2080
|
|
|
|
|
|
|
|
2081
|
|
|
|
|
|
|
# abstract the access to the bad value status |
2082
|
|
|
|
|
|
|
# - means we can easily change the representation without too |
2083
|
|
|
|
|
|
|
# many changes |
2084
|
|
|
|
|
|
|
# |
2085
|
|
|
|
|
|
|
# it's also used in one place in PP/PDLCode.pm |
2086
|
|
|
|
|
|
|
# -- there it's hard-coded |
2087
|
|
|
|
|
|
|
# |
2088
|
|
|
|
|
|
|
sub set_badflag { PDL::PP::pp_line_numbers(__LINE__, '$PRIV(bvalflag) = 1;' . "\n") } |
2089
|
0
|
|
|
|
|
|
sub clear_badflag { PDL::PP::pp_line_numbers(__LINE__, '$PRIV(bvalflag) = 0;' . "\n") } |
2090
|
55
|
|
|
|
|
|
sub get_badflag { PDL::PP::pp_line_numbers(__LINE__, '$PRIV(bvalflag)') } |
2091
|
|
|
|
|
|
|
|
2092
|
|
|
|
|
|
|
sub get_badflag_priv { PDL::PP::pp_line_numbers(__LINE__, '$PRIV(bvalflag)') } |
2093
|
|
|
|
|
|
|
|
2094
|
|
|
|
|
|
|
sub set_badstate { |
2095
|
|
|
|
|
|
|
my $pdl = shift; |
2096
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, "\$SETPDLSTATEBAD($pdl)") |
2097
|
|
|
|
|
|
|
} |
2098
|
|
|
|
|
|
|
|
2099
|
|
|
|
|
|
|
sub clear_badstate { |
2100
|
|
|
|
|
|
|
my $pdl = shift; |
2101
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, "\$SETPDLSTATEGOOD($pdl)") |
2102
|
|
|
|
|
|
|
} |
2103
|
|
|
|
|
|
|
|
2104
|
|
|
|
|
|
|
sub get_badstate { |
2105
|
|
|
|
|
|
|
my $pdl = shift; |
2106
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, "\$ISPDLSTATEBAD($pdl)") |
2107
|
|
|
|
|
|
|
} |
2108
|
|
|
|
|
|
|
|
2109
|
|
|
|
|
|
|
# checks the input piddles to see if the routine |
2110
|
|
|
|
|
|
|
# is being any data containing bad values |
2111
|
|
|
|
|
|
|
# |
2112
|
|
|
|
|
|
|
# if FindBadStatusCode is set, use it, |
2113
|
|
|
|
|
|
|
# otherwise create the code automatically. |
2114
|
|
|
|
|
|
|
# |
2115
|
|
|
|
|
|
|
# - in the automatic code creation, |
2116
|
|
|
|
|
|
|
# if $badflag is 0, rather than being undefined, then |
2117
|
|
|
|
|
|
|
# we issue a warning if any piddles contain bad values |
2118
|
|
|
|
|
|
|
# (and set the bvalflag to 0) |
2119
|
|
|
|
|
|
|
# |
2120
|
|
|
|
|
|
|
# XXX it looks like output piddles are included in the |
2121
|
|
|
|
|
|
|
# check. I *think* this is just wasted code, but I'm |
2122
|
|
|
|
|
|
|
# not sure. |
2123
|
|
|
|
|
|
|
# |
2124
|
|
|
|
|
|
|
sub findbadstatus { |
2125
|
|
|
|
|
|
|
my ( $badflag, $badcode, $xsargs, $parobjs, $optypes, $symtab, $name ) = @_; |
2126
|
|
|
|
|
|
|
return '' unless $bvalflag; |
2127
|
|
|
|
|
|
|
|
2128
|
|
|
|
|
|
|
return PDL::PP::pp_line_numbers(__LINE__, $badcode) if defined $badcode; |
2129
|
|
|
|
|
|
|
|
2130
|
|
|
|
|
|
|
my $sname = $symtab->get_symname('_PDL_ThisTrans'); |
2131
|
|
|
|
|
|
|
|
2132
|
|
|
|
|
|
|
my @args = map { $_->[0] } @$xsargs; |
2133
|
|
|
|
|
|
|
my %out = map { |
2134
|
|
|
|
|
|
|
$_ => |
2135
|
|
|
|
|
|
|
exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagOut}) |
2136
|
|
|
|
|
|
|
&& !exists($$parobjs{$_}{FlagCreateAlways}) |
2137
|
|
|
|
|
|
|
} @args; |
2138
|
|
|
|
|
|
|
my %outca = map { |
2139
|
|
|
|
|
|
|
$_ => |
2140
|
|
|
|
|
|
|
exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagOut}) |
2141
|
|
|
|
|
|
|
&& exists($$parobjs{$_}{FlagCreateAlways}) |
2142
|
|
|
|
|
|
|
} @args; |
2143
|
|
|
|
|
|
|
my %tmp = map { |
2144
|
|
|
|
|
|
|
$_ => |
2145
|
|
|
|
|
|
|
exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagTemp}) |
2146
|
|
|
|
|
|
|
} @args; |
2147
|
|
|
|
|
|
|
my %other = map { $_ => exists($$optypes{$_}) } @args; |
2148
|
|
|
|
|
|
|
|
2149
|
|
|
|
|
|
|
my $clear_bad = clear_badflag(); |
2150
|
|
|
|
|
|
|
my $set_bad = set_badflag(); |
2151
|
|
|
|
|
|
|
my $get_bad = get_badflag(); |
2152
|
|
|
|
|
|
|
|
2153
|
|
|
|
|
|
|
my $str = $clear_bad; |
2154
|
|
|
|
|
|
|
|
2155
|
|
|
|
|
|
|
# set the badflag_cache variable if any input piddle has the bad flag set |
2156
|
|
|
|
|
|
|
# |
2157
|
|
|
|
|
|
|
my $add = 0; |
2158
|
|
|
|
|
|
|
my $badflag_str = " \$BADFLAGCACHE() = "; |
2159
|
|
|
|
|
|
|
foreach my $i ( 0 .. $#args ) { |
2160
|
|
|
|
|
|
|
my $x = $args[$i]; |
2161
|
|
|
|
|
|
|
unless ( $other{$x} or $out{$x} or $tmp{$x} or $outca{$x}) { |
2162
|
|
|
|
|
|
|
if ($add) { $badflag_str .= " || "; } |
2163
|
|
|
|
|
|
|
else { $add = 1; } |
2164
|
|
|
|
|
|
|
$badflag_str .= get_badstate($args[$i]); |
2165
|
|
|
|
|
|
|
} |
2166
|
|
|
|
|
|
|
} |
2167
|
|
|
|
|
|
|
|
2168
|
|
|
|
|
|
|
# It is possible, at present, for $add to be 0. I think this is when |
2169
|
|
|
|
|
|
|
# the routine has no input piddles, such as fibonacci in primitive.pd, |
2170
|
|
|
|
|
|
|
# but there may be other cases. These routines could/should (?) |
2171
|
|
|
|
|
|
|
# be marked as NoBadCode to avoid this, or maybe the code here made |
2172
|
|
|
|
|
|
|
# smarter. Left as is for now as do not want to add instability into |
2173
|
|
|
|
|
|
|
# the 2.4.3 release if I can help it - DJB 23 Jul 2006 |
2174
|
|
|
|
|
|
|
# |
2175
|
|
|
|
|
|
|
if ($add != 0) { |
2176
|
|
|
|
|
|
|
$str .= $badflag_str . ";\n if (\$BADFLAGCACHE()) ${set_bad}\n"; |
2177
|
|
|
|
|
|
|
} else { |
2178
|
|
|
|
|
|
|
print "\nNOTE: $name has no input bad piddles.\n\n" if $::PP_VERBOSE; |
2179
|
|
|
|
|
|
|
} |
2180
|
|
|
|
|
|
|
|
2181
|
|
|
|
|
|
|
if ( defined($badflag) and $badflag == 0 ) { |
2182
|
|
|
|
|
|
|
$str .= |
2183
|
|
|
|
|
|
|
" if ( $get_bad ) { |
2184
|
|
|
|
|
|
|
printf(\"WARNING: $name does not handle bad values.\\n\"); |
2185
|
|
|
|
|
|
|
$clear_bad |
2186
|
|
|
|
|
|
|
}\n"; |
2187
|
|
|
|
|
|
|
print "\nNOTE: $name does not handle bad values.\n\n" if $::PP_VERBOSE; |
2188
|
|
|
|
|
|
|
} # if: $badflag |
2189
|
|
|
|
|
|
|
|
2190
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $str) |
2191
|
|
|
|
|
|
|
|
2192
|
|
|
|
|
|
|
} # sub: findbadstatus |
2193
|
|
|
|
|
|
|
|
2194
|
|
|
|
|
|
|
|
2195
|
|
|
|
|
|
|
# copies over the bad value state to the output piddles |
2196
|
|
|
|
|
|
|
# |
2197
|
|
|
|
|
|
|
# if CopyBadStatusCode is set, use it, |
2198
|
|
|
|
|
|
|
# otherwise create the code automatically. |
2199
|
|
|
|
|
|
|
# |
2200
|
|
|
|
|
|
|
# note: this is executed before the trans_mutual call |
2201
|
|
|
|
|
|
|
# is made, since the state may be changed by the |
2202
|
|
|
|
|
|
|
# Code section |
2203
|
|
|
|
|
|
|
# |
2204
|
|
|
|
|
|
|
sub copybadstatus { |
2205
|
|
|
|
|
|
|
my ( $badflag, $badcode, $xsargs, $parobjs, $symtab ) = @_; |
2206
|
|
|
|
|
|
|
## return '' unless $bvalflag or $badflag == 0; |
2207
|
|
|
|
|
|
|
return '' unless $bvalflag; |
2208
|
|
|
|
|
|
|
|
2209
|
|
|
|
|
|
|
if (defined $badcode) { |
2210
|
|
|
|
|
|
|
# realised in 2.4.3 testing that use of $PRIV at this stage is |
2211
|
|
|
|
|
|
|
# dangerous since it may have been freed. So I introduced the |
2212
|
|
|
|
|
|
|
# $BFLACACHE variable which stores the $PRIV(bvalflag) value |
2213
|
|
|
|
|
|
|
# for use here. |
2214
|
|
|
|
|
|
|
# For now make the substitution automatic but it will likely become an |
2215
|
|
|
|
|
|
|
# error to use $PRIV(bvalflag) here. |
2216
|
|
|
|
|
|
|
# |
2217
|
|
|
|
|
|
|
if ($badcode =~ m/\$PRIV(bvalflag)/) { |
2218
|
|
|
|
|
|
|
$badcode =~ s/\$PRIV(bvalflag)/\$BADFLAGCACHE()/; |
2219
|
|
|
|
|
|
|
print "\nPDL::PP WARNING: copybadstatus contains '\$PRIV(bvalflag)'; replace with \$BADFLAGCACHE()\n\n"; |
2220
|
|
|
|
|
|
|
} |
2221
|
|
|
|
|
|
|
return PDL::PP::pp_line_numbers(__LINE__, $badcode); |
2222
|
|
|
|
|
|
|
} |
2223
|
|
|
|
|
|
|
|
2224
|
|
|
|
|
|
|
# names of output variables (in calling order) |
2225
|
|
|
|
|
|
|
my @outs; |
2226
|
|
|
|
|
|
|
|
2227
|
|
|
|
|
|
|
# beware of existance tests like this: $$parobjs{$arg->[0]}{FlagOut} ! |
2228
|
|
|
|
|
|
|
# this will cause $$parobjs{$arg->[0]} to spring into existance even if $$parobjs{$arg->[0]}{FlagOut} |
2229
|
|
|
|
|
|
|
# does not exist!! |
2230
|
|
|
|
|
|
|
foreach my $arg (@$xsargs) { |
2231
|
|
|
|
|
|
|
my $x = $arg->[0]; |
2232
|
|
|
|
|
|
|
push (@outs, $x) if (exists ($$parobjs{$x}) and exists ($$parobjs{$x}{FlagOut})); |
2233
|
|
|
|
|
|
|
} |
2234
|
|
|
|
|
|
|
|
2235
|
|
|
|
|
|
|
my $sname = $symtab->get_symname('_PDL_ThisTrans'); |
2236
|
|
|
|
|
|
|
my $str = ''; |
2237
|
|
|
|
|
|
|
|
2238
|
|
|
|
|
|
|
# It appears that some code in Bad.xs sets the cache value but then |
2239
|
|
|
|
|
|
|
# this bit of code never gets called. Is this an efficiency issue (ie |
2240
|
|
|
|
|
|
|
# should we try and optimise away those ocurrences) or does it perform |
2241
|
|
|
|
|
|
|
# some purpose? |
2242
|
|
|
|
|
|
|
# |
2243
|
|
|
|
|
|
|
$str = "if (\$BADFLAGCACHE()) {\n"; |
2244
|
|
|
|
|
|
|
foreach my $arg ( @outs ) { |
2245
|
|
|
|
|
|
|
$str .= " " . set_badstate($arg) . ";\n"; |
2246
|
|
|
|
|
|
|
} |
2247
|
|
|
|
|
|
|
$str .= "}\n"; |
2248
|
|
|
|
|
|
|
|
2249
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $str); |
2250
|
55
|
|
|
|
|
|
|
2251
|
|
|
|
|
|
|
} # sub: copybadstatus() |
2252
|
|
|
|
|
|
|
|
2253
|
|
|
|
|
|
|
# insert code, after the autogenerated xs argument processing code |
2254
|
|
|
|
|
|
|
# produced by VarArgsXSHdr and AFTER any in HdrCode |
2255
|
|
|
|
|
|
|
# - this code flags the routine as working inplace, |
2256
|
|
|
|
|
|
|
# |
2257
|
|
|
|
|
|
|
# Inplace can be supplied several values |
2258
|
|
|
|
|
|
|
# => 1 |
2259
|
|
|
|
|
|
|
# assumes fn has an inout and output piddle (eg 'a(); [o] b();') |
2260
|
|
|
|
|
|
|
# |
2261
|
|
|
|
|
|
|
# => [ 'a' ] |
2262
|
|
|
|
|
|
|
# assumes several input piddles in sig, so 'a' labels which |
2263
|
|
|
|
|
|
|
# one is to be marked inplace |
2264
|
|
|
|
|
|
|
# |
2265
|
|
|
|
|
|
|
# => [ 'a', 'b' ] |
2266
|
|
|
|
|
|
|
# input piddle is a(), output pidle is 'b' |
2267
|
|
|
|
|
|
|
# |
2268
|
|
|
|
|
|
|
sub InplaceCode { |
2269
|
|
|
|
|
|
|
my ( $ppname, $xsargs, $parobjs, $arg ) = @_; |
2270
|
|
|
|
|
|
|
return '' unless defined $arg; |
2271
|
|
|
|
|
|
|
|
2272
|
|
|
|
|
|
|
# find input and output piddles |
2273
|
|
|
|
|
|
|
my ( @in, @out ); |
2274
|
|
|
|
|
|
|
foreach my $arg (@$xsargs) { |
2275
|
|
|
|
|
|
|
my $name = $arg->[0]; |
2276
|
|
|
|
|
|
|
if ( exists $$parobjs{$name} ) { |
2277
|
|
|
|
|
|
|
if ( exists $$parobjs{$name}{FlagOut} ) { |
2278
|
|
|
|
|
|
|
push @out, $name; |
2279
|
|
|
|
|
|
|
} elsif ( ! exists $$parobjs{$name}{FlagTemp} ) { |
2280
|
|
|
|
|
|
|
push @in, $name; |
2281
|
|
|
|
|
|
|
} |
2282
|
|
|
|
|
|
|
} |
2283
|
|
|
|
|
|
|
} |
2284
|
|
|
|
|
|
|
|
2285
|
|
|
|
|
|
|
# handle different values of arg |
2286
|
|
|
|
|
|
|
my ( $in, $out ); |
2287
|
|
|
|
|
|
|
|
2288
|
|
|
|
|
|
|
# default vals - only set if we have one input/output piddle |
2289
|
|
|
|
|
|
|
$in = $in[0] if $#in == 0; |
2290
|
|
|
|
|
|
|
$out = $out[0] if $#out == 0; |
2291
|
|
|
|
|
|
|
|
2292
|
|
|
|
|
|
|
if ( ref($arg) eq "ARRAY" ) { |
2293
|
|
|
|
|
|
|
my $narg = $#$arg; |
2294
|
|
|
|
|
|
|
if ( $narg > -1 ) { |
2295
|
|
|
|
|
|
|
$in = $$arg[0]; |
2296
|
|
|
|
|
|
|
$out = $$arg[1] if $narg > 0; |
2297
|
|
|
|
|
|
|
} |
2298
|
|
|
|
|
|
|
} elsif ( ref($arg) eq "" ) { |
2299
|
|
|
|
|
|
|
return '' unless $arg; |
2300
|
|
|
|
|
|
|
# use default values |
2301
|
|
|
|
|
|
|
} else { |
2302
|
|
|
|
|
|
|
die "ERROR: Inplace rule [$ppname] must be sent either an array ref or a scalar.\n"; |
2303
|
|
|
|
|
|
|
} |
2304
|
|
|
|
|
|
|
|
2305
|
|
|
|
|
|
|
die "ERROR: Inplace [$ppname] does not know name of input piddle\n" |
2306
|
|
|
|
|
|
|
unless defined $in; |
2307
|
|
|
|
|
|
|
die "ERROR: Inplace [$ppname] does not know name of output piddle\n" |
2308
|
|
|
|
|
|
|
unless defined $out; |
2309
|
|
|
|
|
|
|
|
2310
|
|
|
|
|
|
|
my $instate = $in . "->state"; |
2311
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, |
2312
|
|
|
|
|
|
|
qq{\tif ( $instate & PDL_INPLACE && ($out != $in)) { |
2313
|
|
|
|
|
|
|
$instate &= ~PDL_INPLACE; PDL_COMMENT("unset") |
2314
|
|
|
|
|
|
|
$out = $in; PDL_COMMENT("discard output value, leak ?") |
2315
|
|
|
|
|
|
|
PDL->SetSV_PDL(${out}_SV,${out}); |
2316
|
|
|
|
|
|
|
}}) |
2317
|
|
|
|
|
|
|
|
2318
|
|
|
|
|
|
|
} # sub: InplaceCode |
2319
|
|
|
|
|
|
|
|
2320
|
|
|
|
|
|
|
# If there is an EquivCPOffsCOde and: |
2321
|
|
|
|
|
|
|
# no bad-value support ==> use that |
2322
|
|
|
|
|
|
|
# bad value support ==> write a bit of code that does |
2323
|
|
|
|
|
|
|
# if ( $PRIV(bvalflag) ) { bad-EquivCPOffsCode } |
2324
|
|
|
|
|
|
|
# else { good-EquivCPOffsCode } |
2325
|
|
|
|
|
|
|
# |
2326
|
|
|
|
|
|
|
# Note: since EquivCPOffsCOde doesn't (or I haven't seen any that |
2327
|
|
|
|
|
|
|
# do) use 'loop %{' or 'threadloop %{', we can't rely on |
2328
|
|
|
|
|
|
|
# PDLCode to automatically write code like above, hence the |
2329
|
|
|
|
|
|
|
# explicit definition here. |
2330
|
|
|
|
|
|
|
# |
2331
|
|
|
|
|
|
|
# Note: I *assume* that bad-Equiv..Code == good-Equiv..Code *EXCEPT* |
2332
|
|
|
|
|
|
|
# that we re-define the meaning of the $EQUIVCPOFFS macro to |
2333
|
|
|
|
|
|
|
# check for bad values when copying things over. |
2334
|
|
|
|
|
|
|
# This means having to write less code. |
2335
|
|
|
|
|
|
|
# |
2336
|
|
|
|
|
|
|
# Since PARENT & CHILD need NOT be the same type we cannot just copy |
2337
|
|
|
|
|
|
|
# values from one to the other - we have to check for the presence |
2338
|
|
|
|
|
|
|
# of bad values, hence the expansion for the $bad code |
2339
|
|
|
|
|
|
|
# |
2340
|
|
|
|
|
|
|
# Some operators (notably range) also have an out-of-range flag; they use |
2341
|
|
|
|
|
|
|
# the macro EQUIVCPTRUNC instead of EQUIVCPOFFS. |
2342
|
|
|
|
|
|
|
# $EQUIVCPTRUNC does the same as EQUIVCPOFFS but accepts a child-out-of-bounds |
2343
|
|
|
|
|
|
|
# flag. If the out-of-bounds flag is set, the forward code puts BAD/0 into |
2344
|
|
|
|
|
|
|
# the child, and reverse code refrains from copying. |
2345
|
|
|
|
|
|
|
# --CED 27-Jan-2003 |
2346
|
|
|
|
|
|
|
# |
2347
|
|
|
|
|
|
|
# sent [EquivCPOffsCode,BadFlag] |
2348
|
|
|
|
|
|
|
|
2349
|
|
|
|
|
|
|
# |
2350
|
|
|
|
|
|
|
# NOTE: EQUIVCPOFFS and EQUIVCPTRUNC both suffer from the macro-block |
2351
|
|
|
|
|
|
|
# wart of C preprocessing. They look like statements but sometimes |
2352
|
|
|
|
|
|
|
# process into blocks, so if/then/else constructs can get broken. |
2353
|
|
|
|
|
|
|
# Either (1) use blocks for if/then/else, or (2) get excited and |
2354
|
|
|
|
|
|
|
# use the "do {BLOCK} while(0)" block-to-statement conversion construct |
2355
|
|
|
|
|
|
|
# in the substitution. I'm too Lazy. --CED 27-Jan-2003 |
2356
|
|
|
|
|
|
|
# |
2357
|
|
|
|
|
|
|
sub CodefromEquivCPOffsCode { |
2358
|
|
|
|
|
|
|
my $good = shift; |
2359
|
|
|
|
|
|
|
my $bflag = shift; |
2360
|
|
|
|
|
|
|
|
2361
|
|
|
|
|
|
|
my $bad = $good; |
2362
|
|
|
|
|
|
|
|
2363
|
|
|
|
|
|
|
# parse 'good' code |
2364
|
|
|
|
|
|
|
$good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = \$PP(PARENT)[$2]/g; |
2365
|
|
|
|
|
|
|
$good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = ($3) ? 0 : \$PP(PARENT)[$2]/g; |
2366
|
|
|
|
|
|
|
|
2367
|
|
|
|
|
|
|
my $str = $good; |
2368
|
|
|
|
|
|
|
|
2369
|
|
|
|
|
|
|
if ( defined $bflag and $bflag ) { |
2370
|
|
|
|
|
|
|
# parse 'bad' code |
2371
|
|
|
|
|
|
|
$bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else { \$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g; |
2372
|
|
|
|
|
|
|
$bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/ if( ($3) || \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else {\$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g; |
2373
|
|
|
|
|
|
|
|
2374
|
|
|
|
|
|
|
$str = 'if( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}'; |
2375
|
|
|
|
|
|
|
} |
2376
|
|
|
|
|
|
|
|
2377
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $str); |
2378
|
|
|
|
|
|
|
|
2379
|
|
|
|
|
|
|
} # sub: CodefromEquivCPOffsCode |
2380
|
|
|
|
|
|
|
|
2381
|
|
|
|
|
|
|
# this just reverses PARENT & CHILD in the expansion of |
2382
|
|
|
|
|
|
|
# the $EQUIVCPOFFS macro (ie compared to CodefromEquivCPOffsCode) |
2383
|
|
|
|
|
|
|
# |
2384
|
|
|
|
|
|
|
sub BackCodefromEquivCPOffsCode { |
2385
|
|
|
|
|
|
|
my $good = shift; |
2386
|
|
|
|
|
|
|
my $bflag = shift; |
2387
|
|
|
|
|
|
|
|
2388
|
|
|
|
|
|
|
my $bad = $good; |
2389
|
|
|
|
|
|
|
|
2390
|
|
|
|
|
|
|
# parse 'good' code |
2391
|
|
|
|
|
|
|
$good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(PARENT)[$2] = \$PP(CHILD)[$1]/g; |
2392
|
|
|
|
|
|
|
$good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) \$PP(PARENT)[$2] = \$PP(CHILD)[$1] /g; |
2393
|
|
|
|
|
|
|
|
2394
|
|
|
|
|
|
|
my $str = $good; |
2395
|
|
|
|
|
|
|
|
2396
|
|
|
|
|
|
|
if ( defined $bflag and $bflag ) { |
2397
|
|
|
|
|
|
|
# parse 'bad' code |
2398
|
|
|
|
|
|
|
$bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; }/g; |
2399
|
|
|
|
|
|
|
$bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) { if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; } } /g; |
2400
|
|
|
|
|
|
|
|
2401
|
|
|
|
|
|
|
$str = 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}'; |
2402
|
|
|
|
|
|
|
} |
2403
|
|
|
|
|
|
|
|
2404
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $str); |
2405
|
|
|
|
|
|
|
|
2406
|
|
|
|
|
|
|
} # sub: BackCodefromEquivCPOffsCode |
2407
|
|
|
|
|
|
|
|
2408
|
|
|
|
|
|
|
sub GenDocs { |
2409
|
|
|
|
|
|
|
my ($name,$pars,$otherpars,$doc,$baddoc) = @_; |
2410
|
|
|
|
|
|
|
|
2411
|
|
|
|
|
|
|
# Allow explcit non-doc using Doc=>undef |
2412
|
|
|
|
|
|
|
|
2413
|
|
|
|
|
|
|
return '' if $doc eq '' && (!defined $doc) && $doc==undef; |
2414
|
|
|
|
|
|
|
return '' if $doc =~ /^\s*internal\s*$/i; |
2415
|
|
|
|
|
|
|
|
2416
|
|
|
|
|
|
|
# remove any 'bad' documentation if we're not compiling support |
2417
|
|
|
|
|
|
|
$baddoc = undef unless $bvalflag; |
2418
|
|
|
|
|
|
|
|
2419
|
|
|
|
|
|
|
# If the doc string is one line let's have to for the |
2420
|
|
|
|
|
|
|
# reference card information as well |
2421
|
|
|
|
|
|
|
my @splitRes; # temp split variable to get rid of |
2422
|
|
|
|
|
|
|
# 'implicit split to @_ is deprecated' messages |
2423
|
|
|
|
|
|
|
$doc = "=for ref\n\n".$doc if( scalar(@splitRes = split("\n", $doc)) <= 1); |
2424
|
|
|
|
|
|
|
|
2425
|
|
|
|
|
|
|
$::DOCUMENTED++; |
2426
|
|
|
|
|
|
|
$pars = "P(); C()" unless $pars; |
2427
|
|
|
|
|
|
|
# Strip leading whitespace and trailing semicolons and whitespace |
2428
|
|
|
|
|
|
|
$pars =~ s/^\s*(.+[^;])[;\s]*$/$1/; |
2429
|
|
|
|
|
|
|
$otherpars =~ s/^\s*(.+[^;])[;\s]*$/$1/ if $otherpars; |
2430
|
|
|
|
|
|
|
my $sig = "$pars".( $otherpars ? "; $otherpars" : ""); |
2431
|
|
|
|
|
|
|
|
2432
|
|
|
|
|
|
|
$doc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m; # Strip extra =cut's |
2433
|
|
|
|
|
|
|
if ( defined $baddoc ) { |
2434
|
|
|
|
|
|
|
# Strip leading newlines and any =cut markings |
2435
|
|
|
|
|
|
|
$baddoc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m; |
2436
|
|
|
|
|
|
|
$baddoc =~ s/^\n+//; |
2437
|
|
|
|
|
|
|
$baddoc = "=for bad\n\n$baddoc"; |
2438
|
|
|
|
|
|
|
} |
2439
|
|
|
|
|
|
|
|
2440
|
|
|
|
|
|
|
my $baddoc_function_pod = <<"EOD" ; |
2441
|
|
|
|
|
|
|
|
2442
|
|
|
|
|
|
|
XXX=head2 $name |
2443
|
|
|
|
|
|
|
|
2444
|
|
|
|
|
|
|
XXX=for sig |
2445
|
|
|
|
|
|
|
|
2446
|
|
|
|
|
|
|
Signature: ($sig) |
2447
|
|
|
|
|
|
|
|
2448
|
|
|
|
|
|
|
$doc |
2449
|
|
|
|
|
|
|
|
2450
|
|
|
|
|
|
|
$baddoc |
2451
|
|
|
|
|
|
|
|
2452
|
|
|
|
|
|
|
XXX=cut |
2453
|
|
|
|
|
|
|
|
2454
|
|
|
|
|
|
|
EOD |
2455
|
|
|
|
|
|
|
|
2456
|
|
|
|
|
|
|
$baddoc_function_pod =~ s/^XXX=/=/gms; |
2457
|
|
|
|
|
|
|
return $baddoc_function_pod; |
2458
|
|
|
|
|
|
|
} |
2459
|
|
|
|
|
|
|
|
2460
|
|
|
|
|
|
|
sub ToIsReversible { |
2461
|
|
|
|
|
|
|
my($rev) = @_; |
2462
|
|
|
|
|
|
|
if($rev eq "1") { |
2463
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, '$SETREVERSIBLE(1)') |
2464
|
|
|
|
|
|
|
} else { |
2465
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $rev) |
2466
|
|
|
|
|
|
|
} |
2467
|
|
|
|
|
|
|
} |
2468
|
|
|
|
|
|
|
|
2469
|
|
|
|
|
|
|
sub make_newcoerce { |
2470
|
|
|
|
|
|
|
my($ftypes) = @_; |
2471
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, join '',map { |
2472
|
|
|
|
|
|
|
"$_->datatype = $ftypes->{$_}; " |
2473
|
|
|
|
|
|
|
} keys %$ftypes); |
2474
|
|
|
|
|
|
|
} |
2475
|
|
|
|
|
|
|
|
2476
|
|
|
|
|
|
|
# Assuming that, if HASP2Child is true, we only have |
2477
|
|
|
|
|
|
|
# PARENT; CHILD parameters, so we can just take the |
2478
|
|
|
|
|
|
|
# datatype to be that of PARENT (which is set up by |
2479
|
|
|
|
|
|
|
# find_datatype()). Little bit complicated because |
2480
|
|
|
|
|
|
|
# we need to set CHILD's datatype under certain |
2481
|
|
|
|
|
|
|
# circumstances |
2482
|
|
|
|
|
|
|
# |
2483
|
|
|
|
|
|
|
sub coerce_types { |
2484
|
|
|
|
|
|
|
my($parnames,$parobjs,$ignore,$newstab,$hasp2child) = @_; |
2485
|
|
|
|
|
|
|
|
2486
|
|
|
|
|
|
|
# assume [oca]CHILD();, although there might be an ignore |
2487
|
|
|
|
|
|
|
if ( $hasp2child ) { |
2488
|
|
|
|
|
|
|
my $child = $$parnames[1]; |
2489
|
|
|
|
|
|
|
return "" if $ignore->{$child}; |
2490
|
|
|
|
|
|
|
|
2491
|
|
|
|
|
|
|
die "ERROR: expected $child to be [oca]\n" |
2492
|
|
|
|
|
|
|
unless $parobjs->{$child}{FlagCreateAlways}; |
2493
|
|
|
|
|
|
|
|
2494
|
|
|
|
|
|
|
return PDL::PP::pp_line_numbers(__LINE__, "$child\->datatype = \$PRIV(__datatype);\n$child\->has_badvalue = \$PRIV(has_badvalue);\n$child\->badvalue = \$PRIV(badvalue);\n"); |
2495
|
|
|
|
|
|
|
} |
2496
|
|
|
|
|
|
|
|
2497
|
|
|
|
|
|
|
my $str = ""; |
2498
|
|
|
|
|
|
|
foreach ( @$parnames ) { |
2499
|
|
|
|
|
|
|
next if $ignore->{$_}; |
2500
|
|
|
|
|
|
|
|
2501
|
|
|
|
|
|
|
my $po = $parobjs->{$_}; |
2502
|
|
|
|
|
|
|
|
2503
|
|
|
|
|
|
|
my $dtype; |
2504
|
|
|
|
|
|
|
if ( $po->{FlagTyped} ) { |
2505
|
|
|
|
|
|
|
$dtype = $po->cenum(); |
2506
|
|
|
|
|
|
|
$dtype = "PDLMAX($dtype,\$PRIV(__datatype))" |
2507
|
|
|
|
|
|
|
if $po->{FlagTplus}; |
2508
|
|
|
|
|
|
|
} else { |
2509
|
|
|
|
|
|
|
$dtype = "\$PRIV(__datatype)"; |
2510
|
|
|
|
|
|
|
} |
2511
|
|
|
|
|
|
|
|
2512
|
|
|
|
|
|
|
if ( $po->{FlagCreateAlways} ) { |
2513
|
|
|
|
|
|
|
$str .= "$_->datatype = $dtype; "; |
2514
|
|
|
|
|
|
|
} else { |
2515
|
|
|
|
|
|
|
$str .= |
2516
|
|
|
|
|
|
|
"if( ($_->state & PDL_NOMYDIMS) && $_->trans == NULL ) { |
2517
|
|
|
|
|
|
|
$_->datatype = $dtype; |
2518
|
|
|
|
|
|
|
} else " |
2519
|
|
|
|
|
|
|
if $po->{FlagCreat}; |
2520
|
|
|
|
|
|
|
$str .= "if($dtype != $_->datatype) { |
2521
|
|
|
|
|
|
|
$_ = PDL->get_convertedpdl($_,$dtype); |
2522
|
|
|
|
|
|
|
}"; |
2523
|
|
|
|
|
|
|
} |
2524
|
|
|
|
|
|
|
} # foreach: @$parnames |
2525
|
|
|
|
|
|
|
|
2526
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $str); |
2527
|
55
|
0
|
|
|
|
|
} # sub: coerce_types() |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2528
|
0
|
|
|
|
|
|
|
2529
|
55
|
50
|
|
|
|
|
# First, finds the greatest datatype, then, if not supported, takes |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2530
|
32
|
|
|
|
|
|
# the largest type supported by the function. |
2531
|
50
|
50
|
|
|
|
|
# Not yet optimal. |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2532
|
8
|
|
|
|
|
|
# |
2533
|
43
|
50
|
|
|
|
|
# Assuming that, if HASP2Child is true, we only have |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2534
|
0
|
|
|
|
|
|
# PARENT; CHILD parameters, so we can just take the |
2535
|
43
|
50
|
|
|
|
|
# datatype to be that of PARENT (see also coerce_types()) |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2536
|
0
|
|
|
|
|
|
# |
2537
|
43
|
50
|
|
|
|
|
sub find_datatype { |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2538
|
0
|
|
|
|
|
|
my($parnames,$parobjs,$ignore,$newstab,$gentypes,$hasp2child) = @_; |
2539
|
1
|
50
|
|
|
|
|
|
2540
|
0
|
|
|
|
|
|
my $dtype = "\$PRIV(__datatype)"; |
2541
|
|
|
|
|
|
|
|
2542
|
|
|
|
|
|
|
# TODO XXX |
2543
|
|
|
|
|
|
|
# the check can probably be removed, but left in since I don't know |
2544
|
|
|
|
|
|
|
# what I'm doing (DJB) |
2545
|
|
|
|
|
|
|
die "ERROR: gentypes != $ntypes with p2child\n" |
2546
|
|
|
|
|
|
|
if $hasp2child and $#$gentypes != $ntypes; |
2547
|
|
|
|
|
|
|
|
2548
|
|
|
|
|
|
|
return "$dtype = $$parnames[0]\->datatype;\n\$PRIV(has_badvalue) = $$parnames[0]\->has_badvalue;\n\$PRIV(badvalue) = $$parnames[0]\->badvalue;\n" |
2549
|
|
|
|
|
|
|
if $hasp2child; |
2550
|
|
|
|
|
|
|
|
2551
|
|
|
|
|
|
|
my $str = "$dtype = 0;"; |
2552
|
|
|
|
|
|
|
foreach ( @$parnames ) { |
2553
|
|
|
|
|
|
|
my $po = $parobjs->{$_}; |
2554
|
|
|
|
|
|
|
next if $ignore->{$_} or $po->{FlagTyped} or $po->{FlagCreateAlways}; |
2555
|
|
|
|
|
|
|
|
2556
|
|
|
|
|
|
|
$str .= "if("; |
2557
|
|
|
|
|
|
|
$str .= "!(($_->state & PDL_NOMYDIMS) && |
2558
|
|
|
|
|
|
|
$_->trans == NULL) && " |
2559
|
|
|
|
|
|
|
if $po->{FlagCreat}; |
2560
|
|
|
|
|
|
|
$str .= "$dtype < $_->datatype) { |
2561
|
|
|
|
|
|
|
$dtype = $_->datatype; |
2562
|
|
|
|
|
|
|
}\n"; |
2563
|
|
|
|
|
|
|
} # foreach: @$parnames |
2564
|
|
|
|
|
|
|
|
2565
|
|
|
|
|
|
|
$str .= join '', map { "if($dtype == PDL_$_) {}\nelse " }(@$gentypes); |
2566
|
|
|
|
|
|
|
|
2567
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $str .= "$dtype = PDL_$gentypes->[-1];\n"); |
2568
|
55
|
0
|
|
|
|
|
} # sub: find_datatype() |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2569
|
14
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2570
|
0
|
0
|
|
|
|
|
sub NT2Decls_p {&NT2Decls__({ToPtrs=>1},@_);} |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2571
|
14
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2572
|
5
|
0
|
|
|
|
|
sub NT2Copies_p {&NT2Copies__({ToPtrs=>1},@_);} |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2573
|
5
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2574
|
14
|
0
|
|
|
|
|
sub NT2Free_p {&NT2Free__({ToPtrs=>1},@_);} |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2575
|
13
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2576
|
12
|
0
|
|
|
|
|
sub NT2Decls {&NT2Decls__({},@_);} |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2577
|
13
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2578
|
12
|
50
|
|
|
|
|
sub NT2Decls__ { |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2579
|
6
|
50
|
|
|
|
|
my($opts,$onames,$otypes) = @_; |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2580
|
5
|
0
|
|
|
|
|
my $decl; |
|
|
50
|
|
|
|
|
|
2581
|
6
|
50
|
|
|
|
|
my $dopts = {}; |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2582
|
2
|
50
|
|
|
|
|
$dopts->{VarArrays2Ptrs} = 1 if $opts->{ToPtrs}; |
|
|
50
|
|
|
|
|
|
2583
|
1
|
50
|
|
|
|
|
for(@$onames) { |
2584
|
1
|
50
|
|
|
|
|
$decl .= $otypes->{$_}->get_decl($_,$dopts).";"; |
2585
|
2
|
50
|
|
|
|
|
} |
|
|
50
|
|
|
|
|
|
2586
|
2
|
50
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $decl); |
|
|
50
|
|
|
|
|
|
2587
|
1
|
50
|
|
|
|
|
} |
|
|
0
|
|
|
|
|
|
2588
|
1
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2589
|
1
|
50
|
|
|
|
|
sub NT2Copies__ { |
|
|
0
|
|
|
|
|
|
2590
|
0
|
0
|
|
|
|
|
my($opts,$onames,$otypes,$copyname) = @_; |
2591
|
0
|
0
|
|
|
|
|
my $decl; |
2592
|
55
|
0
|
|
|
|
|
my $dopts = {}; |
2593
|
0
|
|
|
|
|
|
$dopts->{VarArrays2Ptrs} = 1 if $opts->{ToPtrs}; |
2594
|
55
|
|
|
|
|
|
for(@$onames) { |
2595
|
0
|
|
|
|
|
|
$decl .= $otypes->{$_}->get_copy("\$PRIV($_)","$copyname->$_", |
2596
|
|
|
|
|
|
|
$dopts).";"; |
2597
|
|
|
|
|
|
|
} |
2598
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $decl); |
2599
|
0
|
|
|
|
|
|
} |
2600
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2601
|
0
|
0
|
|
|
|
|
sub NT2Free__ { |
2602
|
|
|
|
|
|
|
my($opts,$onames,$otypes) = @_; |
2603
|
|
|
|
|
|
|
my $decl; |
2604
|
|
|
|
|
|
|
my $dopts = {}; |
2605
|
|
|
|
|
|
|
$dopts->{VarArrays2Ptrs} = 1 if $opts->{ToPtrs}; |
2606
|
|
|
|
|
|
|
for(@$onames) { |
2607
|
|
|
|
|
|
|
$decl .= $otypes->{$_}->get_free("\$PRIV($_)", |
2608
|
|
|
|
|
|
|
$dopts).";"; |
2609
|
|
|
|
|
|
|
} |
2610
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $decl); |
2611
|
0
|
|
|
|
|
|
} |
2612
|
55
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2613
|
0
|
0
|
|
|
|
|
# The undef is just so that PrivIsInc gets set. Is this really |
2614
|
|
|
|
|
|
|
# needed (well, it is since the rule fails if there aren't 2 |
2615
|
|
|
|
|
|
|
# return values; what I meant is what does PrivIsInc do for |
2616
|
|
|
|
|
|
|
# us?) |
2617
|
55
|
|
|
|
|
|
# |
2618
|
|
|
|
|
|
|
sub make_incsizes { |
2619
|
|
|
|
|
|
|
my($parnames,$parobjs,$dimobjs,$havethreading) = @_; |
2620
|
|
|
|
|
|
|
my $str = ($havethreading?"pdl_thread __pdlthread; ":""). |
2621
|
|
|
|
|
|
|
(join '',map {$parobjs->{$_}->get_incdecls} @$parnames). |
2622
|
|
|
|
|
|
|
(join '',map {$_->get_decldim} sort values %$dimobjs); |
2623
|
|
|
|
|
|
|
return ($str,undef); |
2624
|
|
|
|
|
|
|
} |
2625
|
|
|
|
|
|
|
|
2626
|
|
|
|
|
|
|
sub make_incsize_copy { |
2627
|
|
|
|
|
|
|
my($parnames,$parobjs,$dimobjs,$copyname,$havethreading) = @_; |
2628
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, |
2629
|
0
|
|
|
|
|
|
($havethreading? |
2630
|
|
|
|
|
|
|
"PDL->thread_copy(&(\$PRIV(__pdlthread)),&($copyname->__pdlthread));" |
2631
|
|
|
|
|
|
|
: ""). |
2632
|
|
|
|
|
|
|
(join '',map {$parobjs->{$_}->get_incdecl_copy(sub{"\$PRIV($_[0])"}, |
2633
|
|
|
|
|
|
|
sub{"$copyname->$_[0]"})} @$parnames). |
2634
|
|
|
|
|
|
|
(join '',map {$_->get_copydim(sub{"\$PRIV($_[0])"}, |
2635
|
|
|
|
|
|
|
sub{"$copyname->$_[0]"})} sort values %$dimobjs) |
2636
|
|
|
|
|
|
|
); |
2637
|
|
|
|
|
|
|
|
2638
|
|
|
|
|
|
|
} |
2639
|
|
|
|
|
|
|
|
2640
|
|
|
|
|
|
|
sub make_incsize_free { |
2641
|
|
|
|
|
|
|
my($parnames,$parobjs,$dimobjs,$havethreading) = @_; |
2642
|
|
|
|
|
|
|
$havethreading ? |
2643
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, 'PDL->freethreadloop(&($PRIV(__pdlthread)));') |
2644
|
55
|
|
|
|
|
|
: '' |
2645
|
|
|
|
|
|
|
} |
2646
|
|
|
|
|
|
|
|
2647
|
|
|
|
|
|
|
sub make_parnames { |
2648
|
|
|
|
|
|
|
my($pnames,$pobjs,$dobjs) = @_; |
2649
|
|
|
|
|
|
|
my @pdls = map {$pobjs->{$_}} @$pnames; |
2650
|
|
|
|
|
|
|
my $npdls = $#pdls+1; |
2651
|
|
|
|
|
|
|
my $join__parnames = join ",",map {qq|"$_"|} @$pnames; |
2652
|
|
|
|
|
|
|
my $join__realdims = join ",",map {$#{$_->{IndObjs}}+1} @pdls; |
2653
|
|
|
|
|
|
|
if($Config{cc} eq 'cl') { |
2654
|
|
|
|
|
|
|
$join__parnames = '""' if $join__parnames eq ''; |
2655
|
|
|
|
|
|
|
$join__realdims = '0' if $join__realdims eq ''; |
2656
|
|
|
|
|
|
|
} |
2657
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, "static char *__parnames[] = {". $join__parnames ."}; |
2658
|
|
|
|
|
|
|
static PDL_Indx __realdims[] = {". $join__realdims . "}; |
2659
|
|
|
|
|
|
|
static char __funcname[] = \"\$MODULE()::\$NAME()\"; |
2660
|
|
|
|
|
|
|
static pdl_errorinfo __einfo = { |
2661
|
|
|
|
|
|
|
__funcname, __parnames, $npdls |
2662
|
|
|
|
|
|
|
}; |
2663
|
|
|
|
|
|
|
"); |
2664
|
|
|
|
|
|
|
} |
2665
|
|
|
|
|
|
|
|
2666
|
55
|
|
|
|
|
|
############################## |
2667
|
|
|
|
|
|
|
# |
2668
|
|
|
|
|
|
|
# hdrcheck -- examine the various PDLs that form the output PDL, |
2669
|
55
|
|
|
|
|
|
# and copy headers as necessary. The last header found with the hdrcpy |
2670
|
|
|
|
|
|
|
# bit set is used. This used to do just a simple ref copy but now |
2671
|
|
|
|
|
|
|
# it uses the perl routine PDL::_hdr_copy to do the dirty work. That |
2672
|
|
|
|
|
|
|
# routine makes a deep copy of the header. Copies of the deep copy |
2673
|
|
|
|
|
|
|
# are distributed to all the names of the piddle that are not the source |
2674
|
|
|
|
|
|
|
# of the header. I believe that is the Right Thing to do but I could be |
2675
|
|
|
|
|
|
|
# wrong. |
2676
|
|
|
|
|
|
|
# |
2677
|
|
|
|
|
|
|
# It's hard to read this sort of macro stuff so here's the flow: |
2678
|
|
|
|
|
|
|
# - Check the hdrcpy flag. If it's set, then check the header |
2679
|
|
|
|
|
|
|
# to see if it exists. If it doees, we need to call the |
2680
|
|
|
|
|
|
|
# perl-land PDL::_hdr_copy routine. There are some shenanigans |
2681
|
|
|
|
|
|
|
# to keep the return value from evaporating before we've had a |
2682
|
|
|
|
|
|
|
# chance to do our bit with it. |
2683
|
|
|
|
|
|
|
# - For each output argument in the function signature, try to put |
2684
|
|
|
|
|
|
|
# a reference to the new header into that argument's header slot. |
2685
|
|
|
|
|
|
|
# (For functions with multiple outputs, this produces multiple linked |
2686
|
|
|
|
|
|
|
# headers -- that could be Wrong; fixing it would require making |
2687
|
|
|
|
|
|
|
# yet more explicit copies!) |
2688
|
|
|
|
|
|
|
# - Remortalize the return value from PDL::_hdr_copy, so that we don't |
2689
|
|
|
|
|
|
|
# leak memory. |
2690
|
|
|
|
|
|
|
# |
2691
|
|
|
|
|
|
|
# --CED 12-Apr-2003 |
2692
|
|
|
|
|
|
|
# |
2693
|
|
|
|
|
|
|
|
2694
|
|
|
|
|
|
|
sub hdrcheck { |
2695
|
|
|
|
|
|
|
my ($pnames,$pobjs) = @_; |
2696
|
|
|
|
|
|
|
|
2697
|
|
|
|
|
|
|
my $nn = $#$pnames; |
2698
|
|
|
|
|
|
|
my @names = map { "\$PRIV(pdls[$_])" } 0..$nn; |
2699
|
|
|
|
|
|
|
|
2700
|
|
|
|
|
|
|
# from make_redodims_thread() we know that __creating[] == 0 unless |
2701
|
|
|
|
|
|
|
# ...{FlagCreat} is true |
2702
|
|
|
|
|
|
|
# |
2703
|
|
|
|
|
|
|
my $str = " |
2704
|
|
|
|
|
|
|
{ PDL_COMMENT(\"convenience block\") |
2705
|
|
|
|
|
|
|
void *hdrp = NULL; |
2706
|
|
|
|
|
|
|
char propagate_hdrcpy = 0; |
2707
|
|
|
|
|
|
|
SV *hdr_copy = NULL; |
2708
|
|
|
|
|
|
|
"; |
2709
|
|
|
|
|
|
|
|
2710
|
|
|
|
|
|
|
# Find a header among the possible names |
2711
|
|
|
|
|
|
|
foreach ( 0 .. $nn ) { |
2712
|
|
|
|
|
|
|
my $aux = $pobjs->{$pnames->[$_]}{FlagCreat} ? "!__creating[$_] && \n" : ""; |
2713
|
|
|
|
|
|
|
$str .= <<"HdRCHECK1" |
2714
|
|
|
|
|
|
|
if(!hdrp && |
2715
|
|
|
|
|
|
|
$aux $names[$_]\->hdrsv && |
2716
|
|
|
|
|
|
|
($names[$_]\->state & PDL_HDRCPY) |
2717
|
|
|
|
|
|
|
) { |
2718
|
|
|
|
|
|
|
hdrp = $names[$_]\->hdrsv; |
2719
|
|
|
|
|
|
|
propagate_hdrcpy = (($names[$_]\->state & PDL_HDRCPY) != 0); |
2720
|
|
|
|
|
|
|
} |
2721
|
|
|
|
|
|
|
HdRCHECK1 |
2722
|
|
|
|
|
|
|
; |
2723
|
|
|
|
|
|
|
} |
2724
|
|
|
|
|
|
|
|
2725
|
|
|
|
|
|
|
$str .= << 'DeePcOPY' |
2726
|
|
|
|
|
|
|
if (hdrp) { |
2727
|
|
|
|
|
|
|
if(hdrp == &PL_sv_undef) |
2728
|
|
|
|
|
|
|
hdr_copy = &PL_sv_undef; |
2729
|
|
|
|
|
|
|
else { PDL_COMMENT("Call the perl routine _hdr_copy...") |
2730
|
|
|
|
|
|
|
int count; |
2731
|
|
|
|
|
|
|
PDL_COMMENT("Call the perl routine PDL::_hdr_copy(hdrp)") |
2732
|
|
|
|
|
|
|
dSP; |
2733
|
|
|
|
|
|
|
ENTER ; |
2734
|
|
|
|
|
|
|
SAVETMPS ; |
2735
|
|
|
|
|
|
|
PUSHMARK(SP) ; |
2736
|
|
|
|
|
|
|
XPUSHs( hdrp ); |
2737
|
|
|
|
|
|
|
PUTBACK ; |
2738
|
|
|
|
|
|
|
count = call_pv("PDL::_hdr_copy",G_SCALAR); |
2739
|
|
|
|
|
|
|
SPAGAIN ; |
2740
|
|
|
|
|
|
|
if(count != 1) |
2741
|
|
|
|
|
|
|
croak("PDL::_hdr_copy didn't return a single value - please report this bug (A)."); |
2742
|
|
|
|
|
|
|
|
2743
|
|
|
|
|
|
|
hdr_copy = (SV *)POPs; |
2744
|
|
|
|
|
|
|
|
2745
|
|
|
|
|
|
|
if(hdr_copy && hdr_copy != &PL_sv_undef) { |
2746
|
|
|
|
|
|
|
(void)SvREFCNT_inc(hdr_copy); PDL_COMMENT("Keep hdr_copy from vanishing during FREETMPS") |
2747
|
|
|
|
|
|
|
} |
2748
|
|
|
|
|
|
|
|
2749
|
|
|
|
|
|
|
FREETMPS ; |
2750
|
|
|
|
|
|
|
LEAVE ; |
2751
|
|
|
|
|
|
|
|
2752
|
|
|
|
|
|
|
|
2753
|
|
|
|
|
|
|
} PDL_COMMENT("end of callback block") |
2754
|
|
|
|
|
|
|
|
2755
|
|
|
|
|
|
|
DeePcOPY |
2756
|
|
|
|
|
|
|
; |
2757
|
|
|
|
|
|
|
# if(hdrp) block is still open -- now reassign all the aliases... |
2758
|
|
|
|
|
|
|
|
2759
|
|
|
|
|
|
|
# Found the header -- now copy it into all the right places. |
2760
|
|
|
|
|
|
|
foreach ( 0 .. $nn ) { |
2761
|
|
|
|
|
|
|
$str .= <<"HdRCHECK2" |
2762
|
|
|
|
|
|
|
if ( $names[$_]\->hdrsv != hdrp ){ |
2763
|
|
|
|
|
|
|
if( $names[$_]\->hdrsv && $names[$_]\->hdrsv != &PL_sv_undef) |
2764
|
|
|
|
|
|
|
(void)SvREFCNT_dec( $names[$_]\->hdrsv ); |
2765
|
|
|
|
|
|
|
if( hdr_copy != &PL_sv_undef ) |
2766
|
|
|
|
|
|
|
(void)SvREFCNT_inc(hdr_copy); |
2767
|
|
|
|
|
|
|
$names[$_]\->hdrsv = hdr_copy; |
2768
|
|
|
|
|
|
|
} |
2769
|
|
|
|
|
|
|
if(propagate_hdrcpy) |
2770
|
|
|
|
|
|
|
$names[$_]\->state |= PDL_HDRCPY; |
2771
|
|
|
|
|
|
|
HdRCHECK2 |
2772
|
|
|
|
|
|
|
|
2773
|
|
|
|
|
|
|
# QUESTION: what is the following line doing? |
2774
|
|
|
|
|
|
|
# |
2775
|
|
|
|
|
|
|
if ( $pobjs->{$pnames->[$_]}{FlagCreat} ); |
2776
|
|
|
|
|
|
|
} |
2777
|
|
|
|
|
|
|
|
2778
|
|
|
|
|
|
|
$str .= ' |
2779
|
|
|
|
|
|
|
if(hdr_copy != &PL_sv_undef) |
2780
|
|
|
|
|
|
|
SvREFCNT_dec(hdr_copy); PDL_COMMENT("make hdr_copy mortal again") |
2781
|
|
|
|
|
|
|
} PDL_COMMENT("end of if(hdrp) block") |
2782
|
|
|
|
|
|
|
} PDL_COMMENT("end of conv. block") |
2783
|
|
|
|
|
|
|
'; |
2784
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, $str); |
2785
|
|
|
|
|
|
|
|
2786
|
|
|
|
|
|
|
} # sub: hdrcheck() |
2787
|
55
|
|
|
|
|
|
|
2788
|
55
|
|
|
|
|
|
sub make_redodims_thread { |
2789
|
55
|
|
|
|
|
|
#my($pnames,$pobjs,$dobjs,$dpars,$pcode ) = @_; |
2790
|
55
|
0
|
|
|
|
|
my($pnames,$pobjs,$dobjs,$dpars,$pcode, $noPthreadFlag) = @_; |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2791
|
0
|
0
|
|
|
|
|
my $str = PDL::PP::pp_line_numbers(__LINE__, ''); |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2792
|
0
|
|
|
|
|
|
my $npdls = @$pnames; |
2793
|
55
|
|
|
|
|
|
|
2794
|
55
|
|
|
|
|
|
$noPthreadFlag = 0 unless( defined $noPthreadFlag ); # assume we can pthread, unless indicated otherwise |
2795
|
5
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2796
|
7
|
0
|
|
|
|
|
my $nn = $#$pnames; |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2797
|
75
|
0
|
|
|
|
|
my @privname = map { "\$PRIV(pdls[$_])" } ( 0 .. $nn ); |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2798
|
41
|
0
|
|
|
|
|
$str .= $npdls ? "PDL_Indx __creating[$npdls];\n" : "PDL_Indx __creating[1];\n"; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2799
|
27
|
50
|
|
|
|
|
$str .= join '',map {$_->get_initdim."\n"} sort values %$dobjs; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2800
|
8
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2801
|
1
|
50
|
|
|
|
|
# if FlagCreat is NOT true, then we set __creating[] to 0 |
|
|
0
|
|
|
|
|
|
2802
|
21
|
50
|
|
|
|
|
# and we can use this knowledge below, and in hdrcheck() |
|
|
0
|
|
|
|
|
|
2803
|
21
|
|
|
|
|
|
# and in PP/PdlParObj (get_xsnormdimchecks()) |
2804
|
51
|
50
|
|
|
|
|
# |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2805
|
47
|
0
|
|
|
|
|
foreach ( 0 .. $nn ) { |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2806
|
1
|
0
|
|
|
|
|
$str .= "__creating[$_] = "; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2807
|
0
|
0
|
|
|
|
|
if ( $pobjs->{$pnames->[$_]}{FlagCreat} ) { |
2808
|
0
|
|
|
|
|
|
$str .= "PDL_CR_SETDIMSCOND(__privtrans,$privname[$_]);\n"; |
2809
|
0
|
|
|
|
|
|
} else { |
2810
|
0
|
|
|
|
|
|
$str .= "0;\n"; |
2811
|
1
|
0
|
|
|
|
|
} |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2812
|
50
|
50
|
|
|
|
|
} # foreach: 0 .. $nn |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2813
|
42
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2814
|
0
|
0
|
|
|
|
|
$str .= " {\n$pcode\n}\n"; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2815
|
0
|
0
|
|
|
|
|
$str .= " {\n " . make_parnames($pnames,$pobjs,$dobjs) . " |
|
|
0
|
|
|
|
|
|
2816
|
0
|
0
|
|
|
|
|
PDL->initthreadstruct(2,\$PRIV(pdls), |
|
|
0
|
|
|
|
|
|
2817
|
0
|
|
|
|
|
|
__realdims,__creating,$npdls, |
2818
|
0
|
|
|
|
|
|
&__einfo,&(\$PRIV(__pdlthread)), |
2819
|
1
|
50
|
|
|
|
|
\$PRIV(vtable->per_pdl_flags), |
|
|
0
|
|
|
|
|
|
2820
|
43
|
0
|
|
|
|
|
$noPthreadFlag ); |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2821
|
0
|
0
|
|
|
|
|
}\n"; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2822
|
0
|
0
|
|
|
|
|
$str .= join '',map {$pobjs->{$_}->get_xsnormdimchecks()} @$pnames; |
2823
|
0
|
|
|
|
|
|
$str .= hdrcheck($pnames,$pobjs); |
2824
|
0
|
0
|
|
|
|
|
$str .= join '',map {$pobjs->{$pnames->[$_]}-> |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2825
|
0
|
|
|
|
|
|
get_incsets($privname[$_])} 0..$nn; |
2826
|
0
|
0
|
|
|
|
|
return $str; |
2827
|
1
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2828
|
0
|
0
|
|
|
|
|
} # sub: make_redodims_thread() |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2829
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2830
|
0
|
0
|
|
|
|
|
sub XSHdr { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2831
|
0
|
0
|
|
|
|
|
my($xsname,$nxargs) = @_; |
|
|
0
|
|
|
|
|
|
2832
|
0
|
|
|
|
|
|
return XS::mkproto($xsname,$nxargs); |
2833
|
0
|
|
|
|
|
|
} |
2834
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2835
|
0
|
0
|
|
|
|
|
########################################################### |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2836
|
0
|
0
|
|
|
|
|
# Name : extract_signature_from_fulldoc |
2837
|
0
|
0
|
|
|
|
|
# Usage : $sig = extract_signature_from_fulldoc($fulldoc) |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2838
|
0
|
|
|
|
|
|
# Purpose : pull out the signature from the fulldoc string |
2839
|
0
|
0
|
|
|
|
|
# Returns : whatever is in parentheses in the signature, or undef |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2840
|
0
|
|
|
|
|
|
# Parameters : $fulldoc |
2841
|
0
|
0
|
|
|
|
|
# Throws : never |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2842
|
0
|
0
|
|
|
|
|
# Notes : the signature must have the following form: |
|
|
0
|
|
|
|
|
|
2843
|
0
|
0
|
|
|
|
|
# : |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2844
|
0
|
0
|
|
|
|
|
# : =for sig |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2845
|
0
|
|
|
|
|
|
# : |
2846
|
0
|
0
|
|
|
|
|
# : Signature: (
|
|
|
0
|
|
|
|
|
|
2847
|
0
|
|
|
|
|
|
# : be multiline>) |
2848
|
0
|
0
|
|
|
|
|
# : |
2849
|
0
|
0
|
|
|
|
|
# : |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2850
|
0
|
0
|
|
|
|
|
# : The two spaces before "Signature" are required, as are |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2851
|
0
|
0
|
|
|
|
|
# : the parentheses. |
2852
|
0
|
0
|
|
|
|
|
sub extract_signature_from_fulldoc { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2853
|
0
|
|
|
|
|
|
my $fulldoc = shift; |
2854
|
0
|
|
|
|
|
|
if ($fulldoc =~ /=for sig\n\n Signature: \(([^\n]*)\n/g) { |
2855
|
|
|
|
|
|
|
# Extract the signature and remove the final parenthesis |
2856
|
0
|
0
|
|
|
|
|
my $sig = $1; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2857
|
0
|
0
|
|
|
|
|
$sig .= $1 while $fulldoc =~ /\G\h+([^\n]*)\n/g; |
|
|
0
|
|
|
|
|
|
2858
|
0
|
0
|
|
|
|
|
$sig =~ s/\)\s*$//; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2859
|
0
|
0
|
|
|
|
|
return $sig; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2860
|
0
|
|
|
|
|
|
} |
2861
|
0
|
0
|
|
|
|
|
return; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2862
|
0
|
|
|
|
|
|
} |
2863
|
0
|
0
|
|
|
|
|
|
2864
|
0
|
|
|
|
|
|
|
2865
|
0
|
0
|
|
|
|
|
# Build the valid-types regex and valid Pars argument only once. These are |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2866
|
0
|
0
|
|
|
|
|
# also used in PDL::PP::PdlParObj, which is why they are globally available. |
|
|
0
|
|
|
|
|
|
2867
|
0
|
|
|
|
|
|
use PDL::PP::PdlParObj; |
2868
|
0
|
0
|
|
|
|
|
my $pars_re = $PDL::PP::PdlParObj::pars_re; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2869
|
0
|
|
|
|
|
|
|
2870
|
0
|
|
|
|
|
|
########################################################### |
2871
|
|
|
|
|
|
|
# Name : build_pars_from_fulldoc |
2872
|
0
|
0
|
|
|
|
|
# Usage : $pars = build_pars_from_fulldoc($fulldoc) |
2873
|
0
|
|
|
|
|
|
# Purpose : extract the Pars from the signature from the fulldoc string, |
2874
|
|
|
|
|
|
|
# : the part of the signature that specifies the piddles |
2875
|
0
|
0
|
|
|
|
|
# Returns : a string appropriate for the Pars key |
2876
|
0
|
|
|
|
|
|
# Parameters : $fulldoc |
2877
|
|
|
|
|
|
|
# Throws : if there is no signature |
2878
|
|
|
|
|
|
|
# : if there is no extractable Pars section |
2879
|
|
|
|
|
|
|
# : if some PDL arguments come after the OtherPars arguments start |
2880
|
|
|
|
|
|
|
# Notes : This is meant to be used directly in a Rule. Therefore, it |
2881
|
|
|
|
|
|
|
# : is only called if the Pars key does not yet exist, so if it |
2882
|
|
|
|
|
|
|
# : is not possible to extract the Pars section, it dies. |
2883
|
|
|
|
|
|
|
sub build_pars_from_fulldoc { |
2884
|
|
|
|
|
|
|
my $fulldoc = shift; |
2885
|
|
|
|
|
|
|
|
2886
|
|
|
|
|
|
|
# Get the signature or die |
2887
|
|
|
|
|
|
|
my $sig = extract_signature_from_fulldoc($fulldoc) |
2888
|
|
|
|
|
|
|
or confess('No Pars specified and none could be extracted from FullDoc'); |
2889
|
|
|
|
|
|
|
|
2890
|
|
|
|
|
|
|
# Everything is semicolon-delimited |
2891
|
|
|
|
|
|
|
my @args = split /\s*;\s*/, $sig; |
2892
|
|
|
|
|
|
|
my @pars; |
2893
|
|
|
|
|
|
|
my $switched_to_other_pars = 0; |
2894
|
|
|
|
|
|
|
for my $arg (@args) { |
2895
|
|
|
|
|
|
|
confess('All PDL args must come before other pars in FullDoc signature') |
2896
|
|
|
|
|
|
|
if $switched_to_other_pars and $arg =~ $pars_re; |
2897
|
|
|
|
|
|
|
if ($arg =~ $pars_re) { |
2898
|
|
|
|
|
|
|
push @pars, $arg; |
2899
|
|
|
|
|
|
|
} |
2900
|
|
|
|
|
|
|
else { |
2901
|
|
|
|
|
|
|
$switched_to_other_pars = 1; |
2902
|
|
|
|
|
|
|
} |
2903
|
|
|
|
|
|
|
} |
2904
|
|
|
|
|
|
|
|
2905
|
|
|
|
|
|
|
# Make sure there's something there |
2906
|
|
|
|
|
|
|
confess('FullDoc signature contains no PDL arguments') if @pars == 0; |
2907
|
|
|
|
|
|
|
|
2908
|
|
|
|
|
|
|
# All done! |
2909
|
|
|
|
|
|
|
return join('; ', @pars); |
2910
|
|
|
|
|
|
|
} |
2911
|
|
|
|
|
|
|
|
2912
|
|
|
|
|
|
|
########################################################### |
2913
|
|
|
|
|
|
|
# Name : build_otherpars_from_fulldoc |
2914
|
|
|
|
|
|
|
# Usage : $otherpars = build_otherpars_from_fulldoc($fulldoc) |
2915
|
|
|
|
|
|
|
# Purpose : extract the OtherPars from the signature from the fulldoc |
2916
|
|
|
|
|
|
|
# : string, the part of the signature that specifies non-piddle |
2917
|
|
|
|
|
|
|
# : arguments |
2918
|
|
|
|
|
|
|
# Returns : a string appropriate for the OtherPars key |
2919
|
|
|
|
|
|
|
# Parameters : $fulldoc |
2920
|
|
|
|
|
|
|
# Throws : if some OtherPars arguments come before the last PDL argument |
2921
|
|
|
|
|
|
|
# Notes : This is meant to be used directly in a Rule. Therefore, it |
2922
|
|
|
|
|
|
|
# : is only called if the OtherPars key does not yet exist. |
2923
|
|
|
|
|
|
|
sub build_otherpars_from_fulldoc { |
2924
|
|
|
|
|
|
|
my $fulldoc = shift; |
2925
|
|
|
|
|
|
|
|
2926
|
|
|
|
|
|
|
# Get the signature or do not set |
2927
|
|
|
|
|
|
|
my $sig = extract_signature_from_fulldoc($fulldoc) |
2928
|
|
|
|
|
|
|
or return 'DO NOT SET!!'; |
2929
|
|
|
|
|
|
|
|
2930
|
|
|
|
|
|
|
# Everything is semicolon-delimited |
2931
|
|
|
|
|
|
|
my @args = split /\s*;\s*/, $sig; |
2932
|
|
|
|
|
|
|
my @otherpars; |
2933
|
|
|
|
|
|
|
for my $arg (@args) { |
2934
|
|
|
|
|
|
|
confess('All PDL args must come before other pars in FullDoc signature') |
2935
|
|
|
|
|
|
|
if @otherpars > 0 and $arg =~ $pars_re; |
2936
|
|
|
|
|
|
|
if ($arg !~ $pars_re) { |
2937
|
|
|
|
|
|
|
push @otherpars, $arg; |
2938
|
|
|
|
|
|
|
} |
2939
|
|
|
|
|
|
|
} |
2940
|
|
|
|
|
|
|
|
2941
|
|
|
|
|
|
|
# All done! |
2942
|
|
|
|
|
|
|
return 'DO NOT SET!!'if @otherpars == 0; |
2943
|
|
|
|
|
|
|
return join('; ', @otherpars); |
2944
|
|
|
|
|
|
|
} |
2945
|
|
|
|
|
|
|
|
2946
|
|
|
|
|
|
|
# Set up the rules for translating the pp_def contents. |
2947
|
|
|
|
|
|
|
# |
2948
|
|
|
|
|
|
|
$PDL::PP::deftbl = |
2949
|
|
|
|
|
|
|
[ |
2950
|
|
|
|
|
|
|
# used as a flag for many of the routines |
2951
|
|
|
|
|
|
|
# ie should we bother with bad values for this routine? |
2952
|
|
|
|
|
|
|
# 1 - yes, |
2953
|
|
|
|
|
|
|
# 0 - no, maybe issue a warning |
2954
|
|
|
|
|
|
|
# undef - we're not compiling with bad value support |
2955
|
|
|
|
|
|
|
# |
2956
|
|
|
|
|
|
|
PDL::PP::Rule->new("BadFlag", "_HandleBad", |
2957
|
|
|
|
|
|
|
"Sets BadFlag based upon HandleBad key and PDL's ability to handle bad values", |
2958
|
|
|
|
|
|
|
sub { return (defined $_[0]) ? ($bvalflag and $_[0]) : undef; }), |
2959
|
|
|
|
|
|
|
|
2960
|
|
|
|
|
|
|
#################### |
2961
|
|
|
|
|
|
|
# FullDoc Handling # |
2962
|
|
|
|
|
|
|
#################### |
2963
|
|
|
|
|
|
|
|
2964
|
|
|
|
|
|
|
# Error processing: does FullDoc contain BadDoc, yet BadDoc specified? |
2965
|
|
|
|
|
|
|
PDL::PP::Rule::Croak->new(['FullDoc', 'BadDoc'], |
2966
|
|
|
|
|
|
|
'Cannot have both FullDoc and BadDoc defined'), |
2967
|
|
|
|
|
|
|
PDL::PP::Rule::Croak->new(['FullDoc', 'Doc'], |
2968
|
|
|
|
|
|
|
'Cannot have both FullDoc and Doc defined'), |
2969
|
|
|
|
|
|
|
# Note: no error processing on Pars; it's OK for the docs to gloss over |
2970
|
|
|
|
|
|
|
# the details. |
2971
|
|
|
|
|
|
|
|
2972
|
|
|
|
|
|
|
# Add the Pars section based on the signature of the FullDoc if the Pars |
2973
|
|
|
|
|
|
|
# section doesn't already exist |
2974
|
|
|
|
|
|
|
PDL::PP::Rule->new('Pars', 'FullDoc', |
2975
|
|
|
|
|
|
|
'Sets the Pars from the FullDoc if Pars is not explicitly specified', |
2976
|
|
|
|
|
|
|
\&build_pars_from_fulldoc |
2977
|
|
|
|
|
|
|
), |
2978
|
|
|
|
|
|
|
PDL::PP::Rule->new('OtherPars', 'FullDoc', |
2979
|
|
|
|
|
|
|
'Sets the OtherPars from the FullDoc if OtherPars is not explicitly specified', |
2980
|
|
|
|
|
|
|
\&build_otherpars_from_fulldoc |
2981
|
|
|
|
|
|
|
), |
2982
|
|
|
|
|
|
|
|
2983
|
|
|
|
|
|
|
################################ |
2984
|
|
|
|
|
|
|
# Other Documentation Handling # |
2985
|
|
|
|
|
|
|
################################ |
2986
|
|
|
|
|
|
|
|
2987
|
|
|
|
|
|
|
# no docs by default |
2988
|
|
|
|
|
|
|
PDL::PP::Rule::Returns->new("Doc", [], 'Sets the default doc string', |
2989
|
|
|
|
|
|
|
"\n=for ref\n\ninfo not available\n"), |
2990
|
|
|
|
|
|
|
|
2991
|
|
|
|
|
|
|
# try and automate the docs |
2992
|
|
|
|
|
|
|
# could be really clever and include the sig to see about |
2993
|
|
|
|
|
|
|
# input/output params, for instance |
2994
|
|
|
|
|
|
|
|
2995
|
|
|
|
|
|
|
PDL::PP::Rule->new("BadDoc", ["BadFlag","Name","_CopyBadStatusCode"], |
2996
|
|
|
|
|
|
|
'Sets the default documentation for handling of bad values', |
2997
|
|
|
|
|
|
|
sub { |
2998
|
|
|
|
|
|
|
return undef unless $bvalflag; |
2999
|
|
|
|
|
|
|
my ( $bf, $name, $code ) = @_; |
3000
|
|
|
|
|
|
|
my $str; |
3001
|
|
|
|
|
|
|
if ( not defined($bf) ) { |
3002
|
|
|
|
|
|
|
$str = "$name does not process bad values.\n"; |
3003
|
|
|
|
|
|
|
} elsif ( $bf ) { |
3004
|
|
|
|
|
|
|
$str = "$name processes bad values.\n"; |
3005
|
|
|
|
|
|
|
} else { |
3006
|
|
|
|
|
|
|
$str = "$name ignores the bad-value flag of the input piddles.\n"; |
3007
|
|
|
|
|
|
|
} |
3008
|
|
|
|
|
|
|
if ( not defined($code) ) { |
3009
|
|
|
|
|
|
|
$str .= "It will set the bad-value flag of all output piddles if " . |
3010
|
|
|
|
|
|
|
"the flag is set for any of the input piddles.\n"; |
3011
|
|
|
|
|
|
|
} elsif ( $code eq '' ) { |
3012
|
|
|
|
|
|
|
$str .= "The output piddles will NOT have their bad-value flag set.\n"; |
3013
|
|
|
|
|
|
|
} else { |
3014
|
|
|
|
|
|
|
$str .= "The state of the bad-value flag of the output piddles is unknown.\n"; |
3015
|
|
|
|
|
|
|
} |
3016
|
|
|
|
|
|
|
} |
3017
|
|
|
|
|
|
|
), |
3018
|
|
|
|
|
|
|
|
3019
|
|
|
|
|
|
|
# Default: no otherpars |
3020
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::EmptyString->new("OtherPars"), |
3021
|
|
|
|
|
|
|
|
3022
|
|
|
|
|
|
|
# the docs |
3023
|
|
|
|
|
|
|
PDL::PP::Rule->new("PdlDoc", "FullDoc", sub { |
3024
|
|
|
|
|
|
|
my $fulldoc = shift; |
3025
|
|
|
|
|
|
|
|
3026
|
|
|
|
|
|
|
# Remove bad documentation if bad values are not supported |
3027
|
|
|
|
|
|
|
$fulldoc =~ s/=for bad\n\n.*?\n\n//s unless $bvalflag; |
3028
|
|
|
|
|
|
|
|
3029
|
|
|
|
|
|
|
# Append a final cut if it doesn't exist due to heredoc shinanigans |
3030
|
|
|
|
|
|
|
$fulldoc .= "\n\n=cut\n" unless $fulldoc =~ /\n=cut\n*$/; |
3031
|
|
|
|
|
|
|
|
3032
|
|
|
|
|
|
|
# Make sure the =head1 FUNCTIONS section gets added |
3033
|
|
|
|
|
|
|
$::DOCUMENTED++; |
3034
|
|
|
|
|
|
|
|
3035
|
|
|
|
|
|
|
return $fulldoc; |
3036
|
|
|
|
|
|
|
} |
3037
|
|
|
|
|
|
|
), |
3038
|
|
|
|
|
|
|
PDL::PP::Rule->new("PdlDoc", ["Name","_Pars","OtherPars","Doc","_BadDoc"], \&GenDocs), |
3039
|
|
|
|
|
|
|
|
3040
|
|
|
|
|
|
|
################## |
3041
|
|
|
|
|
|
|
# Done with Docs # |
3042
|
|
|
|
|
|
|
################## |
3043
|
|
|
|
|
|
|
|
3044
|
|
|
|
|
|
|
# Notes |
3045
|
|
|
|
|
|
|
# Suffix 'NS' means, "Needs Substitution". In other words, the string |
3046
|
|
|
|
|
|
|
# associated with a key that has the suffix "NS" must be run through a |
3047
|
|
|
|
|
|
|
# Substitute or Substitute::Usual |
3048
|
|
|
|
|
|
|
|
3049
|
|
|
|
|
|
|
# some defaults |
3050
|
|
|
|
|
|
|
# |
3051
|
|
|
|
|
|
|
PDL::PP::Rule::Returns->new("CopyName", [], |
3052
|
|
|
|
|
|
|
'Sets the CopyName key to the default: __copy', "__copy"), |
3053
|
|
|
|
|
|
|
|
3054
|
|
|
|
|
|
|
PDL::PP::Rule->new("DefaultFlowCodeNS", "_DefaultFlow", |
3055
|
|
|
|
|
|
|
'Sets the code to handle dataflow flags, if applicable', |
3056
|
|
|
|
|
|
|
sub { pp_line_numbers(__LINE__, $_[0] ? |
3057
|
|
|
|
|
|
|
'$PRIV(flags) |= PDL_ITRANS_DO_DATAFLOW_F | PDL_ITRANS_DO_DATAFLOW_B;' |
3058
|
|
|
|
|
|
|
: 'PDL_COMMENT("No flow")') }), |
3059
|
|
|
|
|
|
|
|
3060
|
|
|
|
|
|
|
# Question: where is ppdefs defined? |
3061
|
|
|
|
|
|
|
# Answer: Core/Types.pm |
3062
|
|
|
|
|
|
|
# |
3063
|
|
|
|
|
|
|
PDL::PP::Rule->new("GenericTypes", [], |
3064
|
|
|
|
|
|
|
'Sets GenericTypes flag to all types known to PDL::Types', |
3065
|
|
|
|
|
|
|
sub {[ppdefs]}), |
3066
|
|
|
|
|
|
|
|
3067
|
|
|
|
|
|
|
PDL::PP::Rule->new("ExtraGenericLoops", "FTypes", |
3068
|
|
|
|
|
|
|
'Makes ExtraGenericLoops identical to FTypes if the latter exists and the former does not', |
3069
|
|
|
|
|
|
|
sub {return $_[0]}), |
3070
|
|
|
|
|
|
|
PDL::PP::Rule::Returns->new("ExtraGenericLoops", [], |
3071
|
|
|
|
|
|
|
'Sets ExtraGenericLoops to an empty hash if it does not already exist', {}), |
3072
|
|
|
|
|
|
|
|
3073
|
|
|
|
|
|
|
PDL::PP::Rule::InsertName->new("StructName", 'pdl_${name}_struct'), |
3074
|
|
|
|
|
|
|
PDL::PP::Rule::InsertName->new("VTableName", 'pdl_${name}_vtable'), |
3075
|
|
|
|
|
|
|
|
3076
|
|
|
|
|
|
|
PDL::PP::Rule->new("FHdrInfo", ["Name","StructName"], |
3077
|
|
|
|
|
|
|
sub { return { Name => $_[0], StructName => $_[1], }; }), |
3078
|
|
|
|
|
|
|
|
3079
|
|
|
|
|
|
|
# Treat exchanges as affines. Affines assumed to be parent->child. |
3080
|
|
|
|
|
|
|
# Exchanges may, if the want, handle threadids as well. |
3081
|
|
|
|
|
|
|
# Same number of dimensions is assumed, though. |
3082
|
|
|
|
|
|
|
# |
3083
|
|
|
|
|
|
|
PDL::PP::Rule->new("AffinePriv", "XCHGOnly", sub { return @_; }), |
3084
|
|
|
|
|
|
|
PDL::PP::Rule::Returns->new("Priv", "AffinePriv", 'PDL_Indx incs[$CHILD(ndims)];PDL_Indx offs; '), |
3085
|
|
|
|
|
|
|
PDL::PP::Rule::Returns->new("IsAffineFlag", "AffinePriv", "PDL_ITRANS_ISAFFINE"), |
3086
|
|
|
|
|
|
|
|
3087
|
|
|
|
|
|
|
PDL::PP::Rule->new("RedoDims", ["EquivPDimExpr","FHdrInfo","_EquivDimCheck"], |
3088
|
|
|
|
|
|
|
\&pdimexpr2priv), |
3089
|
|
|
|
|
|
|
PDL::PP::Rule->new("RedoDims", ["Identity","FHdrInfo"], |
3090
|
|
|
|
|
|
|
\&identity2priv), |
3091
|
|
|
|
|
|
|
|
3092
|
|
|
|
|
|
|
# NOTE: we use the same bit of code for all-good and bad data - |
3093
|
|
|
|
|
|
|
# see the Code rule |
3094
|
|
|
|
|
|
|
# |
3095
|
|
|
|
|
|
|
PDL::PP::Rule->new("EquivCPOffsCode", "Identity", |
3096
|
|
|
|
|
|
|
"something to do with dataflow between CHILD & PARENT, I think.", |
3097
|
|
|
|
|
|
|
\&equivcpoffscode), |
3098
|
|
|
|
|
|
|
|
3099
|
|
|
|
|
|
|
PDL::PP::Rule->new("Code", ["EquivCPOffsCode","BadFlag"], |
3100
|
|
|
|
|
|
|
"create Code from EquivCPOffsCode", |
3101
|
|
|
|
|
|
|
\&CodefromEquivCPOffsCode), |
3102
|
|
|
|
|
|
|
|
3103
|
|
|
|
|
|
|
PDL::PP::Rule->new("BackCode", ["EquivCPOffsCode","BadFlag"], |
3104
|
|
|
|
|
|
|
"create BackCode from EquivCPOffsCode", |
3105
|
|
|
|
|
|
|
\&BackCodefromEquivCPOffsCode), |
3106
|
|
|
|
|
|
|
|
3107
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::Zero->new("Affine_Ok", "EquivCPOffsCode"), |
3108
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::One->new("Affine_Ok"), |
3109
|
|
|
|
|
|
|
|
3110
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::NULL->new("ReadDataFuncName", "AffinePriv"), |
3111
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "AffinePriv"), |
3112
|
|
|
|
|
|
|
|
3113
|
|
|
|
|
|
|
PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'), |
3114
|
|
|
|
|
|
|
PDL::PP::Rule::InsertName->new("CopyFuncName", 'pdl_${name}_copy'), |
3115
|
|
|
|
|
|
|
PDL::PP::Rule::InsertName->new("FreeFuncName", 'pdl_${name}_free'), |
3116
|
|
|
|
|
|
|
PDL::PP::Rule::InsertName->new("RedoDimsFuncName", 'pdl_${name}_redodims'), |
3117
|
|
|
|
|
|
|
|
3118
|
|
|
|
|
|
|
# There used to be a BootStruct rule which just became copied to the XSBootCode |
3119
|
|
|
|
|
|
|
# rule, so it has been removed. |
3120
|
|
|
|
|
|
|
# |
3121
|
|
|
|
|
|
|
PDL::PP::Rule->new("XSBootCode", ["AffinePriv","VTableName"], |
3122
|
|
|
|
|
|
|
sub {return " $_[1].readdata = PDL->readdata_affine;\n" . |
3123
|
|
|
|
|
|
|
" $_[1].writebackdata = PDL->writebackdata_affine;\n"}), |
3124
|
|
|
|
|
|
|
|
3125
|
|
|
|
|
|
|
# Parameters in the form 'parent and child(this)'. |
3126
|
|
|
|
|
|
|
# The names are PARENT and CHILD. |
3127
|
|
|
|
|
|
|
# |
3128
|
|
|
|
|
|
|
# P2Child implicitly means "no data type changes". |
3129
|
|
|
|
|
|
|
|
3130
|
|
|
|
|
|
|
PDL::PP::Rule->new(["USParNames","USParObjs","FOOFOONoConversion","HaveThreading","NewXSName"], |
3131
|
|
|
|
|
|
|
["P2Child","Name","BadFlag"], |
3132
|
|
|
|
|
|
|
\&NewParentChildPars), |
3133
|
|
|
|
|
|
|
|
3134
|
|
|
|
|
|
|
PDL::PP::Rule::InsertName->new("NewXSName", '_${name}_int'), |
3135
|
|
|
|
|
|
|
|
3136
|
|
|
|
|
|
|
PDL::PP::Rule::Returns->new("EquivPThreadIdExpr", "P2Child", |
3137
|
|
|
|
|
|
|
'$CTID-$PARENT(ndims)+$CHILD(ndims)'), |
3138
|
|
|
|
|
|
|
|
3139
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::One->new("HaveThreading"), |
3140
|
|
|
|
|
|
|
|
3141
|
|
|
|
|
|
|
# Parameters in the 'a(x,y); [o]b(y)' format, with |
3142
|
|
|
|
|
|
|
# fixed nos of real, unthreaded-over dims. |
3143
|
|
|
|
|
|
|
# |
3144
|
|
|
|
|
|
|
# XXX |
3145
|
|
|
|
|
|
|
# - the need for BadFlag is due to hacked get_xsdatapdecl() |
3146
|
|
|
|
|
|
|
# in PP/PdlParObj and because the PdlParObjs are created by |
3147
|
|
|
|
|
|
|
# PDL::PP::Signature (Doug Burke 07/08/00) |
3148
|
|
|
|
|
|
|
|
3149
|
|
|
|
|
|
|
PDL::PP::Rule->new(["USParNames","USParObjs","DimmedPars"], ["Pars","BadFlag"], \&Pars_nft), |
3150
|
|
|
|
|
|
|
PDL::PP::Rule->new("DimObjs", ["USParNames","USParObjs"], \&ParObjs_DimObjs), |
3151
|
|
|
|
|
|
|
|
3152
|
|
|
|
|
|
|
# Set CallCopy flag for simple functions (2-arg with 0-dim signatures) |
3153
|
|
|
|
|
|
|
# This will copy the $object->copy method, instead of initialize |
3154
|
|
|
|
|
|
|
# for PDL-subclassed objects |
3155
|
|
|
|
|
|
|
# |
3156
|
|
|
|
|
|
|
PDL::PP::Rule->new("CallCopy", ["DimObjs", "USParNames", "USParObjs", "Name", "_P2Child"], |
3157
|
|
|
|
|
|
|
sub { |
3158
|
|
|
|
|
|
|
my ($dimObj, $USParNames, $USParObjs, $Name, $hasp2c) = @_; |
3159
|
|
|
|
|
|
|
return 0 if $hasp2c; |
3160
|
|
|
|
|
|
|
my $noDimmedArgs = scalar(keys %$dimObj); |
3161
|
|
|
|
|
|
|
my $noArgs = scalar(@$USParNames); |
3162
|
|
|
|
|
|
|
if( $noDimmedArgs == 0 and $noArgs == 2 ){ |
3163
|
|
|
|
|
|
|
# Check for 2-arg functgion with 0-dim signatures |
3164
|
|
|
|
|
|
|
# Check to see if output arg is _not_ explicitly typed: |
3165
|
|
|
|
|
|
|
my $arg2 = $USParNames->[1]; |
3166
|
|
|
|
|
|
|
my $ParObj = $USParObjs->{$arg2}; |
3167
|
|
|
|
|
|
|
if( $ParObj->ctype('generic') eq 'generic'){ |
3168
|
|
|
|
|
|
|
# print "Calling Copy for function '$Name'\n"; |
3169
|
|
|
|
|
|
|
return 1; |
3170
|
|
|
|
|
|
|
} |
3171
|
|
|
|
|
|
|
} |
3172
|
|
|
|
|
|
|
return 0; |
3173
|
|
|
|
|
|
|
}), |
3174
|
|
|
|
|
|
|
|
3175
|
|
|
|
|
|
|
# "Other pars", the parameters which are usually not pdls. |
3176
|
|
|
|
|
|
|
|
3177
|
|
|
|
|
|
|
PDL::PP::Rule->new(["OtherParNames","OtherParTypes"], ["OtherPars","DimObjs"], \&OtherPars_nft), |
3178
|
|
|
|
|
|
|
|
3179
|
|
|
|
|
|
|
PDL::PP::Rule->new(["ParNames","ParObjs"], ["USParNames","USParObjs"], \&sort_pnobjs), |
3180
|
|
|
|
|
|
|
|
3181
|
|
|
|
|
|
|
PDL::PP::Rule->new("DefSyms", "StructName", \&MkDefSyms), |
3182
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSArgs", ["USParNames","USParObjs","OtherParNames","OtherParTypes"], |
3183
|
|
|
|
|
|
|
\&NXArgs), |
3184
|
|
|
|
|
|
|
|
3185
|
|
|
|
|
|
|
PDL::PP::Rule::Returns->new("PMCode", undef), |
3186
|
|
|
|
|
|
|
|
3187
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSSymTab", ["DefSyms","NewXSArgs"], \&AddArgsyms), |
3188
|
|
|
|
|
|
|
|
3189
|
|
|
|
|
|
|
PDL::PP::Rule->new("InplaceCode", ["Name","NewXSArgs","USParObjs","_Inplace"], |
3190
|
|
|
|
|
|
|
'Insert code (just after HdrCode) to ensure the routine can be done inplace', |
3191
|
|
|
|
|
|
|
\&InplaceCode), |
3192
|
|
|
|
|
|
|
|
3193
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [], |
3194
|
|
|
|
|
|
|
'Code that will be inserted at the end of the autogenerated xs argument processing code VargArgsXSHdr'), |
3195
|
|
|
|
|
|
|
|
3196
|
|
|
|
|
|
|
|
3197
|
|
|
|
|
|
|
# Create header for variable argument list. Used if no 'other pars' specified. |
3198
|
|
|
|
|
|
|
# D. Hunt 4/11/00 |
3199
|
|
|
|
|
|
|
# make sure it is not used when the GlobalNew flag is set ; CS 4/15/00 |
3200
|
|
|
|
|
|
|
PDL::PP::Rule->new("VarArgsXSHdr", |
3201
|
|
|
|
|
|
|
["Name","NewXSArgs","USParObjs","OtherParTypes", |
3202
|
|
|
|
|
|
|
"PMCode","HdrCode","InplaceCode","_GlobalNew","_CallCopy","_Bitwise"], |
3203
|
|
|
|
|
|
|
'XS code to process arguments on stack based on supplied Pars argument to pp_def; GlobalNew has implications how/if this is done', |
3204
|
|
|
|
|
|
|
\&VarArgsXSHdr), |
3205
|
|
|
|
|
|
|
|
3206
|
|
|
|
|
|
|
## Added new line for returning (or not returning) variables. D. Hunt 4/7/00 |
3207
|
|
|
|
|
|
|
# make sure it is not used when the GlobalNew flag is set ; CS 4/15/00 |
3208
|
|
|
|
|
|
|
# |
3209
|
|
|
|
|
|
|
PDL::PP::Rule->new("VarArgsXSReturn", |
3210
|
|
|
|
|
|
|
["NewXSArgs","USParObjs","_GlobalNew"], |
3211
|
|
|
|
|
|
|
"Generate XS trailer for returning output variables", |
3212
|
|
|
|
|
|
|
\&VarArgsXSReturn), |
3213
|
|
|
|
|
|
|
|
3214
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSHdr", ["NewXSName","NewXSArgs"], \&XSHdr), |
3215
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSCHdrs", ["NewXSName","NewXSArgs","GlobalNew"], \&XSCHdrs), |
3216
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSLocals", "NewXSSymTab", \&Sym2Loc), |
3217
|
|
|
|
|
|
|
|
3218
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::Zero->new("IsAffineFlag"), |
3219
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::Zero->new("NoPdlThread"), |
3220
|
|
|
|
|
|
|
|
3221
|
|
|
|
|
|
|
# hmm, need to check on conditional check here (or rather, other bits of code prob need |
3222
|
|
|
|
|
|
|
# to include it too; see Ops.xs, PDL::assgn) |
3223
|
|
|
|
|
|
|
## |
3224
|
|
|
|
|
|
|
## sub { return (defined $_[0]) ? "int \$BADFLAGCACHE() = 0;" : ""; } ], |
3225
|
|
|
|
|
|
|
## |
3226
|
|
|
|
|
|
|
## why have I got a "_HandleBad" condition here? it isn't used in the routine |
3227
|
|
|
|
|
|
|
## and isn't required to fire the rule. Or should we actually check the value of |
3228
|
|
|
|
|
|
|
## HandleBad (ie to optimize for code that explicitly doesn't handle bad code)? |
3229
|
|
|
|
|
|
|
## TO DO: Check assgn in ops for this? Not obvious, or at least we need other |
3230
|
|
|
|
|
|
|
## bits of code work with us (eg the checking of $BADFLAGCACHE in some other |
3231
|
|
|
|
|
|
|
## rule) |
3232
|
|
|
|
|
|
|
## |
3233
|
|
|
|
|
|
|
## PDL::PP::Rule->new("CacheBadFlagInitNS", "_HandleBad", |
3234
|
|
|
|
|
|
|
## sub { return $bvalflag ? "\n int \$BADFLAGCACHE() = 0;\n" : ""; }), |
3235
|
|
|
|
|
|
|
PDL::PP::Rule->new("CacheBadFlagInitNS", |
3236
|
|
|
|
|
|
|
sub { PDL::PP::pp_line_numbers(__LINE__, $bvalflag ? "\n int \$BADFLAGCACHE() = 0;\n" : "") }), |
3237
|
|
|
|
|
|
|
# The next rule, if done in place of the above, causes Ops.xs to fail to compile |
3238
|
|
|
|
|
|
|
# PDL::PP::Rule->new("CacheBadFlagInitNS", "BadFlag", |
3239
|
|
|
|
|
|
|
# sub { return $_[0] ? "\n int \$BADFLAGCACHE() = 0;\n" : ""; }), |
3240
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("CacheBadFlagInit", "CacheBadFlagInitNS"), |
3241
|
|
|
|
|
|
|
|
3242
|
|
|
|
|
|
|
# need special cases for |
3243
|
|
|
|
|
|
|
# a) bad values |
3244
|
|
|
|
|
|
|
# b) bad values + GlobalNew |
3245
|
|
|
|
|
|
|
# c) bad values + PMCode |
3246
|
|
|
|
|
|
|
# - perhaps I should have separate rules (but b and c produce the |
3247
|
|
|
|
|
|
|
# same output...) |
3248
|
|
|
|
|
|
|
# |
3249
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSStructInit0", |
3250
|
|
|
|
|
|
|
["NewXSSymTab","VTableName","IsAffineFlag","NoPdlThread"], |
3251
|
|
|
|
|
|
|
"Rule to create and initialise the private trans structure", |
3252
|
|
|
|
|
|
|
\&MkPrivStructInit), |
3253
|
|
|
|
|
|
|
|
3254
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSMakeNow", ["ParNames","NewXSSymTab"], \&MakeNows), |
3255
|
|
|
|
|
|
|
PDL::PP::Rule->new("IgnoreTypesOf", "FTypes", sub {return {map {($_,1)} keys %{$_[0]}}}), |
3256
|
|
|
|
|
|
|
PDL::PP::Rule::Returns->new("IgnoreTypesOf", {}), |
3257
|
|
|
|
|
|
|
|
3258
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes", \&make_newcoerce), |
3259
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("NewXSCoerceMust", "NewXSCoerceMustNS"), |
3260
|
|
|
|
|
|
|
|
3261
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("DefaultFlowCode", "DefaultFlowCodeNS"), |
3262
|
|
|
|
|
|
|
|
3263
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSFindDatatypeNS", |
3264
|
|
|
|
|
|
|
["ParNames","ParObjs","IgnoreTypesOf","NewXSSymTab","GenericTypes","_P2Child"], |
3265
|
|
|
|
|
|
|
\&find_datatype), |
3266
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("NewXSFindDatatype", "NewXSFindDatatypeNS"), |
3267
|
|
|
|
|
|
|
|
3268
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::EmptyString->new("NewXSTypeCoerce", "NoConversion"), |
3269
|
|
|
|
|
|
|
|
3270
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSTypeCoerceNS", |
3271
|
|
|
|
|
|
|
["ParNames","ParObjs","IgnoreTypesOf","NewXSSymTab","_P2Child"], |
3272
|
|
|
|
|
|
|
\&coerce_types), |
3273
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("NewXSTypeCoerce", "NewXSTypeCoerceNS"), |
3274
|
|
|
|
|
|
|
|
3275
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::EmptyString->new("NewXSStructInit1", ["ParNames","NewXSSymTab"]), |
3276
|
|
|
|
|
|
|
|
3277
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSSetTrans", ["ParNames","ParObjs","NewXSSymTab"], \&makesettrans), |
3278
|
|
|
|
|
|
|
|
3279
|
|
|
|
|
|
|
PDL::PP::Rule->new("ParsedCode", |
3280
|
|
|
|
|
|
|
["Code","_BadCode","ParNames","ParObjs","DimObjs","GenericTypes", |
3281
|
|
|
|
|
|
|
"ExtraGenericLoops","HaveThreading","Name"], |
3282
|
|
|
|
|
|
|
sub { return PDL::PP::Code->new(@_); }), |
3283
|
|
|
|
|
|
|
PDL::PP::Rule->new("ParsedBackCode", |
3284
|
|
|
|
|
|
|
["BackCode","_BadBackCode","ParNames","ParObjs","DimObjs","GenericTypes", |
3285
|
|
|
|
|
|
|
"ExtraGenericLoops","HaveThreading","Name"], |
3286
|
|
|
|
|
|
|
sub { return PDL::PP::Code->new(@_, undef, undef, 'BackCode2'); }), |
3287
|
|
|
|
|
|
|
|
3288
|
|
|
|
|
|
|
# Compiled representations i.e. what the xsub function leaves |
3289
|
|
|
|
|
|
|
# in the trans structure. By default, copies of the parameters |
3290
|
|
|
|
|
|
|
# but in many cases (e.g. slice) a benefit can be obtained |
3291
|
|
|
|
|
|
|
# by parsing the string in that function. |
3292
|
|
|
|
|
|
|
|
3293
|
|
|
|
|
|
|
# If the user wishes to specify his own code and compiled representation, |
3294
|
|
|
|
|
|
|
# The next two definitions allow this. |
3295
|
|
|
|
|
|
|
# Because of substitutions that will be there, |
3296
|
|
|
|
|
|
|
# makecompiledrepr et al are array refs, 0th element = string, |
3297
|
|
|
|
|
|
|
# 1th element = hashref of translated names |
3298
|
|
|
|
|
|
|
# This makes the objects: type + ... |
3299
|
|
|
|
|
|
|
# |
3300
|
|
|
|
|
|
|
PDL::PP::Rule->new(["CompNames","CompObjs"], "Comp", \&OtherPars_nft), |
3301
|
|
|
|
|
|
|
PDL::PP::Rule->new("CompiledRepr", ["CompNames","CompObjs"], \&NT2Decls_p), |
3302
|
|
|
|
|
|
|
PDL::PP::Rule::MakeComp->new("MakeCompiledRepr", ["MakeComp","CompNames","CompObjs"], |
3303
|
|
|
|
|
|
|
"COMP"), |
3304
|
|
|
|
|
|
|
|
3305
|
|
|
|
|
|
|
PDL::PP::Rule->new("CompCopyCode", ["CompNames","CompObjs","CopyName"], \&NT2Copies_p), |
3306
|
|
|
|
|
|
|
PDL::PP::Rule->new("CompFreeCode", ["CompNames","CompObjs"], \&NT2Free_p), |
3307
|
|
|
|
|
|
|
|
3308
|
|
|
|
|
|
|
# This is the default |
3309
|
|
|
|
|
|
|
# |
3310
|
|
|
|
|
|
|
PDL::PP::Rule->new("MakeCompiledRepr", |
3311
|
|
|
|
|
|
|
["OtherParNames","OtherParTypes","NewXSSymTab"], |
3312
|
|
|
|
|
|
|
\&CopyOtherPars), |
3313
|
|
|
|
|
|
|
PDL::PP::Rule->new("CompiledRepr", |
3314
|
|
|
|
|
|
|
["OtherParNames","OtherParTypes"], |
3315
|
|
|
|
|
|
|
\&NT2Decls), |
3316
|
|
|
|
|
|
|
PDL::PP::Rule->new("CompCopyCode", |
3317
|
|
|
|
|
|
|
["OtherParNames","OtherParTypes","CopyName"], |
3318
|
|
|
|
|
|
|
\&NT2Copies_p), |
3319
|
|
|
|
|
|
|
PDL::PP::Rule->new("CompFreeCode", ["OtherParNames","OtherParTypes"], \&NT2Free_p), |
3320
|
|
|
|
|
|
|
|
3321
|
|
|
|
|
|
|
# Threads |
3322
|
|
|
|
|
|
|
# |
3323
|
|
|
|
|
|
|
PDL::PP::Rule->new(["Priv","PrivIsInc"], |
3324
|
|
|
|
|
|
|
["ParNames","ParObjs","DimObjs","HaveThreading"], |
3325
|
|
|
|
|
|
|
\&make_incsizes), |
3326
|
|
|
|
|
|
|
PDL::PP::Rule->new("PrivCopyCode", |
3327
|
|
|
|
|
|
|
["ParNames","ParObjs","DimObjs","CopyName","HaveThreading"], |
3328
|
|
|
|
|
|
|
\&make_incsize_copy), |
3329
|
|
|
|
|
|
|
PDL::PP::Rule->new("PrivFreeCode", |
3330
|
|
|
|
|
|
|
["ParNames","ParObjs","DimObjs","HaveThreading"], |
3331
|
|
|
|
|
|
|
"Frees the thread", |
3332
|
|
|
|
|
|
|
\&make_incsize_free), |
3333
|
|
|
|
|
|
|
|
3334
|
|
|
|
|
|
|
PDL::PP::Rule::Returns->new("RedoDimsCode", [], |
3335
|
|
|
|
|
|
|
'Code that can be inserted to set the size of output piddles dynamically based on input piddles; is parsed', |
3336
|
|
|
|
|
|
|
'PDL_COMMENT("none")'), |
3337
|
|
|
|
|
|
|
PDL::PP::Rule->new("RedoDimsParsedCode", |
3338
|
|
|
|
|
|
|
["RedoDimsCode","_BadRedoDimsCode","ParNames","ParObjs","DimObjs", |
3339
|
|
|
|
|
|
|
"GenericTypes","ExtraGenericLoops","HaveThreading","Name"], |
3340
|
|
|
|
|
|
|
'makes the parsed representation from the supplied RedoDimsCode', |
3341
|
|
|
|
|
|
|
sub { |
3342
|
|
|
|
|
|
|
return 'PDL_COMMENT("no RedoDimsCode")' |
3343
|
|
|
|
|
|
|
if $_[0] =~ m|^/[*] none [*]/$|; |
3344
|
|
|
|
|
|
|
PDL::PP::Code->new(@_,1); }), |
3345
|
|
|
|
|
|
|
PDL::PP::Rule->new("RedoDims", |
3346
|
|
|
|
|
|
|
["ParNames","ParObjs","DimObjs","DimmedPars","RedoDimsParsedCode", '_NoPthread'], |
3347
|
|
|
|
|
|
|
'makes the redodims function from the various bits and pieces', |
3348
|
|
|
|
|
|
|
\&make_redodims_thread), |
3349
|
|
|
|
|
|
|
|
3350
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::EmptyString->new("Priv"), |
3351
|
|
|
|
|
|
|
|
3352
|
|
|
|
|
|
|
PDL::PP::Rule->new(["PrivNames","PrivObjs"], "Priv", \&OtherPars_nft), |
3353
|
|
|
|
|
|
|
PDL::PP::Rule->new("PrivateRepr", ["PrivNames","PrivObjs"], \&NT2Decls_p), |
3354
|
|
|
|
|
|
|
PDL::PP::Rule->new("PrivCopyCode", ["PrivNames","PrivObjs","CopyName"], \&NT2Copies_p), |
3355
|
|
|
|
|
|
|
|
3356
|
|
|
|
|
|
|
# avoid clash with freecode above? |
3357
|
|
|
|
|
|
|
# |
3358
|
|
|
|
|
|
|
PDL::PP::Rule->new("NTPrivFreeCode", ["PrivNames","PrivObjs"], \&NT2Free_p), |
3359
|
|
|
|
|
|
|
|
3360
|
|
|
|
|
|
|
PDL::PP::Rule->new("IsReversibleCodeNS", "Reversible", \&ToIsReversible), |
3361
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("IsReversibleCode", "IsReversibleCodeNS"), |
3362
|
|
|
|
|
|
|
|
3363
|
|
|
|
|
|
|
# Needs cleaning up. NewXSStructInit2DJB has been added to make use |
3364
|
|
|
|
|
|
|
# of the PDL::PP::Rule::Substitute class. |
3365
|
|
|
|
|
|
|
# |
3366
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute->new("NewXSStructInit2DJB", "MakeCompiledRepr"), |
3367
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSStructInit2", "NewXSStructInit2DJB", |
3368
|
|
|
|
|
|
|
sub { PDL::PP::pp_line_numbers(__LINE__, "{".$_[0]."}") }), |
3369
|
|
|
|
|
|
|
|
3370
|
|
|
|
|
|
|
PDL::PP::Rule->new("CopyCodeNS", |
3371
|
|
|
|
|
|
|
["PrivCopyCode","CompCopyCode","StructName","NoPdlThread"], |
3372
|
|
|
|
|
|
|
sub { |
3373
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, |
3374
|
0
|
|
|
|
|
|
"$_[2] *__copy = malloc(sizeof($_[2])); memset(__copy, 0, sizeof($_[2]));\n" . |
3375
|
0
|
|
|
|
|
|
($_[3] ? "" : "PDL_THR_CLRMAGIC(&__copy->__pdlthread);") . |
3376
|
0
|
|
|
|
|
|
" PDL_TR_CLRMAGIC(__copy); |
3377
|
0
|
|
|
|
|
|
__copy->has_badvalue = \$PRIV(has_badvalue); |
3378
|
0
|
|
|
|
|
|
__copy->badvalue = \$PRIV(badvalue); |
3379
|
0
|
|
|
|
|
|
__copy->flags = \$PRIV(flags); |
3380
|
0
|
|
|
|
|
|
__copy->vtable = \$PRIV(vtable); |
3381
|
0
|
|
|
|
|
|
__copy->__datatype = \$PRIV(__datatype); |
3382
|
0
|
|
|
|
|
|
__copy->freeproc = NULL; |
3383
|
|
|
|
|
|
|
__copy->__ddone = \$PRIV(__ddone); |
3384
|
0
|
0
|
|
|
|
|
{int i; |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
3385
|
0
|
|
|
|
|
|
for(i=0; i<__copy->vtable->npdls; i++) |
3386
|
|
|
|
|
|
|
__copy->pdls[i] = \$PRIV(pdls[i]); |
3387
|
|
|
|
|
|
|
} |
3388
|
|
|
|
|
|
|
$_[1] |
3389
|
|
|
|
|
|
|
if(__copy->__ddone) { |
3390
|
|
|
|
|
|
|
$_[0] |
3391
|
|
|
|
|
|
|
} |
3392
|
|
|
|
|
|
|
return (pdl_trans*)__copy;") }), |
3393
|
|
|
|
|
|
|
|
3394
|
|
|
|
|
|
|
PDL::PP::Rule->new("FreeCodeNS", |
3395
|
|
|
|
|
|
|
["PrivFreeCode","CompFreeCode","NTPrivFreeCode"], |
3396
|
|
|
|
|
|
|
sub { |
3397
|
|
|
|
|
|
|
PDL::PP::pp_line_numbers(__LINE__, " |
3398
|
|
|
|
|
|
|
PDL_TR_CLRMAGIC(__privtrans); |
3399
|
55
|
|
|
|
|
|
$_[1] |
3400
|
|
|
|
|
|
|
if(__privtrans->__ddone) { |
3401
|
|
|
|
|
|
|
$_[0] |
3402
|
|
|
|
|
|
|
$_[2] |
3403
|
|
|
|
|
|
|
} |
3404
|
|
|
|
|
|
|
") }), |
3405
|
|
|
|
|
|
|
|
3406
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("CopyCode", "CopyCodeNS"), |
3407
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("FreeCode", "FreeCodeNS"), |
3408
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("FooCodeSub", "FooCode"), |
3409
|
|
|
|
|
|
|
|
3410
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMust"), |
3411
|
|
|
|
|
|
|
|
3412
|
|
|
|
|
|
|
PDL::PP::Rule::MakeComp->new("NewXSCoerceMustSub1", "NewXSCoerceMust", "FOO"), |
3413
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute->new("NewXSCoerceMustSub1d", "NewXSCoerceMustSub1"), |
3414
|
|
|
|
|
|
|
|
3415
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSClearThread", "HaveThreading", |
3416
|
|
|
|
|
|
|
sub {$_[0] ? PDL::PP::pp_line_numbers(__LINE__, "__privtrans->__pdlthread.inds = 0;") : ""}), |
3417
|
55
|
|
|
|
|
|
|
3418
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSFindBadStatusNS", |
3419
|
|
|
|
|
|
|
["BadFlag","_FindBadStatusCode","NewXSArgs","USParObjs","OtherParTypes","NewXSSymTab","Name"], |
3420
|
|
|
|
|
|
|
"Rule to find the bad value status of the input piddles", |
3421
|
|
|
|
|
|
|
\&findbadstatus), |
3422
|
|
|
|
|
|
|
|
3423
|
|
|
|
|
|
|
# this can be removed once the default bad values are stored in a C structure |
3424
|
|
|
|
|
|
|
# (rather than as a perl array in PDL::Types) |
3425
|
|
|
|
|
|
|
# which it now is, hence the comments (DJB 07/10/00) |
3426
|
|
|
|
|
|
|
# - left around in case we move to per-piddle bad values |
3427
|
|
|
|
|
|
|
# - NOTE: now we have the experimental per-piddle bad values I need to remember |
3428
|
|
|
|
|
|
|
# what I was doing here |
3429
|
|
|
|
|
|
|
# [[NewXSCopyBadValues], [BadFlag,NewXSSymTab], |
3430
|
|
|
|
|
|
|
# "copybadvalues", |
3431
|
|
|
|
|
|
|
# "Rule to copy the default bad values into the trnas structure"], |
3432
|
|
|
|
|
|
|
|
3433
|
|
|
|
|
|
|
PDL::PP::Rule->new("NewXSCopyBadStatusNS", |
3434
|
|
|
|
|
|
|
["BadFlag","_CopyBadStatusCode","NewXSArgs","USParObjs","NewXSSymTab"], |
3435
|
|
|
|
|
|
|
"Rule to copy the bad value status to the output piddles", |
3436
|
|
|
|
|
|
|
\©badstatus), |
3437
|
|
|
|
|
|
|
|
3438
|
|
|
|
|
|
|
# expand macros in ...BadStatusCode |
3439
|
|
|
|
|
|
|
# |
3440
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("NewXSFindBadStatus", "NewXSFindBadStatusNS"), |
3441
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute::Usual->new("NewXSCopyBadStatus", "NewXSCopyBadStatusNS"), |
3442
|
|
|
|
|
|
|
|
3443
|
|
|
|
|
|
|
# Generates XS code with variable argument list. If this rule succeeds, the next rule |
3444
|
|
|
|
|
|
|
# will not be executed. D. Hunt 4/11/00 |
3445
|
|
|
|
|
|
|
# |
3446
|
|
|
|
|
|
|
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], |
3447
|
|
|
|
|
|
|
["_GlobalNew","_NewXSCHdrs","VarArgsXSHdr","NewXSLocals", |
3448
|
|
|
|
|
|
|
"CacheBadFlagInit", |
3449
|
|
|
|
|
|
|
"NewXSStructInit0", |
3450
|
|
|
|
|
|
|
"NewXSFindBadStatus", |
3451
|
|
|
|
|
|
|
# NewXSCopyBadValues, |
3452
|
|
|
|
|
|
|
# NewXSMakeNow, # this is unnecessary since families never got implemented |
3453
|
|
|
|
|
|
|
"NewXSFindDatatype","NewXSTypeCoerce", |
3454
|
|
|
|
|
|
|
"NewXSStructInit1", |
3455
|
|
|
|
|
|
|
"NewXSStructInit2", |
3456
|
|
|
|
|
|
|
"NewXSCoerceMustSub1d","_IsReversibleCode","DefaultFlowCode", |
3457
|
|
|
|
|
|
|
"NewXSClearThread", |
3458
|
|
|
|
|
|
|
"NewXSSetTrans", |
3459
|
|
|
|
|
|
|
"NewXSCopyBadStatus", |
3460
|
|
|
|
|
|
|
"VarArgsXSReturn" |
3461
|
|
|
|
|
|
|
], |
3462
|
|
|
|
|
|
|
"Rule to print out XS code when variable argument list XS processing is enabled", |
3463
|
|
|
|
|
|
|
\&mkVarArgsxscat), |
3464
|
|
|
|
|
|
|
|
3465
|
|
|
|
|
|
|
# This rule will fail if the preceding rule succeeds |
3466
|
|
|
|
|
|
|
# D. Hunt 4/11/00 |
3467
|
|
|
|
|
|
|
# |
3468
|
|
|
|
|
|
|
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], |
3469
|
|
|
|
|
|
|
["_GlobalNew","_NewXSCHdrs","NewXSHdr","NewXSLocals", |
3470
|
|
|
|
|
|
|
"CacheBadFlagInit", |
3471
|
|
|
|
|
|
|
"NewXSStructInit0", |
3472
|
|
|
|
|
|
|
"NewXSFindBadStatus", |
3473
|
|
|
|
|
|
|
# NewXSCopyBadValues, |
3474
|
|
|
|
|
|
|
# NewXSMakeNow, # this is unnecessary since families never got implemented |
3475
|
|
|
|
|
|
|
"NewXSFindDatatype","NewXSTypeCoerce", |
3476
|
|
|
|
|
|
|
"NewXSStructInit1", |
3477
|
|
|
|
|
|
|
"NewXSStructInit2", |
3478
|
|
|
|
|
|
|
"NewXSCoerceMustSub1d","_IsReversibleCode","DefaultFlowCode", |
3479
|
|
|
|
|
|
|
"NewXSClearThread", |
3480
|
|
|
|
|
|
|
"NewXSSetTrans", |
3481
|
|
|
|
|
|
|
"NewXSCopyBadStatus" |
3482
|
|
|
|
|
|
|
], |
3483
|
|
|
|
|
|
|
"Rule to print out XS code when variable argument list XS processing is disabled", |
3484
|
|
|
|
|
|
|
\&mkxscat), |
3485
|
|
|
|
|
|
|
|
3486
|
|
|
|
|
|
|
PDL::PP::Rule->new("StructDecl", |
3487
|
|
|
|
|
|
|
["ParNames","ParObjs","CompiledRepr","PrivateRepr","StructName"], |
3488
|
|
|
|
|
|
|
\&mkstruct), |
3489
|
|
|
|
|
|
|
|
3490
|
|
|
|
|
|
|
# The RedoDimsSub rule is a bit weird since it takes in the RedoDims target |
3491
|
|
|
|
|
|
|
# twice (directly and via RedoDims-PostComp). Can this be cleaned up? |
3492
|
|
|
|
|
|
|
# [I don't know who put this in, or when -- but I don't understand it. CED 13-April-2015] |
3493
|
|
|
|
|
|
|
PDL::PP::Rule->new("RedoDims-PreComp", "RedoDims", |
3494
|
|
|
|
|
|
|
sub { PDL::PP::pp_line_numbers(__LINE__, $_[0] . ' $PRIV(__ddone) = 1;') }), |
3495
|
|
|
|
|
|
|
PDL::PP::Rule::MakeComp->new("RedoDims-PostComp", |
3496
|
|
|
|
|
|
|
["RedoDims-PreComp", "PrivNames", "PrivObjs"], "PRIV"), |
3497
|
|
|
|
|
|
|
|
3498
|
|
|
|
|
|
|
# RedoDimsSub is supposed to allow you to use $SIZE as an lvalue, to resize things. It hasn't |
3499
|
|
|
|
|
|
|
# worked since I can remember (at least since I started messing around with range). The reason |
3500
|
|
|
|
|
|
|
# appears to be that the SIZE macro was using the redodims argument instead of its own zeroth |
3501
|
|
|
|
|
|
|
# argument. Renaming gone wrong? Anyway I've fixed it to use $_[0] instead of $redodims in the |
3502
|
|
|
|
|
|
|
# SIZE closure. -- CED 13-April-2015 |
3503
|
|
|
|
|
|
|
PDL::PP::Rule->new("RedoDimsSub", |
3504
|
|
|
|
|
|
|
["RedoDims", "RedoDims-PostComp", "_DimObjs"], |
3505
|
|
|
|
|
|
|
sub { |
3506
|
|
|
|
|
|
|
my $redodims = $_[0]; |
3507
|
|
|
|
|
|
|
my $result = $_[1]; |
3508
|
|
|
|
|
|
|
my $dimobjs = $_[2]; |
3509
|
|
|
|
|
|
|
|
3510
|
|
|
|
|
|
|
$result->[1]{"SIZE"} = sub { |
3511
|
|
|
|
|
|
|
eval 'use PDL::IO::Dumper'; |
3512
|
|
|
|
|
|
|
croak "FOO can't get SIZE of undefined dimension (RedoDims=$redodims).\nredodims is $redodims\ndimobjs is ".sdump($dimobjs)."\n" |
3513
|
|
|
|
|
|
|
unless defined $dimobjs->{$_[0]}; # This is the closure's $_[0], not the rule definition's $_[0] |
3514
|
|
|
|
|
|
|
return $dimobjs->{$_[0]}->get_size(); |
3515
|
|
|
|
|
|
|
}; |
3516
|
|
|
|
|
|
|
return $result; |
3517
|
|
|
|
|
|
|
}), |
3518
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute->new("RedoDimsSubd", "RedoDimsSub"), |
3519
|
|
|
|
|
|
|
PDL::PP::Rule->new("RedoDimsFunc", |
3520
|
|
|
|
|
|
|
["RedoDimsSubd","FHdrInfo","RedoDimsFuncName","_P2Child"], |
3521
|
|
|
|
|
|
|
sub {wrap_vfn(@_,"redodims")}), |
3522
|
|
|
|
|
|
|
|
3523
|
|
|
|
|
|
|
PDL::PP::Rule::MakeComp->new("ReadDataSub", "ParsedCode", "FOO"), |
3524
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute->new("ReadDataSubd", "ReadDataSub"), |
3525
|
|
|
|
|
|
|
PDL::PP::Rule->new("ReadDataFunc", |
3526
|
|
|
|
|
|
|
["ReadDataSubd","FHdrInfo","ReadDataFuncName","_P2Child"], |
3527
|
|
|
|
|
|
|
sub {wrap_vfn(@_,"readdata")}), |
3528
|
|
|
|
|
|
|
|
3529
|
|
|
|
|
|
|
PDL::PP::Rule::MakeComp->new("WriteBackDataSub", "ParsedBackCode", "FOO"), |
3530
|
|
|
|
|
|
|
PDL::PP::Rule::Substitute->new("WriteBackDataSubd", "WriteBackDataSub"), |
3531
|
|
|
|
|
|
|
|
3532
|
|
|
|
|
|
|
PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_${name}_writebackdata'), |
3533
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"), |
3534
|
|
|
|
|
|
|
|
3535
|
|
|
|
|
|
|
PDL::PP::Rule->new("WriteBackDataFunc", |
3536
|
|
|
|
|
|
|
["WriteBackDataSubd","FHdrInfo","WriteBackDataFuncName","_P2Child"], |
3537
|
|
|
|
|
|
|
sub {wrap_vfn(@_,"writebackdata")}),, |
3538
|
|
|
|
|
|
|
|
3539
|
|
|
|
|
|
|
PDL::PP::Rule->new("CopyFunc", |
3540
|
|
|
|
|
|
|
["CopyCode","FHdrInfo","CopyFuncName","_P2Child"], |
3541
|
|
|
|
|
|
|
sub {wrap_vfn(@_,"copy")}), |
3542
|
|
|
|
|
|
|
PDL::PP::Rule->new("FreeFunc", |
3543
|
|
|
|
|
|
|
["FreeCode","FHdrInfo","FreeFuncName","_P2Child"], |
3544
|
|
|
|
|
|
|
sub {wrap_vfn(@_,"free")}), |
3545
|
|
|
|
|
|
|
|
3546
|
|
|
|
|
|
|
PDL::PP::Rule::Returns->new("FoofName", "FooCodeSub", "foomethod"), |
3547
|
|
|
|
|
|
|
PDL::PP::Rule->new("FooFunc", ["FooCodeSub","FHdrInfo","FoofName","_P2Child"], |
3548
|
|
|
|
|
|
|
sub {wrap_vfn(@_,"foo")}), |
3549
|
|
|
|
|
|
|
|
3550
|
|
|
|
|
|
|
PDL::PP::Rule::Returns::NULL->new("FoofName"), |
3551
|
|
|
|
|
|
|
|
3552
|
|
|
|
|
|
|
PDL::PP::Rule->new("VTableDef", |
3553
|
|
|
|
|
|
|
["VTableName","StructName","RedoDimsFuncName","ReadDataFuncName", |
3554
|
|
|
|
|
|
|
"WriteBackDataFuncName","CopyFuncName","FreeFuncName", |
3555
|
|
|
|
|
|
|
"ParNames","ParObjs","Affine_Ok","FoofName"], |
3556
|
|
|
|
|
|
|
\&def_vtable), |
3557
|
|
|
|
|
|
|
|
3558
|
|
|
|
|
|
|
# Maybe accomplish this with an InsertName rule? |
3559
|
|
|
|
|
|
|
PDL::PP::Rule->new('PMFunc', 'Name', |
3560
|
|
|
|
|
|
|
'Sets PMFunc to default symbol table manipulations', |
3561
|
|
|
|
|
|
|
sub { |
3562
|
|
|
|
|
|
|
my ($name) = @_; |
3563
|
|
|
|
|
|
|
$::PDL_IFBEGINWRAP[0].'*'.$name.' = \&'.$::PDLOBJ. |
3564
|
|
|
|
|
|
|
'::'.$name.";\n".$::PDL_IFBEGINWRAP[1] |
3565
|
|
|
|
|
|
|
} |
3566
|
|
|
|
|
|
|
), |
3567
|
|
|
|
|
|
|
|
3568
|
|
|
|
|
|
|
]; |
3569
|
|
|
|
|
|
|
|
3570
|
|
|
|
|
|
|
sub printtrans { |
3571
|
|
|
|
|
|
|
my($bar) = @_; |
3572
|
|
|
|
|
|
|
for (qw/StructDecl RedoDimsFunc ReadDataFunc WriteBackFunc |
3573
|
|
|
|
|
|
|
VTableDef NewXSCode/) { |
3574
|
|
|
|
|
|
|
print "\n\n================================================ |
3575
|
|
|
|
|
|
|
$_ |
3576
|
|
|
|
|
|
|
=========================================\n",$bar->{$_},"\n" if $::PP_VERBOSE; |
3577
|
|
|
|
|
|
|
} |
3578
|
|
|
|
|
|
|
} |
3579
|
|
|
|
|
|
|
|
3580
|
|
|
|
|
|
|
sub translate { |
3581
|
|
|
|
|
|
|
my ($pars,$tbl) = @_; |
3582
|
|
|
|
|
|
|
|
3583
|
|
|
|
|
|
|
foreach my $rule (@$tbl) { |
3584
|
|
|
|
|
|
|
$rule->apply($pars); |
3585
|
|
|
|
|
|
|
} |
3586
|
|
|
|
|
|
|
|
3587
|
|
|
|
|
|
|
# print Dumper($pars); |
3588
|
|
|
|
|
|
|
print "GOING OUT!\n" if $::PP_VERBOSE; |
3589
|
|
|
|
|
|
|
return $pars; |
3590
|
|
|
|
|
|
|
} # sub: translate() |
3591
|
|
|
|
|
|
|
|
3592
|
|
|
|
|
|
|
## End |
3593
|
|
|
|
|
|
|
# |