config/gen/parrot_include.pm

   1 # Copyright (C) 2001-2007, The Perl Foundation.
   2 # $Id$
   3
   4 =head1 NAME
   5
   6 config/gen/parrot_include.pm - Runtime Includes
   7
   8 =head1 DESCRIPTION
   9
  10 Generates the F<runtime/parrot/include> files.
  11
  12 =cut
  13
  14 package gen::parrot_include;
  15
  16 use strict;
  17 use warnings;
  18
  19 use base qw(Parrot::Configure::Step);
  20
  21 use Parrot::Configure::Utils ':gen';
  22
  23
  24 sub _init {
  25     my $self = shift;
  26     my %data;
  27     $data{description} = q{Generate runtime/parrot/include};
  28     $data{result} = q{};
  29     $data{source_files} = [ qw(
  30         include/parrot/cclass.h
  31         include/parrot/datatypes.h
  32         include/parrot/enums.h
  33         include/parrot/events.h
  34         include/parrot/scheduler.h
  35         include/parrot/exceptions.h
  36         include/parrot/interpreter.h
  37         include/parrot/io.h
  38         include/parrot/longopt.h
  39         include/parrot/mmd.h
  40         include/parrot/resources.h
  41         include/parrot/stat.h
  42         include/parrot/string.h
  43         include/parrot/pmc.h
  44         include/parrot/warnings.h
  45         src/pmc/timer.pmc
  46         src/utils.c
  47     ) ];
  48     $data{generated_files} = [ qw(
  49         include/parrot/vtable.h
  50         include/parrot/core_pmcs.h
  51     ) ];
  52     $data{destdir} = 'runtime/parrot/include';
  53     return \%data;
  54 }
  55
  56 sub const_to_parrot {
  57     map ".macro_const $_->[0]\t$_->[1]", @_;
  58 }
  59
  60 # refactor to generate 'use constant' statements, RT#42286
  61 sub const_to_perl {
  62     map "$_->[0] => $_->[1],", @_;
  63 }
  64
  65 sub transform_name {
  66     my $action = shift;
  67
  68     return map { [ $action->( $_->[0] ), $_->[1] ] } @_;
  69 }
  70
  71 sub prepend_prefix {
  72     my $prefix = shift;
  73
  74     transform_name( sub { $prefix . $_[0] }, @_ );
  75 }
  76
  77 sub perform_directive {
  78     my ($d) = @_;
  79
  80     my @defs = prepend_prefix $d->{prefix}, @{ $d->{defs} };
  81     if ( my $subst = $d->{subst} ) {
  82         @defs = transform_name( sub { local $_ = shift; eval $subst; $_ }, @defs );
  83     }
  84     @defs;
  85 }
  86
  87 sub parse_file {
  88     my ( $file, $fh ) = @_;
  89
  90     my ( @d, %values, $last_val, $cur, $or_continues );
  91     while ( my $line = <$fh> ) {
  92         if (
  93             $line =~ m!
  94             &gen_from_(enum|def) \( ( [^)]* ) \)
  95             (?: \s+ prefix \( (\w+) \) )?
  96             (?: \s+ subst \( (s/.*?/.*?/[eig]?) \) )?
  97             !x
  98             )
  99         {
 100             $cur and die "Missing '&end_gen' in $file\n";
 101             $cur = {
 102                 type   => $1,
 103                 files  => [ split ' ', $2 ],
 104                 prefix => defined $3 ? $3 : '',
 105                 defined $4 ? ( subst => $4 ) : (),
 106             };
 107             $last_val = -1;
 108         }
 109         elsif ( $line =~ /&end_gen\b/ ) {
 110             $cur or die "Missing &gen_from_(enum|def) in $file\n";
 111             push @d, $cur;
 112             $cur = undef;
 113         }
 114
 115         $cur or next;
 116
 117         if ( $cur->{type} eq 'def' && $line =~ /^\s*#define\s+(\w+)\s+(-?\w+|"[^"]*")/ ) {
 118             push @{ $cur->{defs} }, [ $1, $2 ];
 119         }
 120         elsif ( $cur->{type} eq 'enum' ) {
 121             # Special case: enum value is or'd combination of other values
 122             if ( $or_continues ) {
 123                 $or_continues = 0;
 124                 my $last_def = $cur->{defs}->[-1];
 125                 my ($k, $v) = @{$last_def};
 126                 my @or_values = grep {defined $_} $line =~ /^\s*(-?\w+)(?:\s*\|\s*(-?\w+))*/;
 127                 for my $or (@or_values) {
 128                     if ( defined $values{$or} ) {
 129                         $v |= $values{$or};
 130                     }
 131                     elsif ( $or =~ /^0/ ) {
 132                         $v |= oct $or;
 133                     }
 134                 }
 135                 if ($line =~ /\|\s*$/) {
 136                     $or_continues = 1;
 137                 }
 138                 $values{$k} = $last_val = $v;
 139                 $cur->{defs}->[-1]->[1] = $v;
 140             }
 141             elsif ( $line =~ /^\s*(\w+)\s*=\s*(-?\w+)\s*\|/ ) {
 142                 my ( $k, $v ) = ( $1, $2 );
 143                 my @or_values = ($v, $line =~ /\|\s*(-?\w+)/g);
 144                 $v = 0;
 145                 for my $or (@or_values) {
 146                     if ( defined $values{$or} ) {
 147                         $v |= $values{$or};
 148                     }
 149                     elsif ( $or =~ /^0/ ) {
 150                         $v |= oct $or;
 151                     }
 152                 }
 153                 if ($line =~ /\|\s*$/) {
 154                     $or_continues = 1;
 155                 }
 156                 $values{$k} = $last_val = $v;
 157                 push @{ $cur->{defs} }, [ $k, $v ];
 158             }
 159             elsif ( $line =~ /^\s*(\w+)\s*=\s*(-?\w+)/ ) {
 160                 my ( $k, $v ) = ( $1, $2 );
 161                 if ( defined $values{$v} ) {
 162                     $v = $values{$v};
 163                 }
 164                 elsif ( $v =~ /^0/ ) {
 165                     $v = oct $v;
 166                 }
 167                 $values{$k} = $last_val = $v;
 168                 push @{ $cur->{defs} }, [ $k, $v ];
 169             }
 170             elsif ( $line =~ m!^\s*(\w+)\s*(?:,\s*)?(?:/\*|$)! ) {
 171                 my $k = $1;
 172                 my $v = $values{$k} = ++$last_val;
 173                 push @{ $cur->{defs} }, [ $k, $v ];
 174             }
 175         }
 176     }
 177     $cur and die "Missing '&end_gen' in $file\n";
 178
 179     return @d;
 180 }
 181
 182 sub runstep {
 183     my ( $self, $conf ) = @_;
 184     my $verbose = $conf->options->get('verbose');
 185
 186     # need vtable.h now
 187     system( $^X, "tools/build/vtable_h.pl" );
 188
 189     my @generated;
 190     for my $file ( @{ $self->{source_files} }, @{ $self->{generated_files} } ) {
 191         open my $fh, '<', $file or die "Can't open $file: $!\n";
 192         my @directives = parse_file $file, $fh;
 193         close $fh;
 194         for my $d (@directives) {
 195             my @defs = perform_directive $d;
 196             for my $target ( @{ $d->{files} } ) {
 197                 $verbose and print "$target ";
 198                 my $gen = join "\n",
 199                     ( $target =~ /\.pl$/ ? \&const_to_perl : \&const_to_parrot )->(@defs);
 200                 $conf->append_configure_log(qq{$self->{destdir}/$target});
 201                 my $target_tmp = "$target.tmp";
 202                 open my $out, '>', $target_tmp or die "Can't open $target_tmp: $!\n";
 203
 204                 # refactor to include package declarations and Export
 205                 # declarations for generated Perl constant modules, RT#42286
 206                 print $out <<"EOF";
 207 # DO NOT EDIT THIS FILE.
 208 #
 209 # This file is generated automatically from
 210 # $file by config/gen/parrot_include.pm
 211 #
 212 # Any changes made here will be lost.
 213 #
 214 $gen
 215 EOF
 216                 close $out or die "Can't write $target_tmp: $!\n";
 217                 $target =~ m[/] or $target = "$self->{destdir}/$target";
 218                 move_if_diff( $target_tmp, $target );
 219                 push @generated, $target;
 220             }
 221         }
 222     }
 223     $conf->data->set( TEMP_gen_pasm_includes => join( " \\\n    ", @generated ) );
 224
 225     return 1;
 226 }
 227
 228 1;
 229
 230 # Local Variables:
 231 #   mode: cperl
 232 #   cperl-indent-level: 4
 233 #   fill-column: 100
 234 # End:
 235 # vim: expandtab shiftwidth=4: