| 1 | #!/usr/bin/env perl |
| 2 | |
| 3 | ## The pir for t/op/string_cmp.t was generated from this |
| 4 | |
| 5 | use strict; |
| 6 | use warnings; |
| 7 | |
| 8 | my ( $subs, $count, $calls ); |
| 9 | |
| 10 | # Generate code to compare each pair of strings in a list |
| 11 | sub 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 | } |
| 63 | my @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 | |
| 96 | print <<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 | |
| 103 | t/op/string.t - Parrot Strings |
| 104 | |
| 105 | =head1 SYNOPSIS |
| 106 | |
| 107 | % prove t/op/string.t |
| 108 | |
| 109 | =head1 DESCRIPTION |
| 110 | |
| 111 | Tests 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 : |
| 131 | TEMPLATE |
| 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 : |