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