Ticket #1114: gen_string_cmp.pl.patch

File gen_string_cmp.pl.patch, 4.2 KB (added by mgrimes, 12 years ago)

  • tools/dev/gen_string_cmp.pl

     
     1#!/usr/bin/env perl 
     2 
     3## The pir for t/op/string_cmp.t was generated from this 
     4 
     5use strict; 
     6use warnings; 
     7 
     8my ( $subs, $count, $calls ); 
     9 
     10# Generate code to compare each pair of strings in a list 
     11sub compare_strings { 
     12    my $const   = shift; 
     13    my $op      = shift; 
     14    my $desc    = shift; 
     15    my @strings = @_; 
     16    my $i       = 1; 
     17    my $rt; 
     18 
     19    $calls .= "    test_${desc}()\n"; 
     20 
     21    $rt .= ".sub test_${desc}\n"; 
     22 
     23    while (@strings) { 
     24        my $s1 = shift @strings; 
     25        my $s2 = shift @strings; 
     26        my $arg1; 
     27        my $arg2; 
     28        if ( $const == 3 ) { 
     29            $arg1 = "\"$s1\""; 
     30            $arg2 = "\"$s2\""; 
     31        } elsif ( $const == 2 ) { 
     32            $rt .= "    set \$S0, \"$s1\"\n"; 
     33            $arg1 = "\$S0"; 
     34            $arg2 = "\"$s2\""; 
     35        } elsif ( $const == 1 ) { 
     36            $rt .= "    set \$S0, \"$s2\"\n"; 
     37            $arg1 = "\"$s1\""; 
     38            $arg2 = "\$S0"; 
     39        } else { 
     40            $rt .= "    set \$S0, \"$s1\"\n"; 
     41            $rt .= "    set \$S1, \"$s2\"\n"; 
     42            $arg1 = "\$S0"; 
     43            $arg2 = "\$S1"; 
     44        } 
     45        if ( eval "\"$s1\" $op \"$s2\"" ) { 
     46            $rt .= "    $op $arg1, $arg2, OK$i\n"; 
     47            $rt .= "    branch ERROR\n"; 
     48        } else { 
     49            $rt .= "    $op $arg1, $arg2, ERROR\n"; 
     50        } 
     51        $rt .= "  OK$i:\n"; 
     52        $i++; 
     53    } 
     54 
     55    $rt .= "    ok( 1, '$desc' )\n"; 
     56    $rt .= "    goto END\n"; 
     57    $rt .= "  ERROR:\n"; 
     58    $rt .= "   ok( 0, '$desc' ) \n "; 
     59    $rt .= "  END:\n"; 
     60    $rt .= ".end\n\n"; 
     61    return $rt; 
     62} 
     63my @strings = ( 
     64    "hello", "hello",   "hello",   "world",   "world",   "hello", 
     65    "hello", "hellooo", "hellooo", "hello",   "hello",   "hella", 
     66    "hella", "hello",   "hella",   "hellooo", "hellooo", "hella", 
     67    "hElLo", "HeLlO",   "hElLo",   "hElLo" 
     68); 
     69 
     70$count = 4 * 6; 
     71$subs .= compare_strings( 0, "eq", 'eq_s_s_ic',   @strings, ); 
     72$subs .= compare_strings( 1, "eq", 'eq_sc_s_ic',  @strings, ); 
     73$subs .= compare_strings( 2, "eq", 'eq_s_sc_ic',  @strings, ); 
     74$subs .= compare_strings( 3, "eq", 'eq_sc_sc_ic', @strings, ); 
     75$subs .= compare_strings( 0, "ne", 'ne_s_s_ic',   @strings, ); 
     76$subs .= compare_strings( 1, "ne", 'ne_sc_s_ic',  @strings, ); 
     77$subs .= compare_strings( 2, "ne", 'ne_s_sc_ic',  @strings, ); 
     78$subs .= compare_strings( 3, "ne", 'ne_sc_sc_ic', @strings, ); 
     79$subs .= compare_strings( 0, "lt", 'lt_s_s_ic',   @strings, ); 
     80$subs .= compare_strings( 1, "lt", 'lt_sc_s_ic',  @strings, ); 
     81$subs .= compare_strings( 2, "lt", 'lt_s_sc_ic',  @strings, ); 
     82$subs .= compare_strings( 3, "lt", 'lt_sc_sc_ic', @strings, ); 
     83$subs .= compare_strings( 0, "le", 'le_s_s_ic',   @strings, ); 
     84$subs .= compare_strings( 1, "le", 'le_sc_s_ic',  @strings, ); 
     85$subs .= compare_strings( 2, "le", 'le_s_sc_ic',  @strings, ); 
     86$subs .= compare_strings( 3, "le", 'le_sc_sc_ic', @strings, ); 
     87$subs .= compare_strings( 0, "gt", 'gt_s_s_ic',   @strings, ); 
     88$subs .= compare_strings( 1, "gt", 'gt_sc_s_ic',  @strings, ); 
     89$subs .= compare_strings( 2, "gt", 'gt_s_sc_ic',  @strings, ); 
     90$subs .= compare_strings( 3, "gt", 'gt_sc_sc_ic', @strings, ); 
     91$subs .= compare_strings( 0, "ge", 'ge_s_s_ic',   @strings, ); 
     92$subs .= compare_strings( 1, "ge", 'ge_sc_s_ic',  @strings, ); 
     93$subs .= compare_strings( 2, "ge", 'ge_s_sc_ic',  @strings, ); 
     94$subs .= compare_strings( 3, "ge", 'ge_sc_sc_ic', @strings, ); 
     95 
     96print <<TEMPLATE; 
     97#! parrot 
     98# Copyright (C) 2001-2009, Parrot Foundation. 
     99# \$Id: string.t 41325 2009-09-17 19:39:19Z NotFound \$ 
     100 
     101=head1 NAME 
     102 
     103t/op/string.t - Parrot Strings 
     104 
     105=head1 SYNOPSIS 
     106 
     107     % prove t/op/string.t 
     108 
     109=head1 DESCRIPTION 
     110 
     111Tests Parrot string registers and operations. 
     112 
     113=cut 
     114 
     115.sub main :main 
     116    .include 'test_more.pir' 
     117 
     118    plan($count) 
     119 
     120    $calls 
     121.end 
     122 
     123$subs 
     124 
     125# Local Variables: 
     126#   mode: pir 
     127#   cperl-indent-level: 4 
     128#   fill-column: 100 
     129# End: 
     130# vim: expandtab shiftwidth=4 ft=pir : 
     131TEMPLATE 
     132 
     133# Local Variables: 
     134#   mode: perl 
     135#   cperl-indent-level: 4 
     136#   fill-column: 100 
     137# End: 
     138# vim: expandtab shiftwidth=4 ft=perl :