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;