1# These are suspended for now...
2
3# use blib; # For Types.pm
4# require './PP.pm';
5
6open PP, "PP.pm" or die "can't open PP.pm";
7$str = join '',<PP>;
8$str =~ m|\@PDL::PP::EXPORT\s*=\s*qw/([^/]*)/|s;
9$str = $1; # Get the contents of the qw//
10
11
12$pm = '
13=head1 NAME
14
15PDL::PP::Dump -- dump pp_xxx calls to stdout
16
17=head1 SYNOPSIS
18
19   perl -MPDL::PP::Dump Basic/Ops/ops.pd
20
21=head1 DESCRIPTION
22
23The most basic PP script debugger thinkable.
24
25=head1 AUTHOR
26
27Christian Soeller <c.soeller@auckland.ac.nz> .
28
29=cut
30
31package PDL::PP::Dump;
32
33use Exporter;
34@ISA = Exporter;
35
36@EXPORT = qw('.$str.q|);
37
38my $typecheck =0;
39
40sub import {
41	my ($pack,$arg) = @_;
42	$typecheck =1 if defined $arg && $arg =~ /^typecheck$/i;
43        @_ = ($pack);
44        goto &Exporter::import;
45}
46
47sub printargs {
48  my $name = shift;
49  print "$name(";
50  print join ',',map("'$_'",@_);
51  print ");\n";
52}
53
54for (@EXPORT) {
55  if ($_ !~ /pp_def/) {
56    my $def = "sub $_ { printargs($_,\@_) unless \$typecheck }";
57    # print "defining =>\n$def\n";
58    eval($def);
59  }
60}
61
62sub pp_def {
63   my($name,%hash) = @_;
64   use PDL::Types ':All';
65
66   if ($typecheck) {
67    my @alltypes = ppdefs; my $jointypes = join '',@alltypes;
68    my $types = exists $hash{GenericTypes} ? $hash{GenericTypes} : [@alltypes];
69    for my $key (qw/Code BackCode/) {
70      if (exists $hash{$key}) {
71         while ($hash{$key} =~ s/\$T([a-zA-Z]+)\s*\(([^)]*)\)//) {
72           my ($mactypes,$alternatives) = ($1,$2);
73           # print "type macro ($mactypes) in $name\n";
74	   my @mactypes = split '', $mactypes;
75	   print "$name has extra types in macro: $mactypes vs $jointypes\n"
76	     unless $mactypes =~ /^\s*[$jointypes]+\s*$/;
77	   for my $gt (@$types) {
78             print "$name has no Macro for generic type $gt (has $mactypes)"
79	      unless grep {$gt eq $_} @mactypes;
80	   }
81         }
82      }
83    }
84   } else {
85       print "pp_def('$name',\n";
86	 foreach (keys(%hash)) {
87	   if ($_ =~ /(Generic)*Types/) {
88	    print "$_ => [" . join(',',@{$hash{$_}}) . "]\n";
89	   } else {
90	    print "$_ =>\n'".$hash{$_}."',\n";
91	   }
92	 }
93       print ");\n";
94   }
95}
96
971;
98|;
99
100print $pm;
101
102