add new comparison method rgb_difference that resembles arithmetical difference per...
[imager.git] / regops.perl
1 #!perl -w
2 use strict;
3 use Data::Dumper;
4 my $in = shift or die "No input name";
5 my $out = shift or die "No output name";
6 open(IN, $in) or die "Cannot open input $in: $!";
7 open(OUT, "> $out") or die "Cannot create $out: $!";
8 binmode OUT;
9 print OUT <<'EOS';
10 # AUTOMATICALLY GENERATED BY regops.perl
11 package Imager::Regops;
12 use 5.006;
13 use strict;
14 require Exporter;
15 our @ISA = qw(Exporter);
16 our @EXPORT_OK = qw(%Attr $MaxOperands $PackCode);
17 our $VERSION = "1.000";
18
19 EOS
20 my @ops;
21 my %attr;
22 my $opcode = 0;
23 my $max_opr = 0;
24 my $reg_pack;
25 while (<IN>) {
26   if (/^\s*rbc_(\w+)/) {
27     my $op = $1;
28     push(@ops, uc "RBC_$op");
29     # each line has a comment with the registers used - find the maximum
30     # I could probably do this as one line, but let's not
31     my @parms = /\b([rp][a-z])\b/g;
32     $max_opr = @parms if @parms > $max_opr;
33     my $types = join("", map {substr($_,0,1)} @parms);
34     my ($result) = /->\s*([rp])/;
35     $attr{$op} = { parms=>scalar @parms,
36                    types=>$types,
37                    func=>/\w+\(/?1:0,
38                    opcode=>$opcode,
39                    result=>$result
40                  };
41     print OUT "use constant RBC_\U$op\E => $opcode;\n";
42     ++$opcode;
43   }
44   if (/^\#define RM_WORD_PACK \"(.)\"/) {
45     $reg_pack = $1; 
46   }
47 }
48 print OUT "\nour \@EXPORT = qw(@ops);\n\n";
49 # previously we used Data::Dumper, with Sortkeys() 
50 # to make sure the generated code only changed when the data
51 # changed.  Unfortunately Sortkeys isn't supported in some versions of
52 # perl we try to support, so we now generate this manually
53 print OUT "our %Attr =\n  (\n";
54 for my $opname (sort keys %attr) {
55   my $op = $attr{$opname};
56   print OUT "  '$opname' =>\n    {\n";
57   for my $attrname (sort keys %$op) {
58     my $attr = $op->{$attrname};
59     print OUT "    '$attrname' => ";
60     if (defined $attr) {
61       if ($attr =~ /^\d+$/) {
62         print OUT $attr;
63       }
64       else {
65         print OUT "'$attr'";
66       }
67     }
68     else {
69       print OUT "undef";
70     }
71
72     print OUT ",\n";
73   }
74   print OUT "    },\n";
75 }
76 print OUT "  );\n";
77 print OUT "our \$MaxOperands = $max_opr;\n";
78 print OUT qq/our \$PackCode = "$reg_pack";\n/;
79 print OUT <<'EOS';
80 1;
81
82 __END__
83
84 =head1 NAME
85
86 Imager::Regops - generated information about the register based virtual machine
87
88 =head1 SYNOPSIS
89
90   use Imager::Regops;
91   $Imager::Regops::Attr{$opname}->{opcode} # opcode for given operator
92   $Imager::Regops::Attr{$opname}->{parms} # number of parameters
93   $Imager::Regops::Attr{$opname}->{types} # types of parameters
94   $Imager::Regops::Attr{$opname}->{func} # operator is a function
95   $Imager::Regops::Attr{$opname}->{result} # r for numeric, p for pixel result
96   $Imager::Regops::MaxOperands; # maximum number of operands
97
98 =head1 DESCRIPTION
99
100 This module is generated automatically from F<regmach.h> so we don't need to
101 maintain the same information in at least one extra place.
102
103 At least that's the idea.
104
105 =head1 AUTHOR
106
107 Tony Cook, tony@develop-help.com
108
109 =head1 SEE ALSO
110
111 perl(1), Imager(3), http://imager.perl.org/
112
113 =cut
114
115 EOS
116 close(OUT) or die "Cannot close $out: $!";
117 close IN;