t/op/cc_params_old.t

   1 #!perl
   2 # Copyright (C) 2007, Parrot Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8 use Test::More;
   9 use Parrot::Test 'no_plan';
  10
  11 =head1 NAME
  12
  13 t/op/cc_params.t - Parrot Calling Conventions parameter matching tests
  14
  15 =head1 SYNOPSIS
  16
  17     % prove t/op/cc_params.t
  18
  19 =head1 DESCRIPTION
  20
  21 Tests Parrot calling conventions for parameter matching and mismatching.
  22
  23 =cut
  24
  25 my $t_testbody = <<'TESTBODY';
  26 .sub 'test' :main
  27     .include 'errors.pasm'
  28     errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
  29     errorson .PARROT_ERRORS_RESULT_COUNT_FLAG
  30
  31 @INIT_ARGS@
  32 @INIT_RESULTS@
  33
  34     (@LIST_RESULTS@) = '@FUNC@'(@LIST_ARGS@)
  35     print "ok\n"
  36 .end
  37
  38 .sub '@FUNC@'
  39 @INIT_PARAMS@
  40 @INIT_RETURNS@
  41 @CHECK_PARAMS@
  42     .return(@LIST_RETURNS@)
  43 .end
  44 TESTBODY
  45
  46 my $t_expbody = <<'EXPBODY';
  47 @CHECK_RESULTS@
  48 EXPBODY
  49
  50 ## loop over test cases
  51 ## expected in
  52 for my $c_args ( 0 .. 1 ) {
  53     ## expected out
  54     for my $c_results ( 0 .. 1 ) {
  55         ## got in
  56         for my $c_params ( 0 .. ( $c_args ? 2 : 1 ) ) {
  57             ## got out
  58             for my $c_returns ( 0 .. ( $c_results ? 2 : 1 ) ) {
  59                 my $td = TemplateData->new;
  60
  61                 ## initialize template keys
  62                 for ( $t_testbody =~ m/@(\w+)@/g ) { $td->addkey($_) }
  63
  64                 for ( $t_expbody =~ m/@(\w+)@/g ) { $td->addkey($_) }
  65
  66                 ## initialize template data
  67                 $td->initialize( $c_args, $c_params, $c_returns, $c_results );
  68
  69                 ## generate tests and results
  70                 my $testbody = $td->generate($t_testbody);
  71                 my $expbody  = $td->generate($t_expbody);
  72                 my $testhead = create_test_header( $c_args, $c_results, $c_params, $c_returns, );
  73
  74                 ## execute tests
  75                 if ( $expbody eq "ok\n" ) {
  76                     pir_output_like( $testbody, "/$expbody/", $testhead );
  77                 }
  78                 else {
  79                     pir_error_output_like( $testbody, "/$expbody/", $testhead );
  80                 }
  81             }
  82         }
  83     }
  84 }
  85
  86 exit;
  87
  88 sub create_test_header {
  89     return 'param mismatch: args:'
  90         . shift()
  91         . ' results:'
  92         . shift()
  93         . ' params:'
  94         . shift()
  95         . ' returns:'
  96         . shift();
  97
  98 }
  99
 100 package TemplateData;
 101
 102 sub new { bless {} => shift; }
 103 sub addkey { my $self = shift; $self->{$_} = '' for @_ }
 104
 105 sub create_args {
 106     my $self = shift;
 107     my $num  = shift;
 108
 109     $self->{C_ARGS} = $num;
 110
 111     if ( $self->{C_ARGS} ) {
 112         $self->{_ARGS} = [ map { 'arg' . $_ } 1 .. $num ];
 113         $self->{LIST_ARGS} = join ', ' => @{ $self->{_ARGS} };
 114         $self->{INIT_ARGS} = '    .local int ' . $self->{LIST_ARGS} . $/;
 115         $self->{INIT_ARGS} .= "    ${ $self->{_ARGS} }[$_] = $_$/" for 0 .. $#{ $self->{_ARGS} };
 116     }
 117 }
 118
 119 sub create_params {
 120     my $self = shift;
 121     my $num  = shift;
 122
 123     $self->{C_PARAMS} = $num;
 124
 125     if ( $self->{C_PARAMS} ) {
 126         $self->{_PARAMS} = [ map { 'param' . $_ } 1 .. $num ];
 127         $self->{LIST_PARAMS} = join ', ' => @{ $self->{_PARAMS} };
 128         $self->{INIT_PARAMS} =
 129             join( "\n" => map { '    .param int ' . ${ $self->{_PARAMS} }[$_] }
 130                 0 .. $#{ $self->{_PARAMS} } );
 131     }
 132     else {
 133         $self->{INIT_PARAMS} = q{    get_params '()'};
 134     }
 135 }
 136
 137 sub create_returns {
 138     my $self = shift;
 139     my $num  = shift;
 140
 141     $self->{C_RETURNS} = $num;
 142
 143     if ( $self->{C_RETURNS} ) {
 144         $self->{_RETURNS} = [ map { 'return' . $_ } 1 .. $num ];
 145         $self->{LIST_RETURNS} = join ', ' => @{ $self->{_RETURNS} };
 146         $self->{INIT_RETURNS} = '    .local int ' . $self->{LIST_RETURNS} . $/;
 147         $self->{INIT_RETURNS} .= "    ${ $self->{_RETURNS} }[$_] = $_$/"
 148             for 0 .. $#{ $self->{_RETURNS} };
 149     }
 150 }
 151
 152 sub create_results {
 153     my $self = shift;
 154     my $num  = shift;
 155
 156     $self->{C_RESULTS} = $num;
 157
 158     if ( $self->{C_RESULTS} ) {
 159         $self->{_RESULTS} = [ map { 'result' . $_ } 1 .. $num ];
 160         $self->{LIST_RESULTS} = join ', ' => @{ $self->{_RESULTS} };
 161         $self->{INIT_RESULTS} =
 162             join "\n" => ( map { '    .local int ' . $_ } @{ $self->{_RESULTS} } );
 163     }
 164 }
 165
 166 sub create_func {
 167     my $self = shift;
 168     my ( $c_args, $c_params, $c_returns, $c_results ) = @_;
 169
 170     $self->{FUNC} =
 171         'args' . $c_args
 172         . '_results'
 173         . $c_results
 174         . '__params'
 175         . $c_params
 176         . '_returns'
 177         . $c_returns;
 178 }
 179
 180 sub create_check_results {
 181     my $self = shift;
 182     my ( $c_args, $c_params, $c_returns, $c_results ) = @_;
 183
 184     $self->{CHECK_RESULTS} =
 185         ( ( $c_args == $c_params ) and ( $c_results == $c_returns ) )
 186         ? 'ok'
 187         : 'too (many|few) ((positional|named) (arguments|returns)).*';
 188 }
 189
 190 sub initialize {
 191     my $self = shift;
 192     my ( $c_args, $c_params, $c_returns, $c_results ) = @_;
 193
 194     $self->create_args($c_args);
 195     $self->create_params($c_params);
 196     $self->create_returns($c_returns);
 197     $self->create_results($c_results);
 198
 199     $self->create_func( $c_args, $c_params, $c_returns, $c_results );
 200
 201     $self->create_check_results( $c_args, $c_params, $c_returns, $c_results );
 202 }
 203
 204 sub generate {
 205     my $self = shift;
 206     my ($template) = @_;
 207
 208     for ( $template =~ m/@(\w+)@/g ) {
 209         my $replacement = ( exists $self->{$_} and defined $self->{$_} ) ? $self->{$_} : '';
 210
 211         $template =~ s/@(\w+)@/$replacement/;
 212     }
 213     return $template;
 214 }
 215
 216 # Local Variables:
 217 #   mode: cperl
 218 #   cperl-indent-level: 4
 219 #   fill-column: 100
 220 # End:
 221 # vim: expandtab shiftwidth=4: