File Coverage

blib/lib/PDLA/PP.pm
Criterion Covered Total %
statement 725 1021 71.0
branch 148 386 38.3
condition 28 105 26.6
subroutine 127 165 76.9
pod 17 88 19.3
total 1045 1765 59.2


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