File Coverage

/usr/local/lib/perl5/site_perl/5.26.1/x86_64-linux/PDL/PP.pm
Criterion Covered Total %
statement 104 212 49.0
branch 185 878 21.0
condition n/a
subroutine n/a
pod n/a
total 289 1090 26.5


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