t/op/01-parse_ops.t

   1 #! perl
   2 # Copyright (C) 2006-2008, The Perl Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8 use Parrot::Test;
   9 use Parrot::Op;
  10 use Parrot::OpLib::core;
  11
  12 =head1 NAME
  13
  14 t/op/01-parse_ops.t - Parse core opcodes
  15
  16 =head1 SYNOPSIS
  17
  18     % prove t/op/01-parse_ops.t
  19
  20 =head1 DESCRIPTION
  21
  22 Tests that all parrot opcodes are parsed properly.
  23
  24 =cut
  25
  26 my $object_map = {
  27     i   => q<I0>,
  28     ic  => q<42>,
  29     k   => q<P0>,
  30     kc  => q<[ 'foo' ; 'bar' ]>,
  31     kic => q<[ 1 ]>,
  32     ks  => q<P0>,
  33     ksc => q<[ 'foo' ; 'bar' ]>,
  34     n   => q<N0>,
  35     nc  => q<13.013>,
  36     p   => q<P0>,
  37     pc  => undef,                  ## RT#39992 figure out how to test this type
  38     s   => q<S0>,
  39     sc  => q<'foo'>,
  40 };
  41
  42 my %parse_errors = map { $_ => 1 } qw(
  43     abs
  44     bnot
  45     bnots
  46     ceil
  47     defined
  48     delete
  49     downcase
  50     eq
  51     exists
  52     floor
  53     ge
  54     get_hll_namespace
  55     get_namespace
  56     get_root_namespace
  57     gt
  58     le
  59     lt
  60     ne
  61     neg
  62     not
  63     print
  64     set
  65     slice
  66     titlecase
  67     typeof
  68     upcase
  69     yield
  70 );
  71
  72 my %cmds;
  73
  74 ## extract the register types from each opcode
  75 for my $op (@$Parrot::OpLib::core::ops) {
  76     my @regtypes = $op->arg_types;
  77
  78     ## for now, avoid opcodes with regtypes i don't know how to represent
  79     next unless @regtypes == grep { defined $$object_map{$_} } @regtypes;
  80
  81     ## extract the basename of the opcode
  82     my $basename = $op->name;
  83
  84     ## create the argument list
  85     my $args = join ', ' => map $$object_map{$_}, @regtypes;
  86
  87     ## store the test commands
  88     $cmds{$basename}{ $basename . ' ' . $args }++;
  89     $cmds{$basename}{ $op->full_name . ' ' . $args }++;
  90 }
  91
  92 $ENV{TEST_PROG_ARGS} ||= '';
  93
  94 plan skip_all => 'IMCC cannot do parse-only with JIT enabled'
  95     if $ENV{TEST_PROG_ARGS} =~ /-j/;
  96
  97 plan skip_all => 'IMCC cannot do parse-only with switched core'
  98     if $ENV{TEST_PROG_ARGS} =~ /-S/;
  99
 100 plan tests => scalar keys %cmds;
 101
 102 for my $cmd ( sort keys %cmds ) {
 103     my @args = (
 104         ## retrieve the test commands, and trick IMCC to parse only
 105         join( $/ => 'end', sort( keys %{ $cmds{$cmd} } ), '' ),
 106         qr/^(?!error:imcc:syntax error,)/,
 107         "parsing: $cmd"
 108     );
 109
 110     if ( $parse_errors{$cmd} ) {
 111         pasm_error_output_like(@args);
 112     }
 113     else {
 114         pasm_output_like(@args);
 115     }
 116 }
 117
 118 # Local Variables:
 119 #   mode: cperl
 120 #   cperl-indent-level: 4
 121 #   fill-column: 100
 122 # End:
 123 # vim: expandtab shiftwidth=4: