[svn:parrot] r41906 - in trunk: . t/op
dukeleto at svn.parrot.org
dukeleto at svn.parrot.org
Sat Oct 17 20:46:55 UTC 2009
Author: dukeleto
Date: Sat Oct 17 20:46:53 2009
New Revision: 41906
URL: https://trac.parrot.org/parrot/changeset/41906
Log:
[t][TT #1114] Convert t/op/string.t, t/op/arithmetics_pmc.t, t/op/arithmetics.t, t/op/arithmetics to PIR, mgrimes++
Added:
trunk/t/op/string_cmp.t (contents, props changed)
Modified:
trunk/MANIFEST
trunk/t/op/64bit.t
trunk/t/op/arithmetics.t
trunk/t/op/arithmetics_pmc.t
trunk/t/op/string.t
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST Sat Oct 17 20:46:50 2009 (r41905)
+++ trunk/MANIFEST Sat Oct 17 20:46:53 2009 (r41906)
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Thu Oct 15 07:39:41 2009 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Sat Oct 17 19:57:22 2009 UT
#
# See below for documentation on the format of this file.
#
@@ -1768,6 +1768,7 @@
t/op/sprintf_tests [test]
t/op/string.t [test]
t/op/string_cclass.t [test]
+t/op/string_cmp.t [test]
t/op/string_cs.t [test]
t/op/string_mem.t [test]
t/op/stringu.t [test]
Modified: trunk/t/op/64bit.t
==============================================================================
--- trunk/t/op/64bit.t Sat Oct 17 20:46:50 2009 (r41905)
+++ trunk/t/op/64bit.t Sat Oct 17 20:46:53 2009 (r41906)
@@ -1,14 +1,7 @@
-#!perl
-# Copyright (C) 2001-2005, Parrot Foundation.
+#!parrot
+# Copyright (C) 2001-2009, Parrot Foundation.
# $Id$
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-use Test::More;
-use Parrot::Test;
-use Parrot::Config;
-
=head1 NAME
t/op/64bit.t - Testing integer ops on 64-bit platforms
@@ -24,45 +17,54 @@
=cut
-## remember to change the number of tests :-)
-if ( $PConfig{intvalsize} == 8 ) {
- plan tests => 1;
-}
-else {
- plan skip_all => "64bit INTVAL platforms only";
-}
+.sub main :main
+ .include "iglobals.pasm"
+ .include 'test_more.pir'
+
+ # Check to see if this is 64 bit
+ .local pmc interp # a handle to our interpreter object.
+ interp = getinterp
+ .local pmc config
+ config = interp[.IGLOBALS_CONFIG_HASH]
+ .local int intvalsize
+ intvalsize = config['intvalsize']
+
+ plan(5)
+
+ if intvalsize == 8 goto is_64_bit
+ skip(5, "this is not a 64 bit platform")
+ goto end
-pasm_output_is( <<'CODE', <<'OUTPUT', "bitops64" );
+ is_64_bit:
+ bitops64()
+
+ end:
+.end
+
+
+.sub bitops64
# check bitops for 8-byte ints
- set I0, 0xffffffffffffffff
- print I0 # -1
- print "\n"
- set I1, 0x00000000ffffffff
- print I1 # 4294967295
- print "\n"
- set I0, I1
- shl I0, I0, 32
- print I0 # -4294967296
- print "\n"
- band I2, I0, I1
- print I2 # 0
- print "\n"
- bor I2, I0, I1
- print I2 # -1
- print "\n"
- end
-
-CODE
--1
-4294967295
--4294967296
-0
--1
-OUTPUT
+
+ set $I0, 0xffffffffffffffff
+ is( $I0, -1, 'bitops64' )
+
+ set $I1, 0x00000000ffffffff
+ is( $I1, 4294967295, 'bitops64' )
+
+ set $I0, $I1
+ shl $I0, $I0, 32
+ is( $I0, -4294967296, 'bitops64' )
+
+ band $I2, $I0, $I1
+ is( $I2, 0, 'bitops64' )
+
+ bor $I2, $I0, $I1
+ is( $I2, -1, 'bitops64' )
+.end
# Local Variables:
-# mode: cperl
+# mode: pir
# cperl-indent-level: 4
# fill-column: 100
# End:
-# vim: expandtab shiftwidth=4:
+# vim: expandtab shiftwidth=4 ft=pir:
Modified: trunk/t/op/arithmetics.t
==============================================================================
--- trunk/t/op/arithmetics.t Sat Oct 17 20:46:50 2009 (r41905)
+++ trunk/t/op/arithmetics.t Sat Oct 17 20:46:53 2009 (r41906)
@@ -1,17 +1,7 @@
-#!perl
+#!parrot
# Copyright (C) 2001-2009, Parrot Foundation.
# $Id$
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-
-use Test::More;
-use Parrot::Test tests => 21;
-
-# test for GMP
-use Parrot::Config;
-
=head1 NAME
t/op/arithmetics.t - Arithmetic Ops
@@ -27,577 +17,513 @@
=cut
+.sub main :main
+ .include 'test_more.pir'
+
+ plan(125)
+
+ take_the_negative_of_a_native_integer()
+ take_the_absolute_of_a_native_integer()
+ add_native_integer_to_native_integer()
+ subtract_native_integer_from_native_integer()
+ multiply_native_integer_with_native_integer()
+ divide_native_integer_by_native_integer()
+ negate_minus_zero_point_zero()
+ negate_a_native_number()
+ take_the_absolute_of_a_native_number()
+ ceil_of_a_native_number()
+ floor_of_a_native_number()
+ add_native_integer_to_native_number()
+ subtract_native_integer_from_native_number()
+ multiply_native_number_with_native_integer()
+ divide_native_number_by_native_integer()
+ add_native_number_to_native_number()
+ subtract_native_number_from_native_number()
+ multiply_native_number_with_native_number()
+ divide_native_number_by_native_number()
+ lcm_test()
+ integer_overflow_with_pow()
+ # END_OF_TESTS
+
+.end
+
#
# Operations on a single INTVAL
#
-pasm_output_is( <<'CODE', <<OUTPUT, "take the negative of a native integer" );
- set I0, 0
- neg I0
- say I0
- set I0, 1234567890
- neg I0
- say I0
- set I0, -1234567890
- neg I0
- say I0
- set I0, 0
- set I1, 0
- neg I1, I0
- say I1
- set I0, 1234567890
- neg I1, I0
- say I1
- set I0, -1234567890
- neg I1, I0
- say I1
- end
-CODE
-0
--1234567890
-1234567890
-0
--1234567890
-1234567890
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "take the absolute of a native integer" );
- set I0, 0
- abs I0
- say I0
- set I0, 1234567890
- abs I0
- say I0
- set I0, -1234567890
- abs I0
- say I0
- set I0, 0
- set I1, 0
- abs I1, I0
- say I1
- set I0, 1234567890
- abs I1, I0
- say I1
- set I0, -1234567890
- abs I1, I0
- say I1
- end
-CODE
-0
-1234567890
-1234567890
-0
-1234567890
-1234567890
-OUTPUT
+.sub take_the_negative_of_a_native_integer
+ set $I0, 0
+ neg $I0
+ is( $I0, "0", 'take_the_negative_of_a_native_integer' )
+
+ set $I0, 1234567890
+ neg $I0
+ is( $I0, "-1234567890", 'take_the_negative_of_a_native_integer' )
+
+ set $I0, -1234567890
+ neg $I0
+ is( $I0, "1234567890", 'take_the_negative_of_a_native_integer' )
+
+ set $I0, 0
+ set $I1, 0
+ neg $I1, $I0
+ is( $I1, "0", 'take_the_negative_of_a_native_integer' )
+
+ set $I0, 1234567890
+ neg $I1, $I0
+ is( $I1, "-1234567890", 'take_the_negative_of_a_native_integer' )
+
+ set $I0, -1234567890
+ neg $I1, $I0
+ is( $I1, "1234567890", 'take_the_negative_of_a_native_integer' )
+.end
+.sub take_the_absolute_of_a_native_integer
+ set $I0, 0
+ abs $I0
+ is( $I0, "0", 'take_the_absolute_of_a_native_integer' )
+
+ set $I0, 1234567890
+ abs $I0
+ is( $I0, "1234567890", 'take_the_absolute_of_a_native_integer' )
+
+ set $I0, -1234567890
+ abs $I0
+ is( $I0, "1234567890", 'take_the_absolute_of_a_native_integer' )
+
+ set $I0, 0
+ set $I1, 0
+ abs $I1, $I0
+ is( $I1, "0", 'take_the_absolute_of_a_native_integer' )
+
+ set $I0, 1234567890
+ abs $I1, $I0
+ is( $I1, "1234567890", 'take_the_absolute_of_a_native_integer' )
+
+ set $I0, -1234567890
+ abs $I1, $I0
+ is( $I1, "1234567890", 'take_the_absolute_of_a_native_integer' )
+.end
+
#
# first arg is INTVAL, second arg is INTVAL
#
-pasm_output_is( <<'CODE', <<OUTPUT, "add native integer to native integer" );
- set I0, 4000
- set I1, -123
- add I2, I0, I1
- say I2
- add I0, I0, I1
- say I0
- end
-CODE
-3877
-3877
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "subtract native integer from native integer" );
- set I0, 4000
- set I1, -123
- sub I2, I0, I1
- say I2
- sub I0, I0, I1
- say I0
- end
-CODE
-4123
-4123
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "multiply native integer with native integer" );
- set I0, 4000
- set I1, -123
- mul I2, I0, I1
- say I2
- mul I0, I0, I1
- say I0
- end
-CODE
--492000
--492000
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "divide native integer by native integer" );
- set I0, 4000
- set I1, -123
- div I2, I0, I1
- say I2
- div I0, I0, I1
- say I0
- end
-CODE
--32
--32
-OUTPUT
+.sub add_native_integer_to_native_integer
+ set $I0, 4000
+ set $I1, -123
+ add $I2, $I0, $I1
+ is( $I2, "3877", 'add_native_integer_to_native_integer' )
-#
-# print -0.0 as -0
-#
-
-pasm_output_is( <<'CODE', <<OUTPUT, 'negate -0.0' );
- set N0, 0
- neg N0
- say N0
- set N0, -0.0
- neg N0
- say N0
- set N0, -0.0
- neg N1, N0
- say N1
- set N0, 0
- set N1, 1
- neg N1, N0
- say N1
- end
-CODE
--0
-0
-0
--0
-OUTPUT
+ add $I0, $I0, $I1
+ is( $I0, "3877", 'add_native_integer_to_native_integer' )
+.end
+
+.sub subtract_native_integer_from_native_integer
+ set $I0, 4000
+ set $I1, -123
+ sub $I2, $I0, $I1
+ is( $I2, "4123", 'subtract_native_integer_from_native_integer' )
+ sub $I0, $I0, $I1
+ is( $I0, "4123", 'subtract_native_integer_from_native_integer' )
+.end
+
+.sub multiply_native_integer_with_native_integer
+ set $I0, 4000
+ set $I1, -123
+ mul $I2, $I0, $I1
+ is( $I2, "-492000", 'multiply_native_integer_with_native_integer' )
+ mul $I0, $I0, $I1
+ is( $I0, "-492000", 'multiply_native_integer_with_native_integer' )
+.end
+
+.sub divide_native_integer_by_native_integer
+ set $I0, 4000
+ set $I1, -123
+ div $I2, $I0, $I1
+ is( $I2, "-32", 'divide_native_integer_by_native_integer' )
+ div $I0, $I0, $I1
+ is( $I0, "-32", 'divide_native_integer_by_native_integer' )
+.end
+
+#
+# print -0.0 as -0
+#
+.sub negate_minus_zero_point_zero
+ set $N0, 0
+ neg $N0
+ $S0 = $N0
+ is( $S0, "-0", '1' )
+
+ set $N0, -0.0
+ neg $N0
+ $S0 = $N0
+ is( $S0, "0", '2' )
+
+ set $N0, -0.0
+ neg $N1, $N0
+ $S0 = $N1
+ is( $S0, "0", '3' )
+
+ set $N0, 0
+ set $N1, 1
+ neg $N1, $N0
+ $S0 = $N1
+ is( $S0, "-0", '4' )
+.end
+
#
# Operations on a single NUMVAL
#
+.sub negate_a_native_number
+ set $N0, 123.4567890
+ neg $N0
+ is( $N0, "-123.456789", 'negate_a_native_number' )
+
+ set $N0, -123.4567890
+ neg $N0
+ is( $N0, "123.456789", 'negate_a_native_number' )
+
+ set $N0, 123.4567890
+ neg $N1, $N0
+ is( $N1, "-123.456789", 'negate_a_native_number' )
+
+ set $N0, -123.4567890
+ neg $N1, $N0
+ is( $N1, "123.456789", 'negate_a_native_number' )
+.end
+
+.sub take_the_absolute_of_a_native_number
+ set $N0, 0
+ abs $N0
+ is( $N0, "0", 'take_the_absolute_of_a_native_number' )
+
+ set $N0, -0.0
+ abs $N0
+ is( $N0, "0", 'take_the_absolute_of_a_native_number' )
+
+ set $N0, 123.45678901
+ abs $N0
+ is( $N0, "123.45678901", 'take_the_absolute_of_a_native_number' )
+
+ set $N0, -123.45678901
+ abs $N0
+ is( $N0, "123.45678901", 'take_the_absolute_of_a_native_number' )
+
+ set $N0, 0
+ set $N1, 1
+ abs $N1, $N0
+ is( $N1, "0", 'take_the_absolute_of_a_native_number' )
+
+ set $N0, 0.0
+ set $N1, 1
+ abs $N1, $N0
+ is( $N1, "0", 'take_the_absolute_of_a_native_number' )
+
+ set $N0, 123.45678901
+ set $N1, 1
+ abs $N1, $N0
+ is( $N1, "123.45678901", 'take_the_absolute_of_a_native_number' )
+
+ set $N0, -123.45678901
+ set $N1, 1
+ abs $N1, $N0
+ is( $N1, "123.45678901", 'take_the_absolute_of_a_native_number' )
+.end
+
+.sub ceil_of_a_native_number
+ set $N0, 0
+ ceil $N0
+ is( $N0, "0", 'ceil_of_a_native_number' )
+
+ set $N0, 123.45678901
+ ceil $N0
+ is( $N0, "124", 'ceil_of_a_native_number' )
+
+ set $N0, -123.45678901
+ ceil $N0
+ is( $N0, "-123", 'ceil_of_a_native_number' )
+
+ set $N0, 0
+ set $N1, 1
+ ceil $N1, $N0
+ is( $N1, "0", 'ceil_of_a_native_number' )
+
+ set $N0, 0.0
+ set $N1, 1
+ ceil $N1, $N0
+ is( $N1, "0", 'ceil_of_a_native_number' )
+
+ set $N0, 123.45678901
+ set $N1, 1
+ ceil $N1, $N0
+ is( $N1, "124", 'ceil_of_a_native_number' )
+
+ set $N0, -123.45678901
+ set $N1, 1
+ ceil $N1, $N0
+ is( $N1, "-123", 'ceil_of_a_native_number' )
+
+ set $N0, 0
+ set $I1, 1
+ ceil $I1, $N0
+ is( $I1, "0", 'ceil_of_a_native_number' )
+
+ set $N0, 0.0
+ set $I1, 1
+ ceil $I1, $N0
+ is( $I1, "0", 'ceil_of_a_native_number' )
+
+ set $N0, 123.45678901
+ set $I1, 1
+ ceil $I1, $N0
+ is( $I1, "124", 'ceil_of_a_native_number' )
+
+ set $N0, -123.45678901
+ set $I1, 1
+ ceil $I1, $N0
+ is( $I1, "-123", 'ceil_of_a_native_number' )
+.end
-pasm_output_is( <<'CODE', <<OUTPUT, 'negate a native number' );
- set N0, 123.4567890
- neg N0
- say N0
- set N0, -123.4567890
- neg N0
- say N0
- set N0, 123.4567890
- neg N1, N0
- say N1
- set N0, -123.4567890
- neg N1, N0
- say N1
- end
-CODE
--123.456789
-123.456789
--123.456789
-123.456789
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "take the absolute of a native number" );
- set N0, 0
- abs N0
- say N0
- set N0, -0.0
- abs N0
- say N0
- set N0, 123.45678901
- abs N0
- say N0
- set N0, -123.45678901
- abs N0
- say N0
- set N0, 0
- set N1, 1
- abs N1, N0
- say N1
- set N0, 0.0
- set N1, 1
- abs N1, N0
- say N1
- set N0, 123.45678901
- set N1, 1
- abs N1, N0
- say N1
- set N0, -123.45678901
- set N1, 1
- abs N1, N0
- say N1
- end
-CODE
-0
-0
-123.45678901
-123.45678901
-0
-0
-123.45678901
-123.45678901
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "ceil of a native number" );
- set N0, 0
- ceil N0
- say N0
- set N0, 123.45678901
- ceil N0
- say N0
- set N0, -123.45678901
- ceil N0
- say N0
- set N0, 0
- set N1, 1
- ceil N1, N0
- say N1
- set N0, 0.0
- set N1, 1
- ceil N1, N0
- say N1
- set N0, 123.45678901
- set N1, 1
- ceil N1, N0
- say N1
- set N0, -123.45678901
- set N1, 1
- ceil N1, N0
- say N1
- set N0, 0
- set I1, 1
- ceil I1, N0
- say I1
- set N0, 0.0
- set I1, 1
- ceil I1, N0
- say I1
- set N0, 123.45678901
- set I1, 1
- ceil I1, N0
- say I1
- set N0, -123.45678901
- set I1, 1
- ceil I1, N0
- say I1
- end
-CODE
-0
-124
--123
-0
-0
-124
--123
-0
-0
-124
--123
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "floor of a native number" );
- set N0, 0
- floor N0
- say N0
- set N0, 123.45678901
- floor N0
- say N0
- set N0, -123.45678901
- floor N0
- say N0
- set N0, 0
- set N1, 1
- floor N1, N0
- say N1
- set N0, 0.0
- set N1, 1
- floor N1, N0
- say N1
- set N0, 123.45678901
- set N1, 1
- floor N1, N0
- say N1
- set N0, -123.45678901
- set N1, 1
- floor N1, N0
- say N1
- set N0, 0
- set I1, 1
- floor I1, N0
- say I1
- set N0, 0.0
- set I1, 1
- floor I1, N0
- say I1
- set N0, 123.45678901
- set I1, 1
- floor I1, N0
- say I1
- set N0, -123.45678901
- set I1, 1
- floor I1, N0
- say I1
- end
-CODE
-0
-123
--124
-0
-0
-123
--124
-0
-0
-123
--124
-OUTPUT
+.sub floor_of_a_native_number
+ set $N0, 0
+ floor $N0
+ is( $N0, "0", 'floor_of_a_native_number' )
+
+ set $N0, 123.45678901
+ floor $N0
+ is( $N0, "123", 'floor_of_a_native_number' )
+
+ set $N0, -123.45678901
+ floor $N0
+ is( $N0, "-124", 'floor_of_a_native_number' )
+
+ set $N0, 0
+ set $N1, 1
+ floor $N1, $N0
+ is( $N1, "0", 'floor_of_a_native_number' )
+
+ set $N0, 0.0
+ set $N1, 1
+ floor $N1, $N0
+ is( $N1, "0", 'floor_of_a_native_number' )
+
+ set $N0, 123.45678901
+ set $N1, 1
+ floor $N1, $N0
+ is( $N1, "123", 'floor_of_a_native_number' )
+
+ set $N0, -123.45678901
+ set $N1, 1
+ floor $N1, $N0
+ is( $N1, "-124", 'floor_of_a_native_number' )
+
+ set $N0, 0
+ set $I1, 1
+ floor $I1, $N0
+ is( $I1, "0", 'floor_of_a_native_number' )
+
+ set $N0, 0.0
+ set $I1, 1
+ floor $I1, $N0
+ is( $I1, "0", 'floor_of_a_native_number' )
+
+ set $N0, 123.45678901
+ set $I1, 1
+ floor $I1, $N0
+ is( $I1, "123", 'floor_of_a_native_number' )
+
+ set $N0, -123.45678901
+ set $I1, 1
+ floor $I1, $N0
+ is( $I1, "-124", 'floor_of_a_native_number' )
+
+.end
#
# FLOATVAL and INTVAL tests
#
-pasm_output_is( <<'CODE', <<OUTPUT, "add native integer to native number" );
- set I0, 4000
- set N0, -123.123
- add N1, N0, I0
- say N1
- add N0, N0, I0
- say N0
- add N0, I0
- say N0
- end
-CODE
-3876.877
-3876.877
-7876.877
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "subtract native integer from native number" );
- set I0, 4000
- set N0, -123.123
- sub N1, N0, I0
- say N1
- sub N0, N0, I0
- say N0
- sub N0, I0
- say N0
- end
-CODE
--4123.123
--4123.123
--8123.123
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "multiply native number with native integer" );
- set I0, 4000
- set N0, -123.123
- mul N1, N0, I0
- say N1
- mul N0, N0, I0
- say N0
- mul N0, -2
- say N0
- end
-CODE
--492492
--492492
-984984
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "divide native number by native integer" );
- set I0, 4000
- set N0, -123.123
- div N1, N0, I0
- say N1
- div N0, N0, I0
- say N0
- div N0, 1
- say N0
- set N0, 100.000
- div N0, 100
- say N0
- div N0, 0.01
- say N0
- end
-CODE
--0.03078075
--0.03078075
--0.03078075
-1
-100
-OUTPUT
+.sub add_native_integer_to_native_number
+ set $I0, 4000
+ set $N0, -123.123
+ add $N1, $N0, $I0
+ is( $N1, "3876.877", 'add_native_integer_to_native_number' )
+ add $N0, $N0, $I0
+ is( $N0, "3876.877", 'add_native_integer_to_native_number' )
+
+ add $N0, $I0
+ is( $N0, "7876.877", 'add_native_integer_to_native_number' )
+
+.end
+
+.sub subtract_native_integer_from_native_number
+ set $I0, 4000
+ set $N0, -123.123
+ sub $N1, $N0, $I0
+ is( $N1, "-4123.123", 'subtract_native_integer_from_native_number' )
+
+ sub $N0, $N0, $I0
+ is( $N0, "-4123.123", 'subtract_native_integer_from_native_number' )
+
+ sub $N0, $I0
+ is( $N0, "-8123.123", 'subtract_native_integer_from_native_number' )
+
+.end
+
+.sub multiply_native_number_with_native_integer
+ set $I0, 4000
+ set $N0, -123.123
+ mul $N1, $N0, $I0
+ is( $N1, "-492492", 'multiply_native_number_with_native_integer' )
+
+ mul $N0, $N0, $I0
+ is( $N0, "-492492", 'multiply_native_number_with_native_integer' )
+
+ mul $N0, -2
+ is( $N0, "984984", 'multiply_native_number_with_native_integer' )
+.end
+
+.sub divide_native_number_by_native_integer
+ set $I0, 4000
+ set $N0, -123.123
+ div $N1, $N0, $I0
+ is( $N1, "-0.03078075", 'divide_native_number_by_native_integer' )
+
+ div $N0, $N0, $I0
+ is( $N0, "-0.03078075", 'divide_native_number_by_native_integer' )
+
+ div $N0, 1
+ is( $N0, "-0.03078075", 'divide_native_number_by_native_integer' )
+
+ set $N0, 100.000
+ div $N0, 100
+ is( $N0, "1", 'divide_native_number_by_native_integer' )
+
+ div $N0, 0.01
+ is( $N0, "100", 'divide_native_number_by_native_integer' )
+.end
+
#
# FLOATVAL and FLOATVAL tests
#
-pasm_output_is( <<'CODE', <<OUTPUT, "add native number to native number" );
- set N2, 4000.246
- set N0, -123.123
- add N1, N0, N2
- say N1
- add N0, N0, N2
- say N0
- end
-CODE
-3877.123
-3877.123
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "subtract native number from native number" );
- set N2, 4000.246
- set N0, -123.123
- sub N1, N0, N2
- say N1
- sub N0, N0, N2
- say N0
- end
-CODE
--4123.369
--4123.369
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "multiply native number with native number" );
- set N2, 4000.246
- set N0, -123.123
- mul N1, N0, N2
- say N1
- mul N0, N0, N2
- say N0
- end
-CODE
--492522.288258
--492522.288258
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "divide native number by native number" );
- set N2, 4000.246
- set N0, -123.123
- div N1, N0, N2
- say N1
- div N0, N0, N2
- say N0
- end
-CODE
--0.0307788571002883
--0.0307788571002883
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "lcm_I_I_I" );
- set I0, 10
- set I1, 10
- lcm I2, I1, I0
- eq I2, 10, OK1
- print "not "
-OK1: say "ok 1"
-
- set I1, 17
- lcm I2, I1, I0
- eq I2, 170, OK2
- print I2
- print "not "
-OK2: print "ok 2\n"
-
- set I0, 17
- set I1, 10
- lcm I2, I1, I0
- eq I2, 170, OK3
- print "not "
-OK3: print "ok 3\n"
-
- set I0, 10
- set I1, 0
- lcm I2, I1, I0
- eq I2, 0, OK4
- print "not "
-OK4: print "ok 4\n"
-
- set I0, 0
- set I1, 10
- lcm I2, I1, I0
- eq I2, 0, OK5
- print "not "
-OK5: print "ok 5\n"
-
- end
-CODE
-ok 1
-ok 2
-ok 3
-ok 4
-ok 5
-OUTPUT
-
-SKIP: {
- skip( 'No integer overflow for 32-bit INTVALs without GMP installed', 1 )
- if $PConfig{intvalsize} == 4 && !$PConfig{gmp};
+.sub add_native_number_to_native_number
+ set $N2, 4000.246
+ set $N0, -123.123
+ add $N1, $N0, $N2
+ is( $N1, "3877.123", 'add_native_number_to_native_number' )
+
+ add $N0, $N0, $N2
+ is( $N0, "3877.123", 'add_native_number_to_native_number' )
+.end
+
+.sub subtract_native_number_from_native_number
+ set $N2, 4000.246
+ set $N0, -123.123
+ sub $N1, $N0, $N2
+ is( $N1, "-4123.369", 'subtract_native_number_from_native_number' )
+
+ sub $N0, $N0, $N2
+ is( $N0, "-4123.369", 'subtract_native_number_from_native_number' )
+
+.end
+
+.sub multiply_native_number_with_native_number
+ set $N2, 4000.246
+ set $N0, -123.123
+ mul $N1, $N0, $N2
+ is( $N1, "-492522.288258", 'multiply_native_number_with_native_number' )
+
+ mul $N0, $N0, $N2
+ is( $N0, "-492522.288258", 'multiply_native_number_with_native_number' )
+
+.end
+
+.sub divide_native_number_by_native_number
+ set $N2, 4000.246
+ set $N0, -123.123
+ div $N1, $N0, $N2
+ is( $N1, "-0.0307788571002883", 'divide_native_number_by_native_number' )
+
+ div $N0, $N0, $N2
+ is( $N0, "-0.0307788571002883", 'divide_native_number_by_native_number' )
+
+.end
+
+.sub lcm_test
+ set $I0, 10
+ set $I1, 10
+ lcm $I2, $I1, $I0
+ is( $I2, 10, 'lcm_test' )
+
+ set $I1, 17
+ lcm $I2, $I1, $I0
+ is( $I2, 170, 'lcm_test' )
+
+ set $I0, 17
+ set $I1, 10
+ lcm $I2, $I1, $I0
+ is( $I2, 170, 'lcm_test' )
+
+ set $I0, 10
+ set $I1, 0
+ lcm $I2, $I1, $I0
+ is( $I2, 0, 'lcm_test' )
+
+ set $I0, 0
+ set $I1, 10
+ lcm $I2, $I1, $I0
+ is( $I2, 0, 'lcm_test' )
+.end
+
+.sub integer_overflow_with_pow
+ .include "iglobals.pasm"
+
+ # Check that we aren't 32-bit INTVALs without GMP
+ .local pmc interp # a handle to our interpreter object.
+ interp = getinterp
+ .local pmc config
+ config = interp[.IGLOBALS_CONFIG_HASH]
+ .local int intvalsize
+ intvalsize = config['intvalsize']
+ .local int gmp
+ gmp = config['gmp']
+
+ if intvalsize != 4 goto can_test
+ if gmp goto can_test
+ skip(40,'No integer overflow for 32-bit INTVALs without GMP installed')
+ goto end
+
+ can_test:
- pir_output_is( <<'CODE', <<OUTPUT, "integer overflow with 'pow'" );
-.sub main
.local pmc i1, i2, r
i1 = new 'Integer'
i2 = new 'Integer'
i1 = 2
i2 = 1
-next:
+ $I1 = 1
+ next:
null r
r = pow i1, i2
$S0 = r
- say $S0
+
+ $I1 = $I1 * 2
+ is( $S0, $I1, 'integer_overflow_with_pow' )
+
inc i2
# XXX: this must be extended to at least 64 bit range
# when sure that the result is not floating point.
# In the meantime, make sure it overflows nicely
# on 32 bit.
unless i2 > 40 goto next
-.end
-CODE
-2
-4
-8
-16
-32
-64
-128
-256
-512
-1024
-2048
-4096
-8192
-16384
-32768
-65536
-131072
-262144
-524288
-1048576
-2097152
-4194304
-8388608
-16777216
-33554432
-67108864
-134217728
-268435456
-536870912
-1073741824
-2147483648
-4294967296
-8589934592
-17179869184
-34359738368
-68719476736
-137438953472
-274877906944
-549755813888
-1099511627776
-OUTPUT
-}
+ end:
+.end
# Local Variables:
-# mode: cperl
+# mode: pir
# cperl-indent-level: 4
# fill-column: 100
# End:
-# vim: expandtab shiftwidth=4:
+# vim: expandtab shiftwidth=4 ft=pir :
Modified: trunk/t/op/arithmetics_pmc.t
==============================================================================
--- trunk/t/op/arithmetics_pmc.t Sat Oct 17 20:46:50 2009 (r41905)
+++ trunk/t/op/arithmetics_pmc.t Sat Oct 17 20:46:53 2009 (r41906)
@@ -1,17 +1,7 @@
-#!perl
+#!parrot
# Copyright (C) 2001-2009, Parrot Foundation.
# $Id$
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-
-use Test::More;
-use Parrot::Test;
-
-# test for GMP
-use Parrot::Config;
-
=head1 NAME
t/op/arithmetics_pmc.t - Arithmetic Ops involving PMCs
@@ -26,84 +16,568 @@
=cut
-# We don't check BigInt and BigNum ops
-if ( $PConfig{gmp} ) {
- plan tests => 68;
-}
-else {
- plan tests => 34;
-}
-
-
-# Map vtable method to op
-my %methods = qw{
- add add
- subtract sub
- multiply mul
- divide div
-
- floor_divide fdiv
- modulus mod
- pow pow
-
- bitwise_or bor
- bitwise_and band
- bitwise_xor bxor
-
- bitwise_shr shr
- bitwise_shl shl
- bitwise_lsr lsr
-
- concatenate concat
-
- logical_or or
- logical_and and
- logical_xor xor
-};
-
-# XXX Put BigInt and BigNum here
-my @pmcs = qw{
- Integer Float
-};
-
-if ($PConfig{gmp}) {
- push @pmcs, qw{ BigInt BigNum};
-}
-
-foreach my $pmc (@pmcs) {
- while(my($vtable, $op) = each(%methods)) {
-
-# We should generate more tests for all possible combinations
-pir_output_is( <<"CODE", <<OUTPUT, "Original dest is untouched in $pmc.$vtable " );
-.sub 'test' :main
- \$P0 = new '$pmc'
- \$P0 = 40
- \$P1 = new '$pmc'
- \$P1 = 2
- \$P2 = new '$pmc'
- \$P2 = 115200
-
- \$P99 = \$P2
- # ignore exceptions
- push_eh done
- $op \$P2, \$P0, \$P1
-
- \$I0 = cmp \$P99, 115200
- unless \$I0 goto done
- print " not "
- done:
- say "ok"
-.end
-CODE
-ok
-OUTPUT
+.sub main :main
+ .include 'test_more.pir'
+ .include "iglobals.pasm"
+
+ plan(68)
+
+ # Don't check BigInt or BigNum without gmp
+ .local pmc interp # a handle to our interpreter object.
+ interp = getinterp
+ .local pmc config
+ config = interp[.IGLOBALS_CONFIG_HASH]
+ .local int gmp
+ gmp = config['gmp']
+
+ run_tests_for('Integer')
+ run_tests_for('Float')
+
+ if gmp goto do_big_ones
+ skip( 34, "will not test BigInt or BigNum without gmp" )
+ goto end
+
+ do_big_ones:
+ run_tests_for('BigInt')
+ run_tests_for('BigNum')
+
+ end:
+.end
+
+.sub run_tests_for
+ .param pmc type
+ test_add(type)
+ test_divide(type)
+ test_multiply(type)
+ test_floor_divide(type)
+ test_logical_and(type)
+ test_concatenate(type)
+ test_logical_xor(type)
+ test_logical_or(type)
+ test_bitwise_shr(type)
+ test_bitwise_or(type)
+ test_bitwise_shl(type)
+ test_bitwise_xor(type)
+ test_modulus(type)
+ test_pow(type)
+ test_subtract(type)
+ test_bitwise_lsr(type)
+ test_bitwise_and(type)
+.end
+
+.sub test_add
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in add for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ add $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_divide
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in divide for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ div $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_multiply
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in multiply for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ mul $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_floor_divide
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in floor_divide for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ fdiv $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_logical_and
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in logical_and for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ and $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_concatenate
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in concatenate for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ concat $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_logical_xor
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in logical_xor for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ xor $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_logical_or
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in logical_or for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ or $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_bitwise_shr
+ .param pmc type
- }
-}
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in bitwise_shr for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ shr $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_bitwise_or
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in bitwise_or for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ bor $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_bitwise_shl
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in bitwise_shl for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ shl $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_bitwise_xor
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in bitwise_xor for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ bxor $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_modulus
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in modulus for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ mod $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_pow
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in pow for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ pow $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_subtract
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in subtract for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ sub $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_bitwise_lsr
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in bitwise_lsr for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ lsr $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
+
+.sub test_bitwise_and
+ .param pmc type
+
+ $P0 = new type
+ $P0 = 40
+ $P1 = new type
+ $P1 = 2
+ $P2 = new type
+ $P2 = 115200
+
+ $P99 = $P2
+
+ $S0 = "original dest is untouched in bitwise_and for "
+ $S1 = type
+ concat $S0, $S1
+
+ # ignore exceptions
+ push_eh done
+ band $P2, $P0, $P1
+
+ $I0 = cmp $P99, 115200
+
+ is( $I0, 0, $S0 )
+ goto end
+
+ done:
+ ok(1, 'ignoring exceptions')
+ end:
+.end
# Local Variables:
-# mode: cperl
+# mode: pir
# cperl-indent-level: 4
# fill-column: 100
# End:
-# vim: expandtab shiftwidth=4:
+# vim: expandtab shiftwidth=4 ft=pir :
Modified: trunk/t/op/string.t
==============================================================================
--- trunk/t/op/string.t Sat Oct 17 20:46:50 2009 (r41905)
+++ trunk/t/op/string.t Sat Oct 17 20:46:53 2009 (r41906)
@@ -1,15 +1,7 @@
-#!perl
+#!parrot
# Copyright (C) 2001-2009, Parrot Foundation.
# $Id$
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-
-use Test::More;
-use Parrot::Test tests => 167;
-use Parrot::Config;
-
=head1 NAME
t/op/string.t - Parrot Strings
@@ -24,2987 +16,2090 @@
=cut
-pasm_output_is( <<'CODE', <<'OUTPUT', 'set_s_s|sc' );
- set S4, "JAPH\n"
- set S5, S4
- print S4
- print S5
- end
-CODE
-JAPH
-JAPH
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'clone' );
- set S0, "Foo\n"
- clone S1, S0
- print S0
- print S1
-
- clone S1, "Bar\n"
- print S1
- chopn S1, 1 # Check that the contents of S1 are no longer constant
- print S1
- print "\n"
+.sub main :main
+ .include 'test_more.pir'
- end
-CODE
-Foo
-Foo
-Bar
-Bar
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'clone null' );
- null S0
- clone S1, S0
- end
-CODE
-OUTPUT
+ plan(405)
-pasm_output_is( <<'CODE', '4', 'length_i_s' );
- set I4, 0
- set S4, "JAPH"
- length I4, S4
- print I4
- end
-CODE
+ set_s_s_sc()
+ test_clone()
+ clone_null()
+ test_length_i_s()
+ zero_length_substr()
+ chopn_with_clone()
+ chopn_with_set()
+ chopn_oob_values()
+ three_argument_chopn()
+ three_argument_chopn__oob_values()
+ substr_tests()
+ neg_substr_offset()
+ exception_substr_oob()
+ exception_substr_oob()
+ len_greater_than_strlen()
+ len_greater_than_strlen_neg_offset()
+ five_arg_substr_w_rep_eq_length()
+ five_arg_substr_w_replacement_gt_length()
+ five_arg_substr_w_replacement_lt_length()
+ five_arg_substr__offset_at_end_of_string()
+ exception_five_arg_substr__offset_past_end_of_string()
+ five_arg_substr_neg_offset_repl_eq_length()
+ five_arg_substr_neg_offset_repl_gt_length()
+ five_arg_substr_neg_offset_repl_lt_length()
+ exception_five_arg_substr_neg_offset_out_of_string()
+ five_arg_substr_length_gt_strlen()
+ five_arg_substr_length_gt_strlen_neg_offset()
+ four_arg_replacement_only_substr()
+ three_arg_substr()
+ exception_substr__pos_offset_zero_length_string()
+ substr_offset_zero_zero_length_string()
+ exception_substr_offset_one_zero_length_string()
+ exception_substr_neg_offset_zero_length_string()
+ zero_length_substr_zero_length_string()
+ zero_length_substr_zero_length_string()
+ three_arg_substr_zero_length_string()
+ five_arg_substr_zero_length_string()
+ four_arg_substr_replace_zero_length_string()
+ concat_s_s_sc_null_onto_null()
+ concat_s_sc_repeated_two_arg_concats()
+ concat_s_s_sc_foo_one_onto_null()
+ test_concat_s_s_sc()
+ concat_s_s_sc_s_sc()
+ concat_ensure_copy_is_made()
+ test_clears()
+
+ same_constant_twice_bug()
+ exception_two_param_ord_empty_string()
+ exception_two_param_ord_empty_string_register()
+ exception_three_param_ord_empty_string()
+ exception_three_param_ord_empty_string_register()
+ two_param_ord_one_character_string()
+ two_param_ord_multi_character_string()
+ two_param_ord_one_character_string_register()
+ three_param_ord_one_character_string()
+ three_param_ord_one_character_string_register()
+ three_param_ord_multi_character_string()
+ three_param_ord_multi_character_string_register()
+ exception_three_param_ord_multi_character_string()
+ exception_three_param_ord_multi_character_string()
+ three_param_ord_one_character_string_from_end()
+ three_param_ord_one_character_string_register_from_end()
+ three_param_ord_multi_character_string_from_end()
+ three_param_ord_multi_character_string_register_from_end()
+ exception_three_param_ord_multi_character_string_register_from_end_oob()
+ chr_of_thirty_two_is_space_in_ascii()
+ chr_of_sixty_five_is_a_in_ascii()
+ chr_of_one_hundred_and_twenty_two_is_z_in_ascii()
+ test_if_s_ic()
+ repeat_s_s_sc_i_ic()
+ exception_repeat_oob()
+ exception_repeat_oob_repeat_p_p_p()
+ exception_repeat_oob_repeate_p_p_i()
+ encodingname_oob()
+ index_three_arg_form()
+ index_four_arg_form()
+ index_four_arg_form_bug_twenty_two_thousand_seven_hundred_and_eighteen()
+ index_null_strings()
+ index_embedded_nulls()
+ index_big_strings()
+ index_big_hard_to_match_strings()
+ index_with_different_charsets()
+ negative_index_bug_35959()
+ index_multibyte_matching()
+ index_multibyte_matching_two()
+ num_to_string()
+ string_to_int()
+ concat_or_substr_cow()
+ constant_to_cstring()
+ cow_with_chopn_leaving_original_untouched()
+ check_that_bug_bug_16874_was_fixed()
+ stress_concat()
+ ord_and_substring_see_bug_17035()
+
+ test_sprintf()
+ other_form_of_sprintf_op()
+ sprintf_left_justify()
+ correct_precision_for_sprintf_x()
+ test_exchange()
+ test_find_encoding()
+ test_string_encoding()
+ test_assign()
+ assign_and_globber()
+ assign_and_globber_2()
+ bands_null_string()
+ bands_2()
+ bands_3()
+ bands_cow()
+ bors_null_string()
+ bors_2()
+ bors_3()
+ bors_cow()
+ bxors_null_string()
+ bxors_2()
+ bxors_3()
+ bxors_cow()
+ bnots_null_string()
+ bnots_2()
+ bnots_cow()
+ transcode_to_utf8()
+ string_chartype()
+ split_on_empty_string()
+ split_on_non_empty_string()
+ test_join()
+ eq_addr_or_ne_addr()
+ test_if_null_s_ic()
+ test_upcase()
+ test_downcase()
+ test_titlecase()
+ three_param_ord_one_character_string_register_i()
+ three_param_ord_multi_character_string_i()
+ three_param_ord_multi_character_string_register_i()
+ exception_three_param_ord_multi_character_string_i()
+ exception_three_param_ord_multi_character_string_i()
+ three_param_ord_one_character_string_from_end_i()
+ three_param_ord_one_character_string_register_from_end_i()
+ three_param_ord_multi_character_string_from_end_i()
+ three_param_ord_multi_character_string_register_from_end_i()
+ exception_three_param_ord_multi_character_string_register_from_end_oob_i()
+ more_string_to_int()
+ constant_string_and_modify_in_situ_op_rt_bug_60030()
+ corner_cases_of_numification()
+ non_canonical_nan_and_inf()
+ split_hll_mapped()
+ # END_OF_TESTS
+ join_get_string_returns_a_null_string()
-pasm_output_is( <<'CODE', '0', '0 length substr' );
- set I4, 0
- set S4, "JAPH"
- substr S3, S4, 1, 0
- length I4, S3
- print I4
- end
-CODE
+.end
+
+.macro exception_is ( M )
+ .local pmc exception
+ .local string message
+ .get_results (exception)
+
+ message = exception['message']
+ is( message, .M, .M )
+.endm
+
+.sub set_s_s_sc
+ set $S4, "JAPH"
+ set $S5, $S4
+
+ is( $S4, "JAPH", '' )
+ is( $S5, "JAPH", '' )
+.end
+
+.sub test_clone
+ set $S0, "Foo1"
+ clone $S1, $S0
+
+ is( $S0, "Foo1", '' )
+ is( $S1, "Foo1", '' )
+
+ clone $S1, "Bar1"
+ is( $S1, "Bar1", '' )
+
+ chopn $S1, 1
+ is( $S1, "Bar", 'the contents of $S1 are no longer constant' )
+.end
+
+.sub clone_null
+ null $S0
+ clone $S1, $S0
+ is( $S1, $S0, '' )
+.end
+
+.sub test_length_i_s
+ set $I4, 0
+ set $S4, "JAPH"
+ length $I4, $S4
+ is( $I4, "4", '' )
+.end
+
+.sub zero_length_substr
+ set $I4, 0
+ set $S4, "JAPH"
+ substr $S3, $S4, 1, 0
+ length $I4, $S3
+ is( $I4, "0", '' )
+.end
+
+.sub chopn_with_clone
+ set $S4, "JAPHxyzw"
+ set $S5, "japhXYZW"
+ clone $S3, $S4
+ set $I1, 4
+ chopn $S4, 3
+ chopn $S4, 1
+ chopn $S5, $I1
+
+ is( $S4, "JAPH", '' )
+ is( $S5, "japh", '' )
+ is( $S3, "JAPHxyzw", '' )
+.end
+
+.sub chopn_with_set
+ set $S4, "JAPHxyzw"
+ set $S5, "japhXYZW"
+ set $S3, $S4
+ set $I1, 4
+ chopn $S4, 3
+ chopn $S4, 1
+ chopn $S5, $I1
+
+ is( $S4, "JAPH", '' )
+ is( $S5, "japh", '' )
+ is( $S3, "JAPH", '' )
+.end
+
+.sub chopn_oob_values
+ set $S1, "A string of length 21"
+ chopn $S1, 0
+ is( $S1, "A string of length 21", '' )
+
+ chopn $S1, 4
+ is( $S1, "A string of lengt", '' )
-pasm_output_is( <<'CODE', <<'OUTPUT', 'chopn with clone' );
- set S4, "JAPHxyzw"
- set S5, "japhXYZW"
- clone S3, S4
- set S1, "\n"
- set I1, 4
- chopn S4, 3
- chopn S4, 1
- chopn S5, I1
- print S4
- print S1
- print S5
- print S1
- print S3
- print S1
- end
-CODE
-JAPH
-japh
-JAPHxyzw
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'chopn with set' );
- set S4, "JAPHxyzw"
- set S5, "japhXYZW"
- set S3, S4
- set S1, "\n"
- set I1, 4
- chopn S4, 3
- chopn S4, 1
- chopn S5, I1
- print S4
- print S1
- print S5
- print S1
- print S3
- print S1
- end
-CODE
-JAPH
-japh
-JAPH
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'chopn, OOB values' );
- set S1, "A string of length 21"
- chopn S1, 0
- print S1
- print "\n"
- chopn S1, 4
- print S1
- print "\n"
# -length cuts now
- chopn S1, -4
- print S1
- print "\n"
- chopn S1, 1000
- print S1
- print "** nothing **\n"
- end
-CODE
-A string of length 21
-A string of lengt
-A st
-** nothing **
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'Three argument chopn' );
- set S1, "Parrot"
-
- chopn S2, S1, 0
- print S1
- print "\n"
- print S2
- print "\n"
-
- chopn S2, S1, 1
- print S1
- print "\n"
- print S2
- print "\n"
-
- set I0, 2
- chopn S2, S1, I0
- print S1
- print "\n"
- print S2
- print "\n"
-
- chopn S2, "Parrot", 3
- print S2
- print "\n"
-
- chopn S1, S1, 5
- print S1
- print "\n"
-
- set S1, "Parrot"
- set S3, S1
- chopn S2, S1, 3
- print S3
- print "\n"
-
- set S3, S1
- chopn S1, 3
- print S3
- print "\n"
+ chopn $S1, -4
+ is( $S1, "A st", '' )
- end
-CODE
-Parrot
-Parrot
-Parrot
-Parro
-Parrot
-Parr
-Par
-P
-Parrot
-Par
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'Three argument chopn, OOB values' );
- set S1, "Parrot"
-
- chopn S2, S1, 7
- print S1
- print "\n"
- print S2
- print "\n"
-
- chopn S2, S1, -1
- print S1
- print "\n"
- print S2
- print "\n"
+ chopn $S1, 1000
+ is( $S1, "", '' )
+.end
+
+.sub three_argument_chopn
+ set $S1, "Parrot"
+ chopn $S2, $S1, 0
+ is( $S1, "Parrot", '' )
+ is( $S2, "Parrot", '' )
+
+ chopn $S2, $S1, 1
+ is( $S1, "Parrot", '' )
+ is( $S2, "Parro", '' )
+
+ set $I0, 2
+ chopn $S2, $S1, $I0
+ is( $S1, "Parrot", '' )
+ is( $S2, "Parr", '' )
+
+ chopn $S2, "Parrot", 3
+ is( $S2, "Par", '' )
+
+ chopn $S1, $S1, 5
+ is( $S1, "P", '' )
+
+ set $S1, "Parrot"
+ set $S3, $S1
+ chopn $S2, $S1, 3
+ is( $S3, "Parrot", '' )
+
+ set $S3, $S1
+ chopn $S1, 3
+ is( $S3, "Par", '' )
+.end
+#
+.sub three_argument_chopn__oob_values
+ set $S1, "Parrot"
+ chopn $S2, $S1, 7
+ is( $S1, "Parrot", '' )
+ is( $S2, "", '' )
+
+ chopn $S2, $S1, -1
+ is( $S1, "Parrot", '' )
+ is( $S2, "P", '' )
+.end
- end
-CODE
-Parrot
+.sub substr_tests
+ set $S4, "12345JAPH01"
+ set $I4, 5
+ set $I5, 4
-Parrot
-P
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'substr_s_s|sc_i|ic_i|ic' );
- set S4, "12345JAPH01"
- set I4, 5
- set I5, 4
- substr S5, S4, I4, I5
- print S5
- substr S5, S4, I4, 4
- print S5
- substr S5, S4, 5, I5
- print S5
- substr S5, S4, 5, 4
- print S5
- substr S5, "12345JAPH01", I4, I5
- print S5
- substr S5, "12345JAPH01", I4, 4
- print S5
- substr S5, "12345JAPH01", 5, I5
- print S5
- substr S5, "12345JAPH01", 5, 4
- print S5
- print "\n"
- end
-CODE
-JAPHJAPHJAPHJAPHJAPHJAPHJAPHJAPH
-OUTPUT
+ substr $S5, $S4, $I4, $I5
+ is( $S5, "JAPH", '' )
-# negative offsets
-pasm_output_is( <<'CODE', <<'OUTPUT', 'neg substr offset' );
- set S0, "A string of length 21"
- set I0, -9
- set I1, 6
- substr S1, S0, I0, I1
- print S0
- print "\n"
- print S1
- print "\n"
- end
-CODE
-A string of length 21
-length
-OUTPUT
+ substr $S5, $S4, $I4, 4
+ is( $S5, "JAPH", '' )
+
+ substr $S5, $S4, 5, $I5
+ is( $S5, "JAPH", '' )
+
+ substr $S5, $S4, 5, 4
+ is( $S5, "JAPH", '' )
+ substr $S5, "12345JAPH01", $I4, $I5
+ is( $S5, "JAPH", '' )
+
+ substr $S5, "12345JAPH01", $I4, 4
+ is( $S5, "JAPH", '' )
+
+ substr $S5, "12345JAPH01", 5, $I5
+ is( $S5, "JAPH", '' )
+
+ substr $S5, "12345JAPH01", 5, 4
+ is( $S5, "JAPH", '' )
+.end
+
+# negative offsets
+.sub neg_substr_offset
+ set $S0, "A string of length 21"
+ set $I0, -9
+ set $I1, 6
+ substr $S1, $S0, $I0, $I1
+ is( $S0, "A string of length 21", '' )
+ is( $S1, "length", '' )
+.end
+
# This asks for substring that shouldn't be allowed...
-pasm_error_output_like( <<'CODE', <<'OUTPUT', 'substr OOB' );
- set S0, "A string of length 21"
- set I0, -99
- set I1, 6
- substr S1, S0, I0, I1
- end
-CODE
-/^Cannot take substr outside string/
-OUTPUT
+.sub exception_substr_oob
+ set $S0, "A string of length 21"
+ set $I0, -99
+ set $I1, 6
+ push_eh handler
+ substr $S1, $S0, $I0, $I1
+handler:
+ .exception_is( "Cannot take substr outside string" )
+.end
# This asks for substring that shouldn't be allowed...
-pasm_error_output_like( <<'CODE', <<'OUTPUT', 'substr OOB' );
- set S0, "A string of length 21"
- set I0, 99
- set I1, 6
- substr S1, S0, I0, I1
- end
-CODE
-/^Cannot take substr outside string/
-OUTPUT
+.sub exception_substr_oob
+ set $S0, "A string of length 21"
+ set $I0, 99
+ set $I1, 6
+ push_eh handler
+ substr $S1, $S0, $I0, $I1
+handler:
+ .exception_is( "Cannot take substr outside string" )
+.end
# This asks for substring much greater than length of original string
-pasm_output_is( <<'CODE', <<'OUTPUT', 'len>strlen' );
- set S0, "A string of length 21"
- set I0, 12
- set I1, 1000
- substr S1, S0, I0, I1
- print S0
- print "\n"
- print S1
- print "\n"
- end
-CODE
-A string of length 21
-length 21
-OUTPUT
+.sub len_greater_than_strlen
+ set $S0, "A string of length 21"
+ set $I0, 12
+ set $I1, 1000
+ substr $S1, $S0, $I0, $I1
+ is( $S0, "A string of length 21", '' )
+ is( $S1, "length 21", '' )
+.end
# The same, with a negative offset
-pasm_output_is( <<'CODE', <<'OUTPUT', 'len>strlen, -ve os' );
- set S0, "A string of length 21"
- set I0, -9
- set I1, 1000
- substr S1, S0, I0, I1
- print S0
- print "\n"
- print S1
- print "\n"
- end
-CODE
-A string of length 21
-length 21
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, replacement = length' );
- set S0, "abcdefghijk"
- set S1, "xyz"
- substr S2, S0, 4, 3, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-abcdxyzhijk
-xyz
-efg
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, replacement > length' );
- set S0, "abcdefghijk"
- set S1, "xyz0123"
- substr S2, S0, 4, 3, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-abcdxyz0123hijk
-xyz0123
-efg
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, replacement < length' );
- set S0, "abcdefghijk"
- set S1, "x"
- substr S2, S0, 4, 3, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-abcdxhijk
-x
-efg
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, offset at end of string' );
- set S0, "abcdefghijk"
- set S1, "xyz"
- substr S2, S0, 11, 3, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-abcdefghijkxyz
-xyz
-
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', '5 arg substr, offset past end of string' );
- set S0, "abcdefghijk"
- set S1, "xyz"
- substr S2, S0, 12, 3, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-/^Can only replace inside string or index after end of string/
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, -ve offset, repl=length' );
- set S0, "abcdefghijk"
- set S1, "xyz"
- substr S2, S0, -3, 3, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-abcdefghxyz
-xyz
-ijk
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, -ve offset, repl>length' );
- set S0, "abcdefghijk"
- set S1, "xyz"
- substr S2, S0, -6, 2, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-abcdexyzhijk
-xyz
-fg
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, -ve offset, repl<length' );
- set S0, "abcdefghijk"
- set S1, "xyz"
- substr S2, S0, -6, 4, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-abcdexyzjk
-xyz
-fghi
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', '5 arg substr, -ve offset out of string' );
- set S0, "abcdefghijk"
- set S1, "xyz"
- substr S2, S0, -12, 4, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-/^Can only replace inside string or index after end of string/
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, length > strlen ' );
- set S0, "abcdefghijk"
- set S1, "xyz"
- substr S2, S0, 3, 11, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-abcxyz
-xyz
-defghijk
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, length > strlen, -ve offset' );
- set S0, "abcdefghijk"
- set S1, "xyz"
- substr S2, S0, -3, 11, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-abcdefghxyz
-xyz
-ijk
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '4-arg, replacement-only substr' );
- set S0, "abcdefghijk"
- set S1, "xyz"
- substr S0, 3, 3, S1
- print S0
- print "\n"
- print S1
- print "\n"
- end
-CODE
-abcxyzghijk
-xyz
-OUTPUT
-
-pasm_output_is( <<'CODE', 'PH', '3-arg substr' );
- set S0, "JAPH"
- substr S1, S0, 2
- print S1
- end
-CODE
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', "substr, +ve offset, zero-length string" );
- set S0, ""
- substr S1, S0, 10, 3
- print S1
- end
-CODE
-/Cannot take substr outside string/
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'substr, offset 0, zero-length string' );
- set S0, ""
- substr S1, S0, 0, 1
- print S1
- print "_\n"
- end
-CODE
-_
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', "substr, offset -1, zero-length string" );
- set S0, ""
- substr S1, S0, -1, 1
- print S1
- end
-CODE
-/Cannot take substr outside string/
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', "substr, -ve offset, zero-length string" );
- set S0, ""
- substr S1, S0, -10, 5
- print S1
- end
-CODE
-/Cannot take substr outside string/
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'zero-length substr, zero-length string' );
- set S0, ""
- substr S1, S0, 10, 0
- print S1
- print "_\n"
- end
-CODE
-_
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'zero-length substr, zero-length string' );
- set S0, ""
- substr S1, S0, -10, 0
- print S1
- print "_\n"
- end
-CODE
-_
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '3-arg substr, zero-length string' );
- set S0, ""
- substr S1, S0, 2
- print S1
- print "_\n"
- end
-CODE
-_
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, zero-length string' );
- set S0, ""
- set S1, "xyz"
- substr S2, S0, 0, 3, S1
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
-
- set S3, ""
- set S4, "abcde"
- substr S5, S3, 0, 0, S4
- print S3
- print "\n"
- print S4
- print "\n"
- print S5
- print "\n"
- end
-CODE
-xyz
-xyz
-
-abcde
-abcde
-
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', '4 arg substr replace, zero-length string' );
- set S0, ""
- set S1, "xyz"
- substr S0, 0, 3, S1
- print S0
- print "\n"
- print S1
- print "\n"
-
- set S2, ""
- set S3, "abcde"
- substr S2, 0, 0, S3
- print S2
- print "\n"
- print S3
- print "\n"
- end
-CODE
-xyz
-xyz
-abcde
-abcde
-OUTPUT
-
-pasm_output_is( <<'CODE', '<><', 'concat_s_s|sc, null onto null' );
- print "<>"
- concat S0, S0
- concat S1, ""
- print "<"
- end
-CODE
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'concat_s_sc, repeated two-arg concats' );
- set S12, ""
- set I0, 0
+.sub len_greater_than_strlen_neg_offset
+ set $S0, "A string of length 21"
+ set $I0, -9
+ set $I1, 1000
+ substr $S1, $S0, $I0, $I1
+ is( $S0, "A string of length 21", '' )
+ is( $S1, "length 21", '' )
+.end
+
+.sub five_arg_substr_w_rep_eq_length
+ set $S0, "abcdefghijk"
+ set $S1, "xyz"
+ substr $S2, $S0, 4, 3, $S1
+ is( $S0, "abcdxyzhijk", '' )
+ is( $S1, "xyz", '' )
+ is( $S2, "efg", '' )
+.end
+
+.sub five_arg_substr_w_replacement_gt_length
+ set $S0, "abcdefghijk"
+ set $S1, "xyz0123"
+ substr $S2, $S0, 4, 3, $S1
+ is( $S0, "abcdxyz0123hijk", '' )
+ is( $S1, "xyz0123", '' )
+ is( $S2, "efg", '' )
+.end
+
+.sub five_arg_substr_w_replacement_lt_length
+ set $S0, "abcdefghijk"
+ set $S1, "x"
+ substr $S2, $S0, 4, 3, $S1
+ is( $S0, "abcdxhijk", '' )
+ is( $S1, "x", '' )
+ is( $S2, "efg", '' )
+.end
+
+.sub five_arg_substr__offset_at_end_of_string
+ set $S0, "abcdefghijk"
+ set $S1, "xyz"
+ substr $S2, $S0, 11, 3, $S1
+ is( $S0, "abcdefghijkxyz", '' )
+ is( $S1, "xyz", '' )
+ is( $S2, "", '' )
+.end
+
+.sub exception_five_arg_substr__offset_past_end_of_string
+ set $S0, "abcdefghijk"
+ set $S1, "xyz"
+ push_eh handler
+ substr $S2, $S0, 12, 3, $S1
+ ok(0,"no exception")
+handler:
+ .exception_is( "Can only replace inside string or index after end of string" )
+.end
+
+.sub five_arg_substr_neg_offset_repl_eq_length
+ set $S0, "abcdefghijk"
+ set $S1, "xyz"
+ substr $S2, $S0, -3, 3, $S1
+ is( $S0, "abcdefghxyz", '' )
+ is( $S1, "xyz", '' )
+ is( $S2, "ijk", '' )
+.end
+
+.sub five_arg_substr_neg_offset_repl_gt_length
+ set $S0, "abcdefghijk"
+ set $S1, "xyz"
+ substr $S2, $S0, -6, 2, $S1
+ is( $S0, "abcdexyzhijk", '' )
+ is( $S1, "xyz", '' )
+ is( $S2, "fg", '' )
+.end
+
+.sub five_arg_substr_neg_offset_repl_lt_length
+ set $S0, "abcdefghijk"
+ set $S1, "xyz"
+ substr $S2, $S0, -6, 4, $S1
+ is( $S0, "abcdexyzjk", '' )
+ is( $S1, "xyz", '' )
+ is( $S2, "fghi", '' )
+.end
+
+.sub exception_five_arg_substr_neg_offset_out_of_string
+ set $S0, "abcdefghijk"
+ set $S1, "xyz"
+ push_eh handler
+ substr $S2, $S0, -12, 4, $S1
+ ok(0,"no exception")
+handler:
+ .exception_is( "Can only replace inside string or index after end of string" )
+.end
+
+.sub five_arg_substr_length_gt_strlen
+ set $S0, "abcdefghijk"
+ set $S1, "xyz"
+ substr $S2, $S0, 3, 11, $S1
+ is( $S0, "abcxyz", '' )
+ is( $S1, "xyz", '' )
+ is( $S2, "defghijk", '' )
+.end
+
+.sub five_arg_substr_length_gt_strlen_neg_offset
+ set $S0, "abcdefghijk"
+ set $S1, "xyz"
+ substr $S2, $S0, -3, 11, $S1
+ is( $S0, "abcdefghxyz", '' )
+ is( $S1, "xyz", '' )
+ is( $S2, "ijk", '' )
+.end
+
+.sub four_arg_replacement_only_substr
+ set $S0, "abcdefghijk"
+ set $S1, "xyz"
+ substr $S0, 3, 3, $S1
+ is( $S0, "abcxyzghijk", '' )
+ is( $S1, "xyz", '' )
+.end
+
+.sub three_arg_substr
+ set $S0, "JAPH"
+ substr $S1, $S0, 2
+ is( $S1, "PH", '' )
+.end
+
+.sub exception_substr__pos_offset_zero_length_string
+ set $S0, ""
+ push_eh handler
+ substr $S1, $S0, 10, 3
+ ok(0,"no exception")
+handler:
+ .exception_is( "Cannot take substr outside string" )
+.end
+
+.sub substr_offset_zero_zero_length_string
+ set $S0, ""
+ substr $S1, $S0, 0, 1
+ is( $S1, "", '' )
+.end
+
+.sub exception_substr_offset_one_zero_length_string
+ set $S0, ""
+ push_eh handler
+ substr $S1, $S0, -1, 1
+ ok(0,"no exception")
+handler:
+ .exception_is( "Cannot take substr outside string" )
+.end
+
+.sub exception_substr_neg_offset_zero_length_string
+ set $S0, ""
+ push_eh handler
+ substr $S1, $S0, -10, 5
+handler:
+ .exception_is( "Cannot take substr outside string" )
+.end
+
+.sub zero_length_substr_zero_length_string
+ set $S0, ""
+ substr $S1, $S0, 10, 0
+ is( $S1, "", '' )
+.end
+
+.sub zero_length_substr_zero_length_string
+ set $S0, ""
+ substr $S1, $S0, -10, 0
+ is( $S1, "", '' )
+.end
+
+.sub three_arg_substr_zero_length_string
+ set $S0, ""
+ substr $S1, $S0, 2
+ is( $S1, "", '' )
+.end
+
+.sub five_arg_substr_zero_length_string
+ set $S0, ""
+ set $S1, "xyz"
+ substr $S2, $S0, 0, 3, $S1
+ is( $S0, "xyz", '' )
+ is( $S1, "xyz", '' )
+ is( $S2, "", '' )
+
+ set $S3, ""
+ set $S4, "abcde"
+ substr $S5, $S3, 0, 0, $S4
+ is( $S3, "abcde", '' )
+ is( $S4, "abcde", '' )
+ is( $S5, "", '' )
+.end
+
+.sub four_arg_substr_replace_zero_length_string
+ set $S0, ""
+ set $S1, "xyz"
+ substr $S0, 0, 3, $S1
+ is( $S0, "xyz", '' )
+ is( $S1, "xyz", '' )
+
+ set $S2, ""
+ set $S3, "abcde"
+ substr $S2, 0, 0, $S3
+ is( $S2, "abcde", '' )
+ is( $S3, "abcde", '' )
+.end
+
+.sub concat_s_s_sc_null_onto_null
+ concat $S0, $S0
+ is( $S0, "", '' )
+ concat $S1, ""
+ is( $S1, "", '' )
+.end
+
+.sub concat_s_sc_repeated_two_arg_concats
+ set $S12, ""
+ set $I0, 0
WHILE:
- concat S12, "hi"
- add I0, 1
- lt I0, 10, WHILE
- print S12
- print "\n"
- end
-CODE
-hihihihihihihihihihi
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'concat_s_s|sc, "foo1" onto null' );
- concat S0, "foo1"
- set S1, "foo2"
- concat S2, S1
- print S0
- print "\n"
- print S2
- print "\n"
- end
-CODE
-foo1
-foo2
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'concat_s_s|sc' );
- set S1, "fish"
- set S2, "bone"
- concat S1, S2
- print S1
- concat S1, "\n"
- print S1
- end
-CODE
-fishbonefishbone
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'concat_s_s|sc_s|sc' );
- set S1, "japh"
- set S2, "JAPH"
- concat S0, "japh", "JAPH"
- print S0
- print "\n"
- concat S0, S1, "JAPH"
- print S0
- print "\n"
- concat S0, "japh", S2
- print S0
- print "\n"
- concat S0, S1, S2
- print S0
- print "\n"
- end
-CODE
-japhJAPH
-japhJAPH
-japhJAPH
-japhJAPH
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'concat - ensure copy is made' );
- set S2, "JAPH"
- concat S0, S2, ""
- concat S1, "", S2
- chopn S0, 1
- chopn S1, 1
- print S2
- print "\n"
- end
-CODE
-JAPH
-OUTPUT
+ concat $S12, "hi"
+ add $I0, 1
+ lt $I0, 10, WHILE
+ is( $S12, "hihihihihihihihihihi", '' )
+.end
+
+.sub concat_s_s_sc_foo_one_onto_null
+ concat $S0, "foo1"
+ set $S1, "foo2"
+ concat $S2, $S1
+ is( $S0, "foo1", '' )
+ is( $S2, "foo2", '' )
+.end
+
+.sub test_concat_s_s_sc
+ set $S1, "fish"
+ set $S2, "bone"
+ concat $S1, $S2
+ is( $S1, "fishbone", '' )
+.end
+
+.sub concat_s_s_sc_s_sc
+ set $S1, "japh"
+ set $S2, "JAPH"
+ concat $S0, "japh", "JAPH"
+ is( $S0, "japhJAPH", '' )
-pasm_output_is( <<"CODE", <<'OUTPUT', 'clears' );
-@{[ set_str_regs( sub {"BOO $_[0]\\n"} ) ]}
+ concat $S0, $S1, "JAPH"
+ is( $S0, "japhJAPH", '' )
+
+ concat $S0, "japh", $S2
+ is( $S0, "japhJAPH", '' )
+
+ concat $S0, $S1, $S2
+ is( $S0, "japhJAPH", '' )
+.end
+
+.sub concat_ensure_copy_is_made
+ set $S2, "JAPH"
+ concat $S0, $S2, ""
+ concat $S1, "", $S2
+ chopn $S0, 1
+ chopn $S1, 1
+ is( $S2, "JAPH", '' )
+.end
+
+.sub test_clears
+ set $S0, "BOO 0"
+ set $S1, "BOO 1"
+ set $S2, "BOO 2"
+ set $S3, "BOO 3"
+ set $S4, "BOO 4"
+ set $S5, "BOO 5"
+ set $S6, "BOO 6"
+ set $S7, "BOO 7"
+ set $S8, "BOO 8"
+ set $S9, "BOO 9"
+ set $S10, "BOO 10"
+ set $S11, "BOO 11"
+ set $S12, "BOO 12"
+ set $S13, "BOO 13"
+ set $S14, "BOO 14"
+ set $S15, "BOO 15"
+ set $S16, "BOO 16"
+ set $S17, "BOO 17"
+ set $S18, "BOO 18"
+ set $S19, "BOO 19"
+ set $S20, "BOO 20"
+ set $S21, "BOO 21"
+ set $S22, "BOO 22"
+ set $S23, "BOO 23"
+ set $S24, "BOO 24"
+ set $S25, "BOO 25"
+ set $S26, "BOO 26"
+ set $S27, "BOO 27"
+ set $S28, "BOO 28"
+ set $S29, "BOO 29"
+ set $S30, "BOO 30"
+ set $S31, "BOO 31"
clears
-@{[ print_str_regs() ]}
- print "done\\n"
- end
-CODE
-done
-OUTPUT
-
-my @strings = (
- "hello", "hello", "hello", "world", "world", "hello", "hello", "hellooo",
- "hellooo", "hello", "hello", "hella", "hella", "hello", "hella", "hellooo",
- "hellooo", "hella", "hElLo", "HeLlO", "hElLo", "hElLo"
-);
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'eq_s_s_ic' );
-@{[ compare_strings( 0, "eq", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'eq_sc_s_ic' );
-@{[ compare_strings( 1, "eq", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'eq_s_sc_ic' );
-@{[ compare_strings( 2, "eq", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'eq_sc_sc_ic' );
-@{[ compare_strings( 3, "eq", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'ne_s_s_ic' );
-@{[ compare_strings( 0, "ne", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'ne_sc_s_ic' );
-@{[ compare_strings( 1, "ne", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'ne_s_sc_ic' );
-@{[ compare_strings( 2, "ne", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'ne_sc_sc_ic' );
-@{[ compare_strings( 3, "ne", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'lt_s_s_ic' );
-@{[ compare_strings( 0, "lt", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'lt_sc_s_ic' );
-@{[ compare_strings( 1, "lt", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'lt_s_sc_ic' );
-@{[ compare_strings( 2, "lt", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'lt_sc_sc_ic' );
-@{[ compare_strings( 3, "lt", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'le_s_s_ic' );
-@{[ compare_strings( 0, "le", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'le_sc_s_ic' );
-@{[ compare_strings( 1, "le", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'le_s_sc_ic' );
-@{[ compare_strings( 2, "le", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'le_sc_sc_ic' );
-@{[ compare_strings( 3, "le", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'gt_s_s_ic' );
-@{[ compare_strings( 0, "gt", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'gt_sc_s_ic' );
-@{[ compare_strings( 1, "gt", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'gt_s_sc_ic' );
-@{[ compare_strings( 2, "gt", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'gt_sc_sc_ic' );
-@{[ compare_strings( 3, "gt", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'ge_s_s_ic' );
-@{[ compare_strings( 0, "ge", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'ge_sc_s_ic' );
-@{[ compare_strings( 1, "ge", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'ge_s_sc_ic' );
-@{[ compare_strings( 2, "ge", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<"CODE", <<'OUTPUT', 'ge_sc_sc_ic' );
-@{[ compare_strings( 3, "ge", @strings ) ]}
- print "ok\\n"
- end
-ERROR:
- print "bad\\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'same constant twice bug' );
- set S0, ""
- set S1, ""
- set S2, "foo"
- concat S1,S1,S2
- print S1
- print S0
- print "\n"
- end
-CODE
-foo
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', '2-param ord, empty string' );
- ord I0,""
- print I0
- end
-CODE
-/^Cannot get character of empty string/
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', '2-param ord, empty string register' );
- ord I0,S0
- print I0
- end
-CODE
-/^Cannot get character of empty string/
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, empty string' );
- ord I0,"",0
- print I0
- end
-CODE
-/^Cannot get character of empty string/
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, empty string register' );
- ord I0,S0,0
- print I0
- end
-CODE
-/^Cannot get character of empty string/
-OUTPUT
-
-pasm_output_is( <<'CODE', ord('a'), '2-param ord, one-character string' );
- ord I0,"a"
- print I0
- end
-CODE
+ is( $S0, "", '' )
+ is( $S1, "", '' )
+ is( $S2, "", '' )
+ is( $S3, "", '' )
+ is( $S4, "", '' )
+ is( $S5, "", '' )
+ is( $S6, "", '' )
+ is( $S7, "", '' )
+ is( $S8, "", '' )
+ is( $S9, "", '' )
+ is( $S10, "", '' )
+ is( $S11, "", '' )
+ is( $S12, "", '' )
+ is( $S13, "", '' )
+ is( $S14, "", '' )
+ is( $S15, "", '' )
+ is( $S16, "", '' )
+ is( $S17, "", '' )
+ is( $S18, "", '' )
+ is( $S19, "", '' )
+ is( $S20, "", '' )
+ is( $S21, "", '' )
+ is( $S22, "", '' )
+ is( $S23, "", '' )
+ is( $S24, "", '' )
+ is( $S25, "", '' )
+ is( $S26, "", '' )
+ is( $S27, "", '' )
+ is( $S28, "", '' )
+ is( $S29, "", '' )
+ is( $S30, "", '' )
+ is( $S31, "", '' )
+.end
-pasm_output_is( <<'CODE', ord('a'), '2-param ord, multi-character string' );
- ord I0,"abc"
- print I0
- end
-CODE
+.sub same_constant_twice_bug
+ set $S0, ""
+ set $S1, ""
+ set $S2, "foo"
+ concat $S1,$S1,$S2
+ is( $S1, "foo", 'same constant twice bug' )
+ is( $S0, "", 'same constant twice bug' )
+.end
-pasm_output_is( <<'CODE', ord('a'), '2-param ord, one-character string register' );
- set S0,"a"
- ord I0,S0
- print I0
- end
-CODE
+.sub exception_two_param_ord_empty_string
+ push_eh handler
+ ord $I0,""
+ ok(0, 'no exception: 2-param ord, empty string' )
+ handler:
+ .exception_is( 'Cannot get character of empty string' )
+.end
-pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string' );
- ord I0,"a",0
- print I0
- end
-CODE
+.sub exception_two_param_ord_empty_string_register
+ push_eh handler
+ ord $I0,$S0
+ ok( 0, 'no exception: 2-param ord, empty string register' )
+ handler:
+ .exception_is( 'Cannot get character of empty string' )
+.end
-pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string register' );
- set S0,"a"
- ord I0,S0,0
- print I0
- end
-CODE
+.sub exception_three_param_ord_empty_string
+ push_eh handler
+ ord $I0,"",0
+ ok(0, 'no exception: 3-param ord, empty string' )
+ handler:
+ .exception_is( 'Cannot get character of empty string' )
+.end
-pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string' );
- ord I0,"ab",1
- print I0
- end
-CODE
+.sub exception_three_param_ord_empty_string_register
+ push_eh handler
+ ord $I0,$S0,0
+ ok( 0, 'no exception: 3-param ord, empty string register' )
+ handler:
+ .exception_is( 'Cannot get character of empty string' )
+.end
-pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string register' );
- set S0,"ab"
- ord I0,S0,1
- print I0
- end
-CODE
+.sub two_param_ord_one_character_string
+ ord $I0,"a"
+ is( $I0, "97", '2-param ord, one-character string' )
+.end
-pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, multi-character string' );
- ord I0,"ab",2
- print I0
- end
-CODE
-/^Cannot get character past end of string/
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, multi-character string' );
- set S0,"ab"
- ord I0,S0,2
- print I0
- end
-CODE
-/^Cannot get character past end of string/
-OUTPUT
-
-pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string, from end' );
- ord I0,"a",-1
- print I0
- end
-CODE
+.sub two_param_ord_multi_character_string
+ ord $I0,"abc"
+ is( $I0, "97", '2-param ord, multi-character string' )
+.end
-pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string register, from end' );
- set S0,"a"
- ord I0,S0,-1
- print I0
- end
-CODE
+.sub two_param_ord_one_character_string_register
+ set $S0,"a"
+ ord $I0,$S0
+ is( $I0, "97", '2-param ord, one-character string register' )
+.end
-pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string, from end' );
- ord I0,"ab",-1
- print I0
- end
-CODE
+.sub three_param_ord_one_character_string
+ ord $I0,"a",0
+ is( $I0, "97", '3-param ord, one-character string' )
+.end
-pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string register, from end' );
- set S0,"ab"
- ord I0,S0,-1
- print I0
- end
-CODE
+.sub three_param_ord_one_character_string_register
+ set $S0,"a"
+ ord $I0,$S0,0
+ is( $I0, "97", '3-param ord, one-character string register' )
+.end
-pasm_error_output_like(
- <<'CODE', <<'OUTPUT', '3-param ord, multi-character string register, from end, OOB' );
- set S0,"ab"
- ord I0,S0,-3
- print I0
- end
-CODE
-/^Cannot get character before beginning of string/
-OUTPUT
-
-pasm_output_is( <<'CODE', chr(32), 'chr of 32 is space in ASCII' );
- chr S0, 32
- print S0
- end
-CODE
-
-pasm_output_is( <<'CODE', chr(65), 'chr of 65 is A in ASCII' );
- chr S0, 65
- print S0
- end
-CODE
-
-pasm_output_is( <<'CODE', chr(122), 'chr of 122 is z in ASCII' );
- chr S0, 122
- print S0
- end
-CODE
+.sub three_param_ord_multi_character_string
+ ord $I0,"ab",1
+ is( $I0, "98", '3-param ord, multi-character string' )
+.end
-pasm_output_is( <<'CODE', <<'OUTPUT', 'if_s_ic' );
- set S0, "I've told you once, I've told you twice..."
- if S0, OK1
- print "not "
-OK1: print "ok 1\n"
-
- set S0, "0.0"
- if S0, OK2
- print "not "
-OK2: print "ok 2\n"
-
- set S0, ""
- if S0, BAD3
- branch OK3
-BAD3: print "not "
-OK3: print "ok 3\n"
-
- set S0, "0"
- if S0, BAD4
- branch OK4
-BAD4: print "not "
-OK4: print "ok 4\n"
-
- set S0, "0e0"
- if S0, OK5
- print "not "
-OK5: print "ok 5\n"
-
- set S0, "x"
- if S0, OK6
- print "not "
-OK6: print "ok 6\n"
-
- set S0, "\\x0"
- if S0, OK7
- print "not "
-OK7: print "ok 7\n"
-
- set S0, "\n"
- if S0, OK8
- print "not "
-OK8: print "ok 8\n"
-
- set S0, " "
- if S0, OK9
- print "not "
-OK9: print "ok 9\n"
-
-# An empty register should be false...
- clears
- if S1, BAD10
- branch OK10
-BAD10: print "not "
-OK10: print "ok 10\n"
+.sub three_param_ord_multi_character_string_register
+ set $S0,"ab"
+ ord $I0,$S0,1
+ is( $I0, "98", '3-param ord, multi-character string register' )
+.end
- end
-CODE
-ok 1
-ok 2
-ok 3
-ok 4
-ok 5
-ok 6
-ok 7
-ok 8
-ok 9
-ok 10
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'repeat_s_s|sc_i|ic' );
- set S0, "x"
-
- repeat S1, S0, 12
- print S0
- print "\n"
- print S1
- print "\n"
-
- set I0, 12
- set S2, "X"
-
- repeat S3, S2, I0
- print S2
- print "\n"
- print S3
- print "\n"
-
- repeat S4, "~", 12
- print S4
- print "\n"
-
- repeat S5, "~", I0
- print S5
- print "\n"
-
- print ">"
- repeat S6, "***", 0
- print S6
- print "< done\n"
+.sub exception_three_param_ord_multi_character_string
+ push_eh handler
+ ord $I0,"ab",2
+ ok( 0, 'no exception: 3-param ord, multi-character string' )
+ handler:
+ .exception_is( 'Cannot get character past end of string' )
+.end
- end
-CODE
-x
-xxxxxxxxxxxx
-X
-XXXXXXXXXXXX
-~~~~~~~~~~~~
-~~~~~~~~~~~~
->< done
-OUTPUT
+.sub exception_three_param_ord_multi_character_string
+ push_eh handler
+ set $S0,"ab"
+ ord $I0,$S0,2
+ ok( 0, 'no exception: 3-param ord, multi-character string' )
+ handler:
+ .exception_is( 'Cannot get character past end of string' )
+.end
-pasm_error_output_like( <<'CODE', qr/Cannot repeat with negative arg\n/, 'repeat OOB' );
- repeat S0, "japh", -1
- end
-CODE
+.sub three_param_ord_one_character_string_from_end
+ ord $I0,"a",-1
+ is( $I0, "97", '3-param ord, one-character string, from end' )
+.end
+
+.sub three_param_ord_one_character_string_register_from_end
+ set $S0,"a"
+ ord $I0,$S0,-1
+ is( $I0, "97", '3-param ord, one-character string register, from end' )
+.end
+
+.sub three_param_ord_multi_character_string_from_end
+ ord $I0,"ab",-1
+ is( $I0, "98", '3-param ord, multi-character string, from end' )
+.end
+
+.sub three_param_ord_multi_character_string_register_from_end
+ set $S0,"ab"
+ ord $I0,$S0,-1
+ is( $I0, "98", '3-param ord, multi-character string register, from end' )
+.end
+
+.sub exception_three_param_ord_multi_character_string_register_from_end_oob
+ push_eh handler
+ set $S0,"ab"
+ ord $I0,$S0,-3
+ ok( 0, 'no exception: 3-param ord, multi-character string register, from end, OOB' )
+ handler:
+ .exception_is( 'Cannot get character before beginning of string' )
+.end
+
+.sub chr_of_thirty_two_is_space_in_ascii
+ chr $S0, 32
+ is( $S0, " ", 'chr of 32 is space in ASCII' )
+.end
+
+.sub chr_of_sixty_five_is_a_in_ascii
+ chr $S0, 65
+ is( $S0, "A", 'chr of 65 is A in ASCII' )
+.end
+
+.sub chr_of_one_hundred_and_twenty_two_is_z_in_ascii
+ chr $S0, 122
+ is( $S0, "z", 'chr of 122 is z in ASCII' )
+.end
+
+.sub test_if_s_ic
+ set $S0, "I've told you once, I've told you twice..."
+ ok( $S0, 'normal strings are true' )
+
+ set $S0, "0.0"
+ ok( $S0, '0.0 is true' )
+
+ set $S0, ""
+ nok( $S0, 'empty string is false' )
+
+ set $S0, "0"
+ nok( $S0, '"0" string is false' )
+
+ set $S0, "0e0"
+ ok( $S0, 'string "0e0" is true' )
+
+ set $S0, "x"
+ ok( $S0, 'string "x" is true' )
+
+ set $S0, "\\x0"
+ ok( $S0, 'string "\\x0" is true' )
+
+ set $S0, "\n"
+ ok( $S0, 'string "\n" is true' )
+
+ set $S0, " "
+ ok( $S0, 'string " " is true' )
+
+ # An empty register should be false...
+ clears
+ nok( $S1, 'empty register is false' )
+.end
-pir_error_output_like( <<'CODE', qr/Cannot repeat with negative arg\n/, 'repeat OOB, repeat_p_p_p' );
-.sub main
+.sub repeat_s_s_sc_i_ic
+ set $S0, "x"
+ repeat $S1, $S0, 12
+ is( $S0, "x", 'repeat_s_s|sc_i|ic' )
+ is( $S1, "xxxxxxxxxxxx", 'repeat_s_s|sc_i|ic' )
+
+ set $I0, 12
+ set $S2, "X"
+ repeat $S3, $S2, $I0
+ is( $S2, "X", 'repeat_s_s|sc_i|ic' )
+ is( $S3, "XXXXXXXXXXXX", 'repeat_s_s|sc_i|ic' )
+
+ repeat $S4, "~", 12
+ is( $S4, "~~~~~~~~~~~~", 'repeat_s_s|sc_i|ic' )
+
+ repeat $S5, "~", $I0
+ is( $S5, "~~~~~~~~~~~~", 'repeat_s_s|sc_i|ic' )
+
+
+ repeat $S6, "***", 0
+ is( $S6, "", 'repeat_s_s|sc_i|ic' )
+.end
+
+.sub exception_repeat_oob
+ push_eh handler
+ repeat $S0, "japh", -1
+ handler:
+ .exception_is( 'Cannot repeat with negative arg' )
+.end
+
+.sub exception_repeat_oob_repeat_p_p_p
+ push_eh handler
$P0 = new ['String']
$P1 = new ['String']
$P2 = new ['Integer']
-
$P2 = -1
-
repeat $P1, $P0, $P2
+ handler:
+ .exception_is( 'Cannot repeat with negative arg' )
.end
-CODE
-pir_error_output_like( <<'CODE', qr/Cannot repeat with negative arg\n/, 'repeat OOB, repeate_p_p_i' );
-.sub main
+.sub exception_repeat_oob_repeate_p_p_i
+ push_eh handler
$P0 = new ['String']
$P1 = new ['String']
-
repeat $P1, $P0, -1
+ handler:
+ .exception_is( 'Cannot repeat with negative arg' )
.end
-CODE
-pir_output_is( <<'CODE', <<'OUTPUT', 'encodingname OOB' );
-.sub main
+.sub encodingname_oob
$I0 = -1
-
$S0 = encodingname -1
$S0 = encodingname $I0
- say 'ok'
+ ok( 1, "no exceptions in encodingname_oob" )
.end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'index, 3-arg form' );
- set S0, "Parrot"
- set S1, "Par"
- index I1, S0, S1
- print I1
- print "\n"
-
- set S1, "rot"
- index I1, S0, S1
- print I1
- print "\n"
-
- set S1, "bar"
- index I1, S0, S1
- print I1
- print "\n"
-
- end
-CODE
-0
-3
--1
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'index, 4-arg form' );
- set S0, "Barbarian"
- set S1, "ar"
- index I1, S0, S1, 0
- print I1
- print "\n"
-
- index I1, S0, S1, 2
- print I1
- print "\n"
-
- set S1, "qwx"
- index I1, S0, S1, 0
- print I1
- print "\n"
-
- end
-CODE
-1
-4
--1
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'index, 4-arg form, bug 22718' );
- set S1, "This is not quite right"
- set S0, " is "
- index I0, S1, S0, 0
- print I0
- set S0, "is"
- index I0, S1, S0, 0
- print I0
- print "\n"
- end
-CODE
-42
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'index, null strings' );
- set S0, "Parrot"
- set S1, ""
- index I1, S0, S1
- print I1
- print "\n"
-
- index I1, S0, S1, 0
- print I1
- print "\n"
-
- index I1, S0, S1, 5
- print I1
- print "\n"
-
- index I1, S0, S1, 6
- print I1
- print "\n"
-
- set S0, ""
- set S1, "a"
- index I1, S0, S1
- print I1
- print "\n"
-
- index I1, S0, S1, 0
- print I1
- print "\n"
-
- set S0, "Parrot"
- null S1
- index I1, S0, S1
- print I1
- print "\n"
-
- null S0
- null S1
- index I1, S0, S1
- print I1
- print "\n"
- end
-CODE
--1
--1
--1
--1
--1
--1
--1
--1
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'index, embedded nulls' );
- set S0, "Par\0\0rot"
- set S1, "\0"
- index I1, S0, S1
- print I1
- print "\n"
-
- index I1, S0, S1, 4
- print I1
- print "\n"
-
- end
-CODE
-3
-4
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'index, big strings' );
- set S0, "a"
- repeat S0, S0, 10000
- set S1, "a"
- repeat S1, S1, 500
- index I1, S0, S1
- print I1
- print "\n"
-
- index I1, S0, S1, 1234
- print I1
- print "\n"
-
- index I1, S0, S1, 9501
- print I1
- print "\n"
-
- end
-CODE
-0
-1234
--1
-OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', 'index, big, hard to match strings' );
-# Builds a 24th iteration fibonacci string (approx. 100K)
- set S1, "a"
- set S2, "b"
- set I0, 0
-LOOP:
- set S3, S1
- concat S1, S2, S3
- set S2, S3
- inc I0
- lt I0, 24, LOOP
-
- index I1, S1, S2
- print I1
- print "\n"
-
- index I1, S1, S2, 50000
- print I1
- print "\n"
- end
-CODE
-46368
--1
-OUTPUT
+.sub index_three_arg_form
+ set $S0, "Parrot"
+ set $S1, "Par"
+ index $I1, $S0, $S1
+ is( $I1, "0", 'index, 3-arg form' )
+
+ set $S1, "rot"
+ index $I1, $S0, $S1
+ is( $I1, "3", 'index, 3-arg form' )
+
+ set $S1, "bar"
+ index $I1, $S0, $S1
+ is( $I1, "-1", 'index, 3-arg form' )
+.end
+
+.sub index_four_arg_form
+ set $S0, "Barbarian"
+ set $S1, "ar"
+ index $I1, $S0, $S1, 0
+ is( $I1, "1", 'index, 4-arg form' )
+
+ index $I1, $S0, $S1, 2
+ is( $I1, "4", 'index, 4-arg form' )
+
+ set $S1, "qwx"
+ index $I1, $S0, $S1, 0
+ is( $I1, "-1", 'index, 4-arg form' )
+.end
+
+.sub index_four_arg_form_bug_twenty_two_thousand_seven_hundred_and_eighteen
+ set $S1, "This is not quite right"
+ set $S0, " is "
+ index $I0, $S1, $S0, 0
+ is( $I0, "4", 'index, 4-arg form, bug 22718' )
+
+ set $S0, "is"
+ index $I0, $S1, $S0, 0
+ is( $I0, "2", 'index, 4-arg form, bug 22718' )
+.end
+
+.sub index_null_strings
+ set $S0, "Parrot"
+ set $S1, ""
+ index $I1, $S0, $S1
+ is( $I1, "-1", 'index, null strings' )
+
+ index $I1, $S0, $S1, 0
+ is( $I1, "-1", 'index, null strings' )
+
+ index $I1, $S0, $S1, 5
+ is( $I1, "-1", 'index, null strings' )
+
+ index $I1, $S0, $S1, 6
+ is( $I1, "-1", 'index, null strings' )
+
+ set $S0, ""
+ set $S1, "a"
+ index $I1, $S0, $S1
+ is( $I1, "-1", 'index, null strings' )
+
+ index $I1, $S0, $S1, 0
+ is( $I1, "-1", 'index, null strings' )
+
+ set $S0, "Parrot"
+ null $S1
+ index $I1, $S0, $S1
+ is( $I1, "-1", 'index, null strings' )
+
+ null $S0
+ null $S1
+ index $I1, $S0, $S1
+ is( $I1, "-1", 'index, null strings' )
+.end
-pir_output_is( << 'CODE', << 'OUTPUT', 'index with different charsets' );
+.sub index_embedded_nulls
+ set $S0, "Par\0\0rot"
+ set $S1, "\0"
+ index $I1, $S0, $S1
+ is( $I1, "3", 'index, embedded nulls' )
+
+ index $I1, $S0, $S1, 4
+ is( $I1, "4", 'index, embedded nulls' )
+.end
-.sub test :main
+.sub index_big_strings
+ set $S0, "a"
+ repeat $S0, $S0, 10000
+ set $S1, "a"
+ repeat $S1, $S1, 500
+ index $I1, $S0, $S1
+ is( $I1, "0", 'index, big strings' )
+
+ index $I1, $S0, $S1, 1234
+ is( $I1, "1234", 'index, big strings' )
+
+ index $I1, $S0, $S1, 9501
+ is( $I1, "-1", 'index, big strings' )
+.end
+
+# Builds a 24th iteration fibonacci string (approx. 100K)
+.sub index_big_hard_to_match_strings
+ set $S1, "a"
+ set $S2, "b"
+ set $I0, 0
+ LOOP:
+ set $S3, $S1
+ concat $S1, $S2, $S3
+ set $S2, $S3
+ inc $I0
+ lt $I0, 24, LOOP
+ index $I1, $S1, $S2
+ is( $I1, "46368", 'index, big, hard to match strings' )
+ index $I1, $S1, $S2, 50000
+ is( $I1, "-1", 'index, big, hard to match strings' )
+.end
- print "default - default:\n"
+.sub index_with_different_charsets
set $S0, "Parrot"
set $S1, "rot"
index $I1, $S0, $S1
- print $I1
- print "\n"
+ is( $I1, "3", 'default - default' )
- print "ascii - ascii:\n"
set $S0, ascii:"Parrot"
set $S1, ascii:"rot"
index $I1, $S0, $S1
- print $I1
- print "\n"
+ is( $I1, "3", 'ascii - ascii')
- print "default - ascii:\n"
set $S0, "Parrot"
set $S1, ascii:"rot"
index $I1, $S0, $S1
- print $I1
- print "\n"
+ is( $I1, "3", 'default - ascii' )
- print "ascii - default:\n"
set $S0, ascii:"Parrot"
set $S1, "rot"
index $I1, $S0, $S1
- print $I1
- print "\n"
+ is( $I1, "3", 'ascii - default' )
- print "binary - binary:\n"
set $S0, binary:"Parrot"
set $S1, binary:"rot"
index $I1, $S0, $S1
- print $I1
- print "\n"
+ is( $I1, "-1", 'binary - binary' )
+.end
+.sub negative_index_bug_35959
+ index $I1, "u", "t", -123456
+ is( $I1, "-1", 'negative index #35959' )
+
+ index $I1, "u", "t", -123456789
+ is( $I1, "-1", 'negative index #35959' )
.end
-CODE
-default - default:
-3
-ascii - ascii:
-3
-default - ascii:
-3
-ascii - default:
-3
-binary - binary:
--1
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'negative index #35959' );
- index I1, "u", "t", -123456
- print I1
- print "\n"
- index I1, "u", "t", -123456789
- print I1
- print "\n"
- end
-CODE
--1
--1
-OUTPUT
-
-SKIP: {
- skip( "Pending rework of creating non-ascii literals", 2 );
- pasm_output_is( <<'CODE', <<'OUTPUT', 'index, multibyte matching' );
- set S0, "\xAB"
- find_chartype I0, "8859-1"
- set_chartype S0, I0
- find_encoding I0, "singlebyte"
- set_encoding S0, I0
-
- find_encoding I0, "utf8"
- find_chartype I1, "unicode"
- transcode S1, S0, I0, I1
-
- eq S0, S1, equal
- print "not "
-equal:
- print "equal\n"
-
- index I0, S0, S1
- print I0
- print "\n"
- index I0, S1, S0
- print I0
- print "\n"
- end
-CODE
-equal
-0
-0
-OUTPUT
-
- pasm_output_is( <<'CODE', <<'OUTPUT', 'index, multibyte matching 2' );
- set S0, "\xAB\xBA"
- set S1, "foo\xAB\xAB\xBAbar"
- find_chartype I0, "8859-1"
- set_chartype S0, I0
- find_encoding I0, "singlebyte"
- set_encoding S0, I0
-
- find_chartype I0, "unicode"
- find_encoding I1, "utf8"
- transcode S1, S1, I1, I0
-
- index I0, S0, S1
- print I0
- print "\n"
- index I0, S1, S0
- print I0
- print "\n"
- end
-CODE
--1
-4
-OUTPUT
-}
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'num to string' );
- set N0, 80.43
- set S0, N0
- print S0
- print "\n"
-
- set N0, -1.111111
- set S0, N0
- print S0
- print "\n"
- end
-CODE
-80.43
--1.111111
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'string to int' );
- set S0, "123"
- set I0, S0
- print I0
- print "\n"
-
- set S0, " 1"
- set I0, S0
- print I0
- print "\n"
-
- set S0, "-1"
- set I0, S0
- print I0
- print "\n"
-
- set S0, "Not a number"
- set I0, S0
- print I0
- print "\n"
-
- set S0, ""
- set I0, S0
- print I0
- print "\n"
- end
-CODE
-123
-1
--1
-0
-0
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'concat/substr (COW)' );
- set S0, "<JA"
- set S1, "PH>"
- set S2, ""
- concat S2, S2, S0
- concat S2, S2, S1
- print S2
- print "\n"
- substr S0, S2, 1, 4
- print S0
- print "\n"
- end
-CODE
-<JAPH>
-JAPH
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'constant to cstring' );
- stringinfo I0, "\n", 2
- stringinfo I1, "\n", 2
- eq I1, I0, ok1
- print "N"
-ok1:
- print "OK"
- print "\n"
- stringinfo I2, "\n", 2
- eq I2, I0, ok2
- print "N"
-ok2:
- print "OK\n"
- end
-CODE
-OK
-OK
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'COW with chopn leaving original untouched' );
- set S0, "ABCD"
- clone S1, S0
- chopn S0, 1
- print S0
- print "\n"
- print S1
- print "\n"
- end
-CODE
-ABC
-ABCD
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'Check that bug #16874 was fixed' );
- set S0, "foo "
- set S1, "bar "
- set S2, "quux "
- set S15, ""
- concat S15, S0
- concat S15, S1
- concat S15, S2
- print "["
- print S15
- print "]\n"
- end
-CODE
-[foo bar quux ]
-OUTPUT
-
-pasm_output_is( <<'CODE', "all ok\n", 'stress concat' );
- set I0, 1000
- set S0, "michael"
-LOOP:
- set S2, I0
- concat S1, S0, S2
- concat S3, "mic", "hael"
- concat S3, S3, S2
- eq S1, S3, BOTTOM
- print "Failed: "
- print S1
- print " ne "
- print S3
- print "\n"
- end
-BOTTOM:
- sub I0, I0, 1
- ne I0, 0, LOOP
- print "all ok\n"
- end
-CODE
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'ord and substring (see #17035)' );
- set S0, "abcdef"
- substr S1, S0, 2, 3
- ord I0, S0, 2
- ord I1, S1, 0
- ne I0, I1, fail
- ord I0, S0, 3
- ord I1, S1, 1
- ne I0, I1, fail
- ord I0, S0, 4
- ord I1, S1, 2
- ne I0, I1, fail
- print "It's all good\n"
- end
-fail:
- print "Not good: original string="
- print I0
- print ", substring="
- print I1
- print "\n"
- end
-CODE
-It's all good
-OUTPUT
+.sub index_multibyte_matching
+ skip( 3, "Pending rework of creating non-ascii literals" )
-pasm_output_is( <<'CODE', <<'OUTPUT', 'sprintf' );
- branch MAIN
+ # set $S0, "\xAB"
+ # find_chartype $I0, "8859-1"
+ # set_chartype $S0, $I0
+ # find_encoding $I0, "singlebyte"
+ # set_encoding $S0, $I0
+ # find_encoding $I0, "utf8"
+ # find_chartype $I1, "unicode"
+ # transcode $S1, $S0, $I0, $I1
+ # is( $S0, $S1, 'equal' );
-NEWARYP:
- new P1, 'ResizablePMCArray'
- set P1[0], P0
- local_return P4
-NEWARYS:
- new P1, 'ResizablePMCArray'
- set P1[0], S0
- local_return P4
-NEWARYI:
- new P1, 'ResizablePMCArray'
- set P1[0], I0
- local_return P4
-NEWARYN:
- new P1, 'ResizablePMCArray'
- set P1[0], N0
- local_return P4
-PRINTF:
- sprintf S2, S1, P1
- print S2
- local_return P4
-
-MAIN:
- new P4, 'ResizableIntegerArray'
- set S1, "Hello, %s\n"
- set S0, "Parrot!"
- local_branch P4, NEWARYS
- local_branch P4, PRINTF
-
- set S1, "Hash[0x%x]\n"
- set I0, 256
- local_branch P4, NEWARYI
- local_branch P4, PRINTF
-
- set S1, "Hash[0x%lx]\n"
- set I0, 256
- local_branch P4, NEWARYI
- local_branch P4, PRINTF
-
- set S1, "Hello, %.2s!\n"
- set S0, "Parrot"
- local_branch P4, NEWARYS
- local_branch P4, PRINTF
-
- set S1, "Hello, %Ss"
- set S0, S2
- local_branch P4, NEWARYS
- local_branch P4, PRINTF
-
- set S1, "1 == %Pd\n"
- new P0, 'Integer'
- set P0, 1
- local_branch P4, NEWARYP
- local_branch P4, PRINTF
-
- set S1, "-255 == %vd\n"
- set I0, -255
- local_branch P4, NEWARYI
- local_branch P4, PRINTF
-
- set S1, "+123 == %+vd\n"
- set I0, 123
- local_branch P4, NEWARYI
- local_branch P4, PRINTF
-
- set S1, "256 == %vu\n"
- set I0, 256
- local_branch P4, NEWARYI
- local_branch P4, PRINTF
-
- set S1, "1 == %+vu\n"
- set I0, 1
- local_branch P4, NEWARYI
- local_branch P4, PRINTF
-
- set S1, "001 == %0.3u\n"
- set I0, 1
- local_branch P4, NEWARYI
- local_branch P4, PRINTF
-
- set S1, "001 == %+0.3u\n"
- set I0, 1
- local_branch P4, NEWARYI
- local_branch P4, PRINTF
-
- set S1, "0.500000 == %f\n"
- set N0, 0.5
- local_branch P4, NEWARYN
- local_branch P4, PRINTF
-
- set S1, "0.500 == %5.3f\n"
- set N0, 0.5
- local_branch P4, NEWARYN
- local_branch P4, PRINTF
-
- set S1, "0.001 == %g\n"
- set N0, 0.001
- local_branch P4, NEWARYN
- local_branch P4, PRINTF
-
- set S1, "1e+06 == %g\n"
- set N0, 1.0e6
- local_branch P4, NEWARYN
- local_branch P4, PRINTF
-
- set S1, "0.5 == %3.3g\n"
- set N0, 0.5
- local_branch P4, NEWARYN
- local_branch P4, PRINTF
-
- set S1, "%% == %%\n"
- set I0, 0
- local_branch P4, NEWARYI
- local_branch P4, PRINTF
-
- set S1, "That's all, %s\n"
- set S0, "folks!"
- local_branch P4, NEWARYS
- local_branch P4, PRINTF
+ # index $I0, $S0, $S1
+ # is( $I0, "0", 'index, multibyte matching' )
- end
-CODE
-Hello, Parrot!
-Hash[0x100]
-Hash[0x100]
-Hello, Pa!
-Hello, Hello, Pa!
-1 == 1
--255 == -255
-+123 == +123
-256 == 256
-1 == 1
-001 == 001
-001 == 001
-0.500000 == 0.500000
-0.500 == 0.500
-0.001 == 0.001
-1e+06 == 1e+06
-0.5 == 0.5
-% == %
-That's all, folks!
-OUTPUT
+ # index $I0, $S1, $S0
+ # is( $I0, "0", 'index, multibyte matching' )
+.end
-pasm_output_is( <<'CODE', <<'OUTPUT', 'other form of sprintf op' );
- branch MAIN
+.sub index_multibyte_matching_two
+ skip( 2, "Pending rework of creating non-ascii literals" )
+ # set $S0, "\xAB\xBA"
+ # set $S1, "foo\xAB\xAB\xBAbar"
+ # find_chartype $I0, "8859-1"
+ # set_chartype $S0, $I0
+ # find_encoding $I0, "singlebyte"
+ # set_encoding $S0, $I0
+ # find_chartype $I0, "unicode"
+ # find_encoding $I1, "utf8"
+ # transcode $S1, $S1, $I1, $I0
+ # index $I0, $S0, $S1
+ # is( $I0, "-1", 'index, multibyte matching 2' )
+ # index $I0, $S1, $S0
+ # is( $I0, "4", 'index, multibyte matching 2' )
+.end
-PRINTF:
- sprintf P3, P2, P1
- print P3
- local_return P4
-
-MAIN:
- new P4, 'ResizableIntegerArray'
- new P3, 'String'
-
- new P2, 'String'
- set P2, "15 is %b\n"
- new P1, 'ResizablePMCArray'
- set P1[0], 15
- local_branch P4, PRINTF
-
- new P2, 'String'
- set P2, "128 is %o\n"
- new P1, 'ResizablePMCArray'
- set P1[0], 128
- local_branch P4, PRINTF
+.sub num_to_string
+ set $N0, 80.43
+ set $S0, $N0
+ is( $S0, "80.43", 'num to string' )
+
+ set $N0, -1.111111
+ set $S0, $N0
+ is( $S0, "-1.111111", 'num to string' )
+.end
- end
-CODE
-15 is 1111
-128 is 200
-OUTPUT
+.sub string_to_int
+ set $S0, "123"
+ set $I0, $S0
+ is( $I0, "123", 'string to int' )
+
+ set $S0, " 1"
+ set $I0, $S0
+ is( $I0, "1", 'string to int' )
+
+ set $S0, "-1"
+ set $I0, $S0
+ is( $I0, "-1", 'string to int' )
+
+ set $S0, "Not a number"
+ set $I0, $S0
+ is( $I0, "0", 'string to int' )
+
+ set $S0, ""
+ set $I0, $S0
+ is( $I0, "0", 'string to int' )
+.end
-pir_output_is( <<'CODE', <<'OUTPUT', 'sprintf - left justify' );
-.sub main :main
- $P0 = new 'ResizablePMCArray'
- $P1 = new 'Integer'
- $P1 = 10
- $P0[0] = $P1
- $P1 = new 'String'
- $P1 = "foo"
- $P0[1] = $P1
- $P1 = new 'String'
- $P1 = "bar"
- $P0[2] = $P1
- $S0 = sprintf "%-*s - %s\n", $P0
- print $S0
- end
-.end
-CODE
-foo - bar
-OUTPUT
-
-{
- my $output = substr( ( 'f' x ( $PConfig{intvalsize} * 2 ) ) . ( ' ' x 20 ), 0, 20 );
- pir_output_is( <<'CODE', $output, 'Correct precision for %x' ); }
-.sub main :main
- $P0 = new 'ResizablePMCArray'
- $P0[0] = -1
- $S0 = sprintf "%-20x", $P0
- print $S0
- end
-.end
-CODE
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'exchange' );
- set S0, "String #0\n"
- set S1, "String #1\n"
- exchange S0, S1
- print S0
- print S1
-
- set S2, "String #2\n"
- exchange S2, S2
- print S2
+.sub concat_or_substr_cow
+ set $S0, "<JA"
+ set $S1, "PH>"
+ set $S2, ""
+ concat $S2, $S2, $S0
+ concat $S2, $S2, $S1
+ is( $S2, "<JAPH>", 'concat/substr (COW)' )
+
+ substr $S0, $S2, 1, 4
+ is( $S0, "JAPH", 'concat/substr (COW)' )
+.end
- end
-CODE
-String #1
-String #0
-String #2
-OUTPUT
-
-SKIP: {
- skip( "Pending reimplementation of find_encoding", 1 );
- pasm_output_is( <<'CODE', <<'OUTPUT', 'find_encoding' );
- find_encoding I0, "singlebyte"
- print I0
- print "\n"
- find_encoding I0, "utf8"
- print I0
- print "\n"
- find_encoding I0, "utf16"
- print I0
- print "\n"
- find_encoding I0, "utf32"
- print I0
- print "\n"
- end
-CODE
-0
-1
-2
-3
-OUTPUT
-}
-
-SKIP: {
- skip( "no more visible encoding", 1 );
- pasm_output_is( <<'CODE', <<'OUTPUT', 'string_encoding' );
- set I0, 0
- new S0, 0, I0
- string_encoding I1, S0
- eq I0, I1, OK1
- print "not "
-OK1: print "ok 1\n"
-
- set I0, 1
- new S0, 0, I0
- string_encoding I1, S0
- eq I0, I1, OK2
- print "not "
-OK2: print "ok 2\n"
-
- set I0, 2
- new S0, 0, I0
- string_encoding I1, S0
- eq I0, I1, OK3
- print "not "
-OK3: print "ok 3\n"
-
- set I0, 3
- new S0, 0, I0
- string_encoding I1, S0
- eq I0, I1, OK4
- print "not "
-OK4: print "ok 4\n"
-
- end
-CODE
-ok 1
-ok 2
-ok 3
-ok 4
-OUTPUT
-}
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'assign' );
- set S4, "JAPH\n"
- assign S5, S4
- print S4
- print S5
- end
-CODE
-JAPH
-JAPH
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'assign & globber' );
- set S4, "JAPH\n"
- assign S5, S4
- assign S4, "Parrot\n"
- print S4
- print S5
- end
-CODE
-Parrot
-JAPH
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'assign & globber 2' );
- set S4, "JAPH\n"
- set S5, S4
- assign S4, "Parrot\n"
- print S4
- print S5
- end
-CODE
-Parrot
-Parrot
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bands NULL string' );
- null S1
- set S2, "abc"
- bands S1, S2
- null S3
- eq S1, S3, ok1
- print "not "
-ok1: print "ok 1\n"
- set S1, ""
- bands S1, S2
- unless S1, ok2
- print "not "
-ok2: print "ok 2\n"
-
- null S2
- set S1, "abc"
- bands S1, S2
- null S3
- eq S1, S3, ok3
- print "not "
-ok3: print "ok 3\n"
- set S2, ""
- bands S1, S2
- unless S1, ok4
- print "not "
-ok4: print "ok 4\n"
- end
-CODE
-ok 1
-ok 2
-ok 3
-ok 4
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bands 2' );
- set S1, "abc"
- set S2, "EE"
- bands S1, S2
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-A@
-EE
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bands 3' );
- set S1, "abc"
- set S2, "EE"
- bands S0, S1, S2
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-A@
-abc
-EE
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bands COW' );
- set S1, "foo"
- substr S2, S1, 0, 3
- bands S1, "bar"
- print S2
- print "\n"
- end
-CODE
-foo
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bors NULL string' );
- null S1
- null S2
- bors S1, S2
- null S3
- eq S1, S3, OK1
- print "not "
-OK1: print "ok 1\n"
-
- null S1
- set S2, ""
- bors S1, S2
- null S3
- eq S1, S3, OK2
- print "not "
-OK2: print "ok 2\n"
- bors S2, S1
- eq S2, S3, OK3
- print "not "
-OK3: print "ok 3\n"
-
- null S1
- set S2, "def"
- bors S1, S2
- eq S1, "def", OK4
- print "not "
-OK4: print "ok 4\n"
- null S2
- bors S1, S2
- eq S1, "def", OK5
- print "not "
-OK5: print "ok 5\n"
-
- null S1
- null S2
- bors S3, S1, S2
- null S4
- eq S3, S4, OK6
- print "not "
-OK6: print "ok 6\n"
-
- set S1, ""
- bors S3, S1, S2
- eq S3, S4, OK7
- print "not "
-OK7: print "ok 7\n"
- bors S3, S2, S1
- eq S3, S4, OK8
- print "not "
-OK8: print "ok 8\n"
-
- set S1, "def"
- bors S3, S1, S2
- eq S3, "def", OK9
- print "not "
-OK9: print "ok 9\n"
- bors S3, S2, S1
- eq S3, "def", OK10
- print "not "
-OK10: print "ok 10\n"
- end
-CODE
-ok 1
-ok 2
-ok 3
-ok 4
-ok 5
-ok 6
-ok 7
-ok 8
-ok 9
-ok 10
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bors 2' );
- set S1, "abc"
- set S2, "EE"
- bors S1, S2
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-egc
-EE
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bors 3' );
- set S1, "abc"
- set S2, "EE"
- bors S0, S1, S2
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-egc
-abc
-EE
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bors COW' );
- set S1, "foo"
- substr S2, S1, 0, 3
- bors S1, "bar"
- print S2
- print "\n"
- end
-CODE
-foo
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bxors NULL string' );
- null S1
- null S2
- bxors S1, S2
- null S3
- eq S1, S3, OK1
- print "not "
-OK1: print "ok 1\n"
-
- null S1
- set S2, ""
- bxors S1, S2
- null S3
- eq S1, S3, OK2
- print "not "
-OK2: print "ok 2\n"
- bxors S2, S1
- eq S2, S3, OK3
- print "not "
-OK3: print "ok 3\n"
-
- null S1
- set S2, "abc"
- bxors S1, S2
- eq S1, "abc", OK4
- print "not "
-OK4: print "ok 4\n"
- null S2
- bxors S1, S2
- eq S1, "abc", OK5
- print "not "
-OK5: print "ok 5\n"
-
- null S1
- null S2
- bxors S3, S1, S2
- null S4
- eq S3, S4, OK6
- print "not "
-OK6: print "ok 6\n"
-
- set S1, ""
- bxors S3, S1, S2
- eq S3, S4, OK7
- print "not "
-OK7: print "ok 7\n"
- bxors S3, S2, S1
- eq S3, S4, OK8
- print "not "
-OK8: print "ok 8\n"
-
- set S1, "abc"
- bxors S3, S1, S2
- eq S3, "abc", OK9
- print "not "
-OK9: print "ok 9\n"
- bxors S3, S2, S1
- eq S3, "abc", OK10
- print "not "
-OK10: print "ok 10\n"
- end
-CODE
-ok 1
-ok 2
-ok 3
-ok 4
-ok 5
-ok 6
-ok 7
-ok 8
-ok 9
-ok 10
-OUTPUT
-
-# string_133.pasm, used for t/native_pbc/string.t
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bxors 2' );
- set S1, "a2c"
- set S2, "Dw"
- bxors S1, S2
- print S1
- print "\n"
- print S2
- print "\n"
- set S1, "abc"
- set S2, " X"
- bxors S1, S2
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-%Ec
-Dw
-ABCX
- X
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bxors 3' );
- set S1, "a2c"
- set S2, "Dw"
- bxors S0, S1, S2
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- set S1, "abc"
- set S2, " Y"
- bxors S0, S1, S2
- print S0
- print "\n"
- print S1
- print "\n"
- print S2
- print "\n"
- end
-CODE
-%Ec
-a2c
-Dw
-ABCY
-abc
- Y
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bxors COW' );
- set S1, "foo"
- substr S2, S1, 0, 3
- bxors S1, "bar"
- print S2
- print "\n"
- end
-CODE
-foo
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bnots NULL string' );
- null S1
- null S2
- bnots S1, S2
- null S3
- eq S1, S3, OK1
- print "not "
-OK1: print "ok 1\n"
-
- null S1
- set S2, ""
- bnots S1, S2
- null S3
- eq S1, S3, OK2
- print "not "
-OK2: print "ok 2\n"
- bnots S2, S1
- eq S2, S3, OK3
- print "not "
-OK3: print "ok 3\n"
- end
-CODE
-ok 1
-ok 2
-ok 3
-OUTPUT
-
-SKIP: {
- skip( "No unicode yet", 1 );
- # This was the previous test used for t/native_pbc/string.t
- pasm_output_is( <<'CODE', <<'OUTPUT', 'bnots 2' );
- getstdout P0
- push P0, "utf8"
- set S1, "a2c"
- bnots S2, S1
- print S1
- print "\n"
- print S2
- print "\n"
- bnots S1, S1
- print S1
- print "\n"
- bnots S1, S1
- print S1
- print "\n"
- end
-CODE
-a2c
-\xC2\x9E\xC3\x8D\xC2\x9C
-\xC2\x9E\xC3\x8D\xC2\x9C
-a2c
-OUTPUT
-}
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'bnots COW' );
- set S1, "foo"
- substr S2, S1, 0, 3
- bnots S1, S1
- print S2
- print "\n"
- end
-CODE
-foo
-OUTPUT
-
-SKIP: {
- skip( "no more transcode", 1 );
- pasm_output_is( <<'CODE', <<'OUTPUT', 'transcode to utf8' );
- set S1, "ASCII is the same as UTF8\n"
- find_encoding I1, "utf8"
- transcode S2, S1, I1
- print S1
- print S2
- end
-CODE
-ASCII is the same as UTF8
-ASCII is the same as UTF8
-OUTPUT
-}
-
-SKIP: {
- skip( "no more chartype", 1 );
- pasm_output_is( <<'CODE', <<'OUTPUT', 'string_chartype' );
- set S0, "Test String"
- find_chartype I0, "usascii"
- set_chartype S0, I0
- string_chartype I1, S0
- eq I1, I0, OK
- print I0
- print "\n"
- print I1
- print "\n"
- print "not "
-OK: print "ok\n"
- end
-CODE
-ok
-OUTPUT
-}
-
-# Set all string registers to values given by &$_[0](reg num)
-sub set_str_regs {
- my $code = shift;
- my $rt;
- for ( 0 .. 31 ) {
- $rt .= "\tset S$_, \"" . &$code($_) . "\"\n";
- }
- return $rt;
-}
-
-# print string registers, no additional prints
-sub print_str_regs {
- my $rt;
- for ( 0 .. 31 ) {
- $rt .= "\tprint S$_\n";
- }
- return $rt;
-}
-
-# Generate code to compare each pair of strings in a list
-sub compare_strings {
- my $const = shift;
- my $op = shift;
- my @strings = @_;
- my $i = 1;
- my $rt;
- while (@strings) {
- my $s1 = shift @strings;
- my $s2 = shift @strings;
- my $arg1;
- my $arg2;
- if ( $const == 3 ) {
- $arg1 = "\"$s1\"";
- $arg2 = "\"$s2\"";
- }
- elsif ( $const == 2 ) {
- $rt .= " set S0, \"$s1\"\n";
- $arg1 = "S0";
- $arg2 = "\"$s2\"";
- }
- elsif ( $const == 1 ) {
- $rt .= " set S0, \"$s2\"\n";
- $arg1 = "\"$s1\"";
- $arg2 = "S0";
- }
- else {
- $rt .= " set S0, \"$s1\"\n";
- $rt .= " set S1, \"$s2\"\n";
- $arg1 = "S0";
- $arg2 = "S1";
- }
- if ( eval "\"$s1\" $op \"$s2\"" ) {
- $rt .= " $op $arg1, $arg2, OK$i\n";
- $rt .= " branch ERROR\n";
- }
- else {
- $rt .= " $op $arg1, $arg2, ERROR\n";
- }
- $rt .= "OK$i:\n";
- $i++;
- }
- return $rt;
-}
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'split on empty string' );
-_main:
- split P1, "", ""
- set I1, P1
- print I1
- print "\n"
- split P0, "", "ab"
- set I0, P0
- print I0
- print "\n"
- set S0, P0[0]
- print S0
- set S0, P0[1]
- print S0
- print "\n"
- end
-CODE
-0
-2
-ab
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'split on non-empty string' );
-_main:
- split P0, "a", "afooabara"
- set I0, P0
- print I0
- print "\n"
- set I1, 0
-loop:
- set S0, P0[I1]
- print S0
- print "\n"
- inc I1
- sub I2, I1, I0
- if I2, loop
- end
-CODE
-5
+.sub constant_to_cstring
+ stringinfo $I0, "\n", 2
+ stringinfo $I1, "\n", 2
+ is( $I1, $I0, 'constant to cstring' )
-foo
-b
-r
+ stringinfo $I2, "\n", 2
+ is( $I2, $I0, 'constant to cstring' )
+.end
-OUTPUT
+.sub cow_with_chopn_leaving_original_untouched
+ set $S0, "ABCD"
+ clone $S1, $S0
+ chopn $S0, 1
+ is( $S0, "ABC", 'COW with chopn leaving original untouched' )
+ is( $S1, "ABCD", 'COW with chopn leaving original untouched' )
+.end
-pir_output_is( <<'CODE', <<'OUTPUT', 'split HLL mapped' );
-.HLL 'foohll'
-.sub main
- .local pmc RSA, fooRSA
- RSA = get_class ['ResizableStringArray']
- fooRSA = subclass ['ResizableStringArray'], 'fooRSA'
- .local pmc interp
+.sub check_that_bug_bug_16874_was_fixed
+ set $S0, "foo "
+ set $S1, "bar "
+ set $S2, "quux "
+ set $S15, ""
+ concat $S15, $S0
+ concat $S15, $S1
+ concat $S15, $S2
+ is( $S15, "foo bar quux ", 'Check that bug #16874 was fixed' )
+.end
+
+.sub stress_concat
+ set $I0, 1000
+ set $S0, "michael"
+ LOOP:
+ set $S2, $I0
+ concat $S1, $S0, $S2
+ concat $S3, "mic", "hael"
+ concat $S3, $S3, $S2
+ eq $S1, $S3, BOTTOM
+ ok(0, 'failed stress concat test')
+ end
+
+ BOTTOM:
+ sub $I0, $I0, 1
+ ne $I0, 0, LOOP
+ ok(1, 'stress concat test')
+.end
+
+.sub ord_and_substring_see_bug_17035
+ set $S0, "abcdef"
+ substr $S1, $S0, 2, 3
+ ord $I0, $S0, 2
+ ord $I1, $S1, 0
+ ne $I0, $I1, fail
+ ord $I0, $S0, 3
+ ord $I1, $S1, 1
+ ne $I0, $I1, fail
+ ord $I0, $S0, 4
+ ord $I1, $S1, 2
+ ne $I0, $I1, fail
+ ok(1, 'ord and substring #17035')
+ goto end
+ fail:
+ ok(0, 'failed: ord and substring #17035')
+ end:
+.end
+
+.sub test_sprintf
+ branch MAIN
+ NEWARYP:
+ new $P1, 'ResizablePMCArray'
+ set $P1[0], $P0
+ local_return $P4
+ NEWARYS:
+ new $P1, 'ResizablePMCArray'
+ set $P1[0], $S0
+ local_return $P4
+ NEWARYI:
+ new $P1, 'ResizablePMCArray'
+ set $P1[0], $I0
+ local_return $P4
+ NEWARYN:
+ new $P1, 'ResizablePMCArray'
+ set $P1[0], $N0
+ local_return $P4
+ PRINTF:
+ sprintf $S2, $S1, $P1
+ is( $S2, $S99, $S1 )
+ local_return $P4
+
+ MAIN:
+ new $P4, 'ResizableIntegerArray'
+ set $S1, "Hello, %s"
+ set $S0, "Parrot!"
+ set $S99, "Hello, Parrot!"
+ local_branch $P4, NEWARYS
+ local_branch $P4, PRINTF
+
+ set $S1, "Hash[0x%x]"
+ set $I0, 256
+ set $S99, "Hash[0x100]"
+ local_branch $P4, NEWARYI
+ local_branch $P4, PRINTF
+
+ set $S1, "Hash[0x%lx]"
+ set $I0, 256
+ set $S99, "Hash[0x100]"
+ local_branch $P4, NEWARYI
+ local_branch $P4, PRINTF
+
+ set $S1, "Hello, %.2s!"
+ set $S0, "Parrot"
+ set $S99, "Hello, Pa!"
+ local_branch $P4, NEWARYS
+ local_branch $P4, PRINTF
+
+ set $S1, "Hello, %Ss"
+ set $S0, $S2
+ set $S99, "Hello, Hello, Pa!"
+ local_branch $P4, NEWARYS
+ local_branch $P4, PRINTF
+
+ set $S1, "1 == %Pd"
+ new $P0, 'Integer'
+ set $P0, 1
+ set $S99, "1 == 1"
+ local_branch $P4, NEWARYP
+ local_branch $P4, PRINTF
+
+ set $S1, "-255 == %vd"
+ set $I0, -255
+ set $S99, "-255 == -255"
+ local_branch $P4, NEWARYI
+ local_branch $P4, PRINTF
+
+ set $S1, "+123 == %+vd"
+ set $I0, 123
+ set $S99, "+123 == +123"
+ local_branch $P4, NEWARYI
+ local_branch $P4, PRINTF
+
+ set $S1, "256 == %vu"
+ set $I0, 256
+ set $S99, "256 == 256"
+ local_branch $P4, NEWARYI
+ local_branch $P4, PRINTF
+
+ set $S1, "1 == %+vu"
+ set $I0, 1
+ set $S99, "1 == 1"
+ local_branch $P4, NEWARYI
+ local_branch $P4, PRINTF
+
+ set $S1, "001 == %0.3u"
+ set $I0, 1
+ set $S99, "001 == 001"
+ local_branch $P4, NEWARYI
+ local_branch $P4, PRINTF
+
+ set $S1, "001 == %+0.3u"
+ set $I0, 1
+ set $S99, "001 == 001"
+ local_branch $P4, NEWARYI
+ local_branch $P4, PRINTF
+
+ set $S1, "0.500000 == %f"
+ set $N0, 0.5
+ set $S99, "0.500000 == 0.500000"
+ local_branch $P4, NEWARYN
+ local_branch $P4, PRINTF
+
+ set $S1, "0.500 == %5.3f"
+ set $N0, 0.5
+ set $S99, "0.500 == 0.500"
+ local_branch $P4, NEWARYN
+ local_branch $P4, PRINTF
+
+ set $S1, "0.001 == %g"
+ set $N0, 0.001
+ set $S99, "0.001 == 0.001"
+ local_branch $P4, NEWARYN
+ local_branch $P4, PRINTF
+
+ set $S1, "1e+06 == %g"
+ set $N0, 1.0e6
+ set $S99, "1e+06 == 1e+06"
+ local_branch $P4, NEWARYN
+ local_branch $P4, PRINTF
+
+ set $S1, "0.5 == %3.3g"
+ set $N0, 0.5
+ set $S99, "0.5 == 0.5"
+ local_branch $P4, NEWARYN
+ local_branch $P4, PRINTF
+
+ set $S1, "%% == %%"
+ set $I0, 0
+ set $S99, "% == %"
+ local_branch $P4, NEWARYI
+ local_branch $P4, PRINTF
+
+ set $S1, "That's all, %s"
+ set $S0, "folks!"
+ set $S99, "That's all, folks!"
+ local_branch $P4, NEWARYS
+ local_branch $P4, PRINTF
+.end
+
+.sub other_form_of_sprintf_op
+ new $P4, 'ResizableIntegerArray'
+ new $P3, 'String'
+ new $P2, 'String'
+ set $P2, "15 is %b"
+ new $P1, 'ResizablePMCArray'
+ set $P1[0], 15
+ sprintf $P3, $P2, $P1
+ is( $P3, "15 is 1111", 'other form of sprintf op' )
+
+ new $P2, 'String'
+ set $P2, "128 is %o"
+ new $P1, 'ResizablePMCArray'
+ set $P1[0], 128
+ sprintf $P3, $P2, $P1
+ is( $P3, "128 is 200", 'other form of sprintf op' )
+.end
+
+.sub sprintf_left_justify
+ $P0 = new 'ResizablePMCArray'
+ $P1 = new 'Integer'
+ $P1 = 10
+ $P0[0] = $P1
+ $P1 = new 'String'
+ $P1 = "foo"
+ $P0[1] = $P1
+ $P1 = new 'String'
+ $P1 = "bar"
+ $P0[2] = $P1
+ $S0 = sprintf "%-*s - %s", $P0
+ is( $S0, "foo - bar", 'sprintf - left justify' )
+.end
+
+
+.sub correct_precision_for_sprintf_x
+ .include "iglobals.pasm"
+
+ # Create the string via concat
+ .local pmc interp # a handle to our interpreter object.
interp = getinterp
- interp.'hll_map'(RSA, fooRSA)
- .local pmc a
- split a, "a", "afooabara"
- .local string t
- t = typeof a
- say t
- .local int n, i
- n = a
- say n
- i = 0
-loop:
- .local string s
- s = a[i]
- say s
- inc i
- if i != n goto loop
-.end
-CODE
-fooRSA
-5
-
-foo
-b
-r
-
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'join' );
-_main:
- new P0, 'ResizablePMCArray'
- join S0, "--", P0
- print S0
- print "\n"
- push P0, "a"
- join S0, "--", P0
- print S0
- print "\n"
- new P0, 'ResizablePMCArray'
- push P0, "a"
- push P0, "b"
- join S0, "--", P0
- print S0
- print "\n"
- end
-CODE
+ .local pmc config
+ config = interp[.IGLOBALS_CONFIG_HASH]
+ .local int intvalsize
+ intvalsize = config['intvalsize']
+
+ $S0 = ''
+ $I0 = 1
+ $I1 = intvalsize * 2
+ loop:
+ concat $S0, 'f'
+ inc $I0
+ le $I0, $I1, loop
+ padding_loop:
+ concat $S0, ' '
+ inc $I0
+ le $I0, 20, padding_loop
+
+ # Now see what sprintf comes up with
+ $P0 = new 'ResizablePMCArray'
+ $P0[0] = -1
+ $S1 = sprintf "%-20x", $P0
+ is( $S1, $S0, 'Correct precision for %x' )
+.end
+
+.sub test_exchange
+ set $S0, "String #0"
+ set $S1, "String #1"
+ exchange $S0, $S1
+ is( $S0, "String #1", 'exchange' )
+ is( $S1, "String #0", 'exchange' )
+
+ set $S2, "String #2"
+ exchange $S2, $S2
+ is( $S2, "String #2", 'exchange' )
+.end
+
+.sub test_find_encoding
+ skip( 4, "Pending reimplementation of find_encoding" )
+ # find_encoding $I0, "singlebyte"
+ # is( $I0, "0", 'find_encoding' )
+ # find_encoding $I0, "utf8"
+ # is( $I0, "1", 'find_encoding' )
+ # find_encoding $I0, "utf16"
+ # is( $I0, "2", 'find_encoding' )
+ # find_encoding $I0, "utf32"
+ # is( $I0, "3", 'find_encoding' )
+.end
+
+.sub test_string_encoding
+ skip(4, "no more visible encoding" )
+ # set $I0, 0
+ # new $S0, 0, $I0
+ # string_encoding $I1, $S0
+ # eq $I0, $I1, OK1
+ # print "not "
+ # OK1: print "ok 1\n"
+ # set $I0, 1
+ # new $S0, 0, $I0
+ # string_encoding $I1, $S0
+ # eq $I0, $I1, OK2
+ # print "not "
+ # OK2: print "ok 2\n"
+ # set $I0, 2
+ # new $S0, 0, $I0
+ # string_encoding $I1, $S0
+ # eq $I0, $I1, OK3
+ # print "not "
+ # OK3: print "ok 3\n"
+ # set $I0, 3
+ # new $S0, 0, $I0
+ # string_encoding $I1, $S0
+ # eq $I0, $I1, OK4
+ # print "not "
+ # OK4: print "ok 4\n"
+.end
+
+.sub test_assign
+ set $S4, "JAPH"
+ assign $S5, $S4
+ is( $S4, "JAPH", 'assign' )
+ is( $S5, "JAPH", 'assign' )
+.end
+
+.sub assign_and_globber
+ set $S4, "JAPH"
+ assign $S5, $S4
+ assign $S4, "Parrot"
+ is( $S4, "Parrot", 'assign & globber' )
+ is( $S5, "JAPH", 'assign & globber' )
+.end
-a
-a--b
-OUTPUT
+.sub assign_and_globber_2
+ set $S4, "JAPH"
+ set $S5, $S4
+ assign $S4, "Parrot"
+ is( $S4, "Parrot", 'assign & globber 2' )
+ is( $S5, "Parrot", 'assign & globber 2' )
+.end
+
+.sub bands_null_string
+ null $S1
+ set $S2, "abc"
+ bands $S1, $S2
+ null $S3
+ is( $S1, $S3, 'ok1' )
+
+ set $S1, ""
+ bands $S1, $S2
+ nok( $S1, 'ok2' )
+
+ null $S2
+ set $S1, "abc"
+ bands $S1, $S2
+ null $S3
+ is( $S1, $S3, 'ok3' )
+
+ set $S2, ""
+ bands $S1, $S2
+ nok( $S1, 'ok4' )
+.end
+
+.sub bands_2
+ set $S1, "abc"
+ set $S2, "EE"
+ bands $S1, $S2
+ is( $S1, "A@", 'bands 2' )
+ is( $S2, "EE", 'bands 2' )
+.end
+
+.sub bands_3
+ set $S1, "abc"
+ set $S2, "EE"
+ bands $S0, $S1, $S2
+ is( $S0, "A@", 'bands 3' )
+ is( $S1, "abc", 'bands 3' )
+ is( $S2, "EE", 'bands 3' )
+.end
+
+.sub bands_cow
+ set $S1, "foo"
+ substr $S2, $S1, 0, 3
+ bands $S1, "bar"
+ is( $S2, "foo", 'bands COW' )
+.end
+
+.sub bors_null_string
+ null $S1
+ null $S2
+ bors $S1, $S2
+ null $S3
+ is( $S1, $S3, 'bors NULL string' )
+
+ null $S1
+ set $S2, ""
+ bors $S1, $S2
+ null $S3
+ is( $S1, $S3, 'bors NULL string' )
+
+ bors $S2, $S1
+ is( $S2, $S3, 'bors NULL string' )
+
+ null $S1
+ set $S2, "def"
+ bors $S1, $S2
+ is( $S1, "def", 'bors NULL string' )
+
+ null $S2
+ bors $S1, $S2
+ is( $S1, "def", 'bors NULL string' )
+
+ null $S1
+ null $S2
+ bors $S3, $S1, $S2
+ null $S4
+ is( $S3, $S4, 'bors NULL string' )
+
+ set $S1, ""
+ bors $S3, $S1, $S2
+ is( $S3, $S4, 'bors NULL string' )
+
+ bors $S3, $S2, $S1
+ is( $S3, $S4, 'bors NULL string' )
+
+ set $S1, "def"
+ bors $S3, $S1, $S2
+ is( $S3, "def", 'bors NULL string' )
+
+ bors $S3, $S2, $S1
+ is( $S3, "def", 'bors NULL string' )
+.end
+
+.sub bors_2
+ set $S1, "abc"
+ set $S2, "EE"
+ bors $S1, $S2
+ is( $S1, "egc", 'bors 2' )
+ is( $S2, "EE", 'bors 2' )
+.end
+
+.sub bors_3
+ set $S1, "abc"
+ set $S2, "EE"
+ bors $S0, $S1, $S2
+ is( $S0, "egc", 'bors 3' )
+ is( $S1, "abc", 'bors 3' )
+ is( $S2, "EE", 'bors 3' )
+.end
+
+.sub bors_cow
+ set $S1, "foo"
+ substr $S2, $S1, 0, 3
+ bors $S1, "bar"
+ is( $S2, "foo", 'bors COW' )
+.end
+
+.sub bxors_null_string
+ null $S1
+ null $S2
+ bxors $S1, $S2
+ null $S3
+ is( $S1, $S3, 'bxors NULL string' )
+
+ null $S1
+ set $S2, ""
+ bxors $S1, $S2
+ null $S3
+ is( $S1, $S3, 'bxors NULL string' )
+
+ bxors $S2, $S1
+ is( $S2, $S3, 'bxors NULL string' )
+
+ null $S1
+ set $S2, "abc"
+ bxors $S1, $S2
+ is( $S1, "abc", 'bxors NULL string' )
+
+ null $S2
+ bxors $S1, $S2
+ is( $S1, "abc", 'bxors NULL string' )
+
+ null $S1
+ null $S2
+ bxors $S3, $S1, $S2
+ null $S4
+ is( $S3, $S4, 'bxors NULL string' )
+
+ set $S1, ""
+ bxors $S3, $S1, $S2
+ is( $S3, $S4, 'bxors NULL string' )
+
+ bxors $S3, $S2, $S1
+ is( $S3, $S4, 'bxors NULL string' )
+
+ set $S1, "abc"
+ bxors $S3, $S1, $S2
+ is( $S3, "abc", 'bxors NULL string' )
+
+ bxors $S3, $S2, $S1
+ is( $S3, "abc", 'bxors NULL string' )
+.end
+
+.sub bxors_2
+ set $S1, "a2c"
+ set $S2, "Dw"
+ bxors $S1, $S2
+ is( $S1, "%Ec", 'bxors 2' )
+ is( $S2, "Dw", 'bxors 2' )
+
+ set $S1, "abc"
+ set $S2, " X"
+ bxors $S1, $S2
+ is( $S1, "ABCX", 'bxors 2' )
+ is( $S2, " X", 'bxors 2' )
+.end
+
+.sub bxors_3
+ set $S1, "a2c"
+ set $S2, "Dw"
+ bxors $S0, $S1, $S2
+ is( $S0, "%Ec", 'bxors 3' )
+ is( $S1, "a2c", 'bxors 3' )
+ is( $S2, "Dw", 'bxors 3' )
+
+ set $S1, "abc"
+ set $S2, " Y"
+ bxors $S0, $S1, $S2
+ is( $S0, "ABCY", 'bxors 3' )
+ is( $S1, "abc", 'bxors 3' )
+ is( $S2, " Y", 'bxors 3' )
+.end
+
+.sub bxors_cow
+ set $S1, "foo"
+ substr $S2, $S1, 0, 3
+ bxors $S1, "bar"
+ is( $S2, "foo", 'bxors COW' )
+.end
+
+.sub bnots_null_string
+ null $S1
+ null $S2
+ bnots $S1, $S2
+ null $S3
+ is( $S1, $S3, 'bnots NULL string' )
+
+ null $S1
+ set $S2, ""
+ bnots $S1, $S2
+ null $S3
+ is( $S1, $S3, 'bnots NULL string' )
+
+ bnots $S2, $S1
+ is( $S2, $S3, 'bnots NULL string' )
+.end
+
+# This was the previous test used for t/native_pbc/string.t
+.sub bnots_2
+ skip( 4, "No unicode yet" )
+ # getstdout $P0
+ # push $P0, "utf8"
+ # set $S1, "a2c"
+ # bnots $S2, $S1
+ # is( $S1, "a2c", 'bnots 2' )
+ # is( $S2, "\xC2\x9E\xC3\x8D\xC2\x9C", 'bnots 2' )
+ #
+ # bnots $S1, $S1
+ # is( $S1, "\xC2\x9E\xC3\x8D\xC2\x9C", 'bnots 2' )
+ #
+ # bnots $S1, $S1
+ # is( $S1, "a2c", 'bnots 2' )
+.end
+
+.sub bnots_cow
+ set $S1, "foo"
+ substr $S2, $S1, 0, 3
+ bnots $S1, $S1
+ is( $S2, "foo", 'bnots COW' )
+.end
+
+.sub transcode_to_utf8
+ skip( 2, "no more transcode" )
+ # set $S1, "ASCII is the same as UTF8\n"
+ # find_encoding $I1, "utf8"
+ # transcode $S2, $S1, $I1
+ # is( $S1, "ASCII is the same as UTF8", 'transcode to utf8' )
+ # is( $S2, "ASCII is the same as UTF8", 'transcode to utf8' )
+.end
-pir_output_is( <<'CODE', <<'OUTPUT', 'join: get_string returns a null string' );
+.sub string_chartype
+ skip( 1, "no more chartype" )
-.sub _main
- newclass $P0, "Foo"
+ # set $S0, "Test String"
+ # find_chartype $I0, "usascii"
+ # set_chartype $S0, $I0
+ # string_chartype $I1, $S0
+ # is( $I0, $I1, 'string_chartype' )
+.end
+
+.sub split_on_empty_string
+ split $P1, "", ""
+ set $I1, $P1
+ is( $I1, "0", 'split on empty string' )
+
+ split $P0, "", "ab"
+ set $I0, $P0
+ is( $I0, "2", 'split on empty string' )
+
+ set $S0, $P0[0]
+ is( $S0, "a", 'split on empty string' )
+
+ set $S0, $P0[1]
+ is( $S0, "b", 'split on empty string' )
+.end
+.sub split_on_non_empty_string
+ split $P0, "a", "afooabara"
+ set $I0, $P0
+ is( $I0, "5", 'split on non-empty string' )
+
+ set $S0, $P0[0]
+ is( $S0, "", 'split on non-empty string' )
+ set $S0, $P0[1]
+ is( $S0, "foo", 'split on non-empty string' )
+ set $S0, $P0[2]
+ is( $S0, "b", 'split on non-empty string' )
+ set $S0, $P0[3]
+ is( $S0, "r", 'split on non-empty string' )
+ set $S0, $P0[4]
+ is( $S0, "", 'split on non-empty string' )
+.end
+
+.sub test_join
new $P0, 'ResizablePMCArray'
+ join $S0, "--", $P0
+ is( $S0, "", 'join' )
- $P1 = new "Foo"
+ push $P0, "a"
+ join $S0, "--", $P0
+ is( $S0, "a", 'join' )
+
+ new $P0, 'ResizablePMCArray'
+ push $P0, "a"
+ push $P0, "b"
+ join $S0, "--", $P0
+ is( $S0, "a--b", 'join' )
+.end
+# join: get_string returns a null string --------
+.namespace ["Foo5"]
+ .sub get_string :vtable :method
+ .local string ret
+ null ret
+ .begin_return
+ .set_return ret
+ .end_return
+ .end
+.namespace [] # revert to root for next test
+.sub join_get_string_returns_a_null_string
+ newclass $P0, "Foo5"
+ new $P0, 'ResizablePMCArray'
+ $P1 = new "Foo5"
push $P0, $P1
-
- print "a"
join $S0, "", $P0
- print "b"
- print $S0
- print "c\n"
- end
+ is( $S0, "", 'join: get_string returns a null string' )
.end
-.namespace ["Foo"]
+.sub eq_addr_or_ne_addr
+ set $S0, "Test"
+ set $S1, $S0
+
+ set $I99, 1
+ eq_addr $S1, $S0, OK1
+ set $I99, 0
+ OK1:
+ ok($I99, 'eq_addr/ne_addr')
+
+ set $S1, "Test"
+ set $I99, 0
+ eq_addr $S1, $S0, BAD2
+ set $I99, 1
+ BAD2:
+ ok($I99, 'eq_addr/ne_addr')
+
+ set $I99, 1
+ ne_addr $S1, $S0, OK3
+ set $I99, 0
+ OK3:
+ ok($I99, 'eq_addr/ne_addr')
+
+ set $S0, $S1
+ set $I99, 0
+ ne_addr $S1, $S0, BAD4
+ set $I99, 1
+ BAD4:
+ ok($I99, 'eq_addr/ne_addr')
+.end
-.sub get_string :vtable :method
- .local string ret
+.sub test_if_null_s_ic
+ set $S0, "foo"
+ $I99 = 0
+ if_null $S0, ERROR
+ $I99 = 1
+ ERROR:
+ ok($I99, 'if_null s_ic' )
+
+ null $S0
+ $I99 = 1
+ if_null $S0, OK
+ $I99 = 0
+ OK:
+ ok($I99, 'if_null s_ic' )
+.end
- null ret
- .begin_return
- .set_return ret
- .end_return
-.end
-CODE
-abc
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'eq_addr/ne_addr' );
- set S0, "Test"
- set S1, S0
- eq_addr S1, S0, OK1
- print "not "
-OK1: print "ok 1\n"
- set S1, "Test"
- eq_addr S1, S0, BAD2
- branch OK2
-BAD2: print "not "
-OK2: print "ok 2\n"
-
- ne_addr S1, S0, OK3
- print "not "
-OK3: print "ok 3\n"
- set S0, S1
- ne_addr S1, S0, BAD4
- branch OK4
-BAD4: print "not "
-OK4: print "ok 4\n"
- end
-CODE
-ok 1
-ok 2
-ok 3
-ok 4
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'if_null_s_ic' );
- set S0, "foo"
- if_null S0, ERROR
- print "ok 1\n"
- null S0
- if_null S0, OK
-ERROR: print "error\n"
- end
-OK: print "ok 2\n"
- end
-CODE
-ok 1
-ok 2
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'upcase' );
- set S0, "abCD012yz\n"
- upcase S1, S0
- print S1
- upcase S0
- print S0
- end
-CODE
-ABCD012YZ
-ABCD012YZ
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'downcase' );
- set S0, "ABcd012YZ\n"
- downcase S1, S0
- print S1
- downcase S0
- print S0
- end
-CODE
-abcd012yz
-abcd012yz
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', 'titlecase' );
- set S0, "aBcd012YZ\n"
- titlecase S1, S0
- print S1
- titlecase S0
- print S0
- end
-CODE
-Abcd012yz
-Abcd012yz
-OUTPUT
-
-pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string register, I' );
- set S0,"a"
- set I1, 0
- ord I0,S0,I1
- print I0
- end
-CODE
+.sub test_upcase
+ set $S0, "abCD012yz"
+ upcase $S1, $S0
+ is( $S1, "ABCD012YZ", 'upcase' )
+
+ upcase $S0
+ is( $S0, "ABCD012YZ", 'upcase' )
+.end
-pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string, I' );
- set I1, 1
- ord I0,"ab",I1
- print I0
- end
-CODE
+.sub test_downcase
+ set $S0, "ABcd012YZ"
+ downcase $S1, $S0
+ is( $S1, "abcd012yz", 'test_downcase' )
+
+ downcase $S0
+ is( $S0, "abcd012yz", 'test_downcase' )
+.end
-pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string register, I' );
- set I1, 1
- set S0,"ab"
- ord I0,S0,I1
- print I0
- end
-CODE
+.sub test_titlecase
+ set $S0, "aBcd012YZ"
+ titlecase $S1, $S0
+ is( $S1, "Abcd012yz", 'test_titlecase' )
+
+ titlecase $S0
+ is( $S0, "Abcd012yz", 'test_titlecase' )
+.end
-pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, multi-character string, I' );
- set I1, 2
- ord I0,"ab",I1
- print I0
- end
-CODE
-/^Cannot get character past end of string/
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, multi-character string, I' );
- set I1, 2
- set S0,"ab"
- ord I0,S0,I1
- print I0
- end
-CODE
-/^Cannot get character past end of string/
-OUTPUT
-
-pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string, from end, I' );
- set I1, -1
- ord I0,"a",I1
- print I0
- end
-CODE
+.sub three_param_ord_one_character_string_register_i
+ set $S0,"a"
+ set $I1, 0
+ ord $I0,$S0,$I1
+ is( $I0, "97", '3-param ord, one-character string register, I' )
+.end
-pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string register, from end, I' );
- set I1, -1
- set S0,"a"
- ord I0,S0,I1
- print I0
- end
-CODE
+.sub three_param_ord_multi_character_string_i
+ set $I1, 1
+ ord $I0,"ab",$I1
+ is( $I0, "98", '3-param ord, multi-character string, I' )
+.end
-pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string, from end, I' );
- set I1, -1
- ord I0,"ab",I1
- print I0
- end
-CODE
+.sub three_param_ord_multi_character_string_register_i
+ set $I1, 1
+ set $S0,"ab"
+ ord $I0,$S0,$I1
+ is( $I0, "98", '3-param ord, multi-character string register, I' )
+.end
-pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string register, from end, I' );
- set I1, -1
- set S0,"ab"
- ord I0,S0,I1
- print I0
- end
-CODE
+.sub exception_three_param_ord_multi_character_string_i
+ push_eh handler
+ set $I1, 2
+ ord $I0,"ab",$I1
+ ok( 0, 'no exception: 3-param ord, multi-character string, I' )
+ handler:
+ .exception_is( 'Cannot get character past end of string' )
+.end
+
+.sub exception_three_param_ord_multi_character_string_i
+ push_eh handler
+ set $I1, 2
+ set $S0,"ab"
+ ord $I0,$S0,$I1
+ ok( 0, 'no exception: 3-param ord, multi-character string, I' )
+ handler:
+ .exception_is( 'Cannot get character past end of string' )
+.end
+
+.sub three_param_ord_one_character_string_from_end_i
+ set $I1, -1
+ ord $I0,"a",$I1
+ is( $I0, "97", '3-param ord, one-character string, from end, I' )
+.end
+
+.sub three_param_ord_one_character_string_register_from_end_i
+ set $I1, -1
+ set $S0,"a"
+ ord $I0,$S0,$I1
+ is( $I0, "97", '3-param ord, one-character string register, from end, I' )
+.end
+
+.sub three_param_ord_multi_character_string_from_end_i
+ set $I1, -1
+ ord $I0,"ab",$I1
+ is( $I0, "98", '3-param ord, multi-character string, from end, I' )
+.end
+
+.sub three_param_ord_multi_character_string_register_from_end_i
+ set $I1, -1
+ set $S0,"ab"
+ ord $I0,$S0,$I1
+ is( $I0, "98", '3-param ord, multi-character string register, from end, I' )
+.end
+
+.sub exception_three_param_ord_multi_character_string_register_from_end_oob_i
+ push_eh handler
+ set $I1, -3
+ set $S0,"ab"
+ ord $I0,$S0,$I1
+ ok( 0, 'no exception: 3-param ord, multi-character string register, from end, OOB, I' )
+ handler:
+ .exception_is( 'Cannot get character before beginning of string' )
+.end
-pasm_error_output_like(
- <<'CODE', <<'OUTPUT', '3-param ord, multi-character string register, from end, OOB, I' );
- set I1, -3
- set S0,"ab"
- ord I0,S0,I1
- print I0
- end
-CODE
-/^Cannot get character before beginning of string/
-OUTPUT
-
-pir_output_is( <<'CODE', <<'OUT', 'more string_to_int' );
- .sub 'main' :main
- print_as_integer('-4')
- print_as_integer('X-4')
- print_as_integer('--4')
- print_as_integer('+')
- print_as_integer('++')
- print_as_integer('+2')
- print_as_integer(' +3')
- print_as_integer('++4')
- print_as_integer('+ 5')
- print_as_integer('-')
- print_as_integer('--56')
- print_as_integer(' -+67')
- print_as_integer('+-78')
- print_as_integer(' -089xyz')
- print_as_integer('- 89')
- .end
-
- .sub 'print_as_integer'
- .param string s
- $I0 = s
- print $I0
- print "\n"
- .end
-CODE
--4
-0
-0
-0
-0
-2
-3
-0
-0
-0
-0
-0
-0
--89
-0
-OUT
+# Utility method for more_string_to_int
+.sub 'print_as_integer'
+ .param string s
+ .param string answer
+ $I0 = s
+ concat $S99, 'string to int: ', s
+ is( $I0, answer, $S99 )
+.end
+
+.sub more_string_to_int
+ print_as_integer('-4', "-4")
+ print_as_integer('X-4',"0")
+ print_as_integer('--4',"0")
+ print_as_integer('+',"0")
+ print_as_integer('++',"0")
+ print_as_integer('+2',"2")
+ print_as_integer(' +3',"3")
+ print_as_integer('++4',"0")
+ print_as_integer('+ 5',"0")
+ print_as_integer('-',"0")
+ print_as_integer('--56',"0")
+ print_as_integer(' -+67',"0")
+ print_as_integer('+-78',"0")
+ print_as_integer(' -089xyz',"-89")
+ print_as_integer('- 89',"0")
+.end
-pir_output_is( <<'CODE', <<'OUT', 'constant string and modify-in-situ op (RT #60030)' );
-.sub doit
+# Utility sub for constant_string_and_modify_in_situ_op_rt_bug_60030
+.sub doit_sub_for_but_60030
.param string s
$I0 = index s, '::'
- say s
+ is( s, "Foo::Bar", 'bug 60030' )
substr s, $I0, 2, "/"
- say s
+ is( s, "Foo/Bar", 'bug 60030' )
collect
- say s
+ is( s, "Foo/Bar", 'bug 60030' )
.end
-
-.sub main :main
- doit('Foo::Bar')
-
- # repeat to prove that the constant 'Foo::Bar' remains unchanged
- doit('Foo::Bar')
+.sub constant_string_and_modify_in_situ_op_rt_bug_60030
+
+ doit_sub_for_but_60030('Foo::Bar')
+ # repeat to prove that the constant 'Foo4::Bar4' remains unchanged
+ doit_sub_for_but_60030('Foo::Bar')
.end
-CODE
-Foo::Bar
-Foo/Bar
-Foo/Bar
-Foo::Bar
-Foo/Bar
-Foo/Bar
-OUT
-pir_output_is( <<'CODE', <<'OUT', 'Corner cases of numification' );
-.sub main :main
- say 2147483647.0
- say -2147483648.0
+.sub corner_cases_of_numification
+ is( 2147483647.0, "2147483647", 'corner cases of numification' )
+ is( -2147483648.0, "-2147483648", 'corner cases of numification' )
.end
-CODE
-2147483647
--2147483648
-OUT
-pir_output_is( <<'CODE', <<'OUT', 'Non canonical nan and inf' );
-.sub main :main
+
+.sub non_canonical_nan_and_inf
$N0 = 'nan'
- say $N0
+ is( $N0, "NaN", 'Non canonical nan and inf' )
+
$N0 = 'iNf'
- say $N0
+ is( $N0, "Inf", 'Non canonical nan and inf' )
+
$N0 = 'INFINITY'
- say $N0
+ is( $N0, "Inf", 'Non canonical nan and inf' )
+
$N0 = '-INF'
- say $N0
+ is( $N0, "-Inf", 'Non canonical nan and inf' )
+
$N0 = '-Infinity'
- say $N0
+ is( $N0, "-Inf", 'Non canonical nan and inf' )
.end
-CODE
-NaN
-Inf
-Inf
--Inf
--Inf
-OUT
+.HLL 'foohll'
+.sub split_hll_mapped
+ .include 'test_more.pir'
+ .local pmc RSA, fooRSA
+ RSA = get_class ['ResizableStringArray']
+ fooRSA = subclass ['ResizableStringArray'], 'fooRSA'
+
+ .local pmc interp
+ interp = getinterp
+ interp.'hll_map'(RSA, fooRSA)
+
+ .local pmc a
+ split a, "a", "afooabara"
+
+ .local string t
+ t = typeof a
+ is( t, 'fooRSA', 'split - hll mapped' )
+
+ .local int n, i
+ n = a
+ is( n, '5', 'split - hll mapped' )
+
+ .local string s
+ s = a[0]
+ is( s, '', 'split - hll mapped' )
+ s = a[1]
+ is( s, 'foo', 'split - hll mapped' )
+ s = a[2]
+ is( s, 'b', 'split - hll mapped' )
+ s = a[3]
+ is( s, 'r', 'split - hll mapped' )
+ s = a[4]
+ is( s, '', 'split - hll mapped' )
+.end
# Local Variables:
-# mode: cperl
+# mode: pir
# cperl-indent-level: 4
# fill-column: 100
# End:
-# vim: expandtab shiftwidth=4:
+# vim: expandtab shiftwidth=4 ft=pir :
Added: trunk/t/op/string_cmp.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/t/op/string_cmp.t Sat Oct 17 20:46:53 2009 (r41906)
@@ -0,0 +1,1172 @@
+#! parrot
+# Copyright (C) 2001-2009, Parrot Foundation.
+# $Id$
+
+=head1 NAME
+
+t/op/string.t - Parrot Strings
+
+=head1 SYNOPSIS
+
+ % prove t/op/string.t
+
+=head1 DESCRIPTION
+
+Tests Parrot string registers and operations.
+
+=cut
+
+.sub main :main
+ .include 'test_more.pir'
+
+ plan(24)
+
+ test_eq_s_s_ic()
+ test_eq_sc_s_ic()
+ test_eq_s_sc_ic()
+ test_eq_sc_sc_ic()
+ test_ne_s_s_ic()
+ test_ne_sc_s_ic()
+ test_ne_s_sc_ic()
+ test_ne_sc_sc_ic()
+ test_lt_s_s_ic()
+ test_lt_sc_s_ic()
+ test_lt_s_sc_ic()
+ test_lt_sc_sc_ic()
+ test_le_s_s_ic()
+ test_le_sc_s_ic()
+ test_le_s_sc_ic()
+ test_le_sc_sc_ic()
+ test_gt_s_s_ic()
+ test_gt_sc_s_ic()
+ test_gt_s_sc_ic()
+ test_gt_sc_sc_ic()
+ test_ge_s_s_ic()
+ test_ge_sc_s_ic()
+ test_ge_s_sc_ic()
+ test_ge_sc_sc_ic()
+
+.end
+
+.sub test_eq_s_s_ic
+ set $S0, "hello"
+ set $S1, "hello"
+ eq $S0, $S1, OK1
+ branch ERROR
+ OK1:
+ set $S0, "hello"
+ set $S1, "world"
+ eq $S0, $S1, ERROR
+ OK2:
+ set $S0, "world"
+ set $S1, "hello"
+ eq $S0, $S1, ERROR
+ OK3:
+ set $S0, "hello"
+ set $S1, "hellooo"
+ eq $S0, $S1, ERROR
+ OK4:
+ set $S0, "hellooo"
+ set $S1, "hello"
+ eq $S0, $S1, ERROR
+ OK5:
+ set $S0, "hello"
+ set $S1, "hella"
+ eq $S0, $S1, ERROR
+ OK6:
+ set $S0, "hella"
+ set $S1, "hello"
+ eq $S0, $S1, ERROR
+ OK7:
+ set $S0, "hella"
+ set $S1, "hellooo"
+ eq $S0, $S1, ERROR
+ OK8:
+ set $S0, "hellooo"
+ set $S1, "hella"
+ eq $S0, $S1, ERROR
+ OK9:
+ set $S0, "hElLo"
+ set $S1, "HeLlO"
+ eq $S0, $S1, ERROR
+ OK10:
+ set $S0, "hElLo"
+ set $S1, "hElLo"
+ eq $S0, $S1, OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'eq_s_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'eq_s_s_ic' )
+ END:
+.end
+
+.sub test_eq_sc_s_ic
+ set $S0, "hello"
+ eq "hello", $S0, OK1
+ branch ERROR
+ OK1:
+ set $S0, "world"
+ eq "hello", $S0, ERROR
+ OK2:
+ set $S0, "hello"
+ eq "world", $S0, ERROR
+ OK3:
+ set $S0, "hellooo"
+ eq "hello", $S0, ERROR
+ OK4:
+ set $S0, "hello"
+ eq "hellooo", $S0, ERROR
+ OK5:
+ set $S0, "hella"
+ eq "hello", $S0, ERROR
+ OK6:
+ set $S0, "hello"
+ eq "hella", $S0, ERROR
+ OK7:
+ set $S0, "hellooo"
+ eq "hella", $S0, ERROR
+ OK8:
+ set $S0, "hella"
+ eq "hellooo", $S0, ERROR
+ OK9:
+ set $S0, "HeLlO"
+ eq "hElLo", $S0, ERROR
+ OK10:
+ set $S0, "hElLo"
+ eq "hElLo", $S0, OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'eq_sc_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'eq_sc_s_ic' )
+ END:
+.end
+
+.sub test_eq_s_sc_ic
+ set $S0, "hello"
+ eq $S0, "hello", OK1
+ branch ERROR
+ OK1:
+ set $S0, "hello"
+ eq $S0, "world", ERROR
+ OK2:
+ set $S0, "world"
+ eq $S0, "hello", ERROR
+ OK3:
+ set $S0, "hello"
+ eq $S0, "hellooo", ERROR
+ OK4:
+ set $S0, "hellooo"
+ eq $S0, "hello", ERROR
+ OK5:
+ set $S0, "hello"
+ eq $S0, "hella", ERROR
+ OK6:
+ set $S0, "hella"
+ eq $S0, "hello", ERROR
+ OK7:
+ set $S0, "hella"
+ eq $S0, "hellooo", ERROR
+ OK8:
+ set $S0, "hellooo"
+ eq $S0, "hella", ERROR
+ OK9:
+ set $S0, "hElLo"
+ eq $S0, "HeLlO", ERROR
+ OK10:
+ set $S0, "hElLo"
+ eq $S0, "hElLo", OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'eq_s_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'eq_s_sc_ic' )
+ END:
+.end
+
+.sub test_eq_sc_sc_ic
+ eq "hello", "hello", OK1
+ branch ERROR
+ OK1:
+ eq "hello", "world", ERROR
+ OK2:
+ eq "world", "hello", ERROR
+ OK3:
+ eq "hello", "hellooo", ERROR
+ OK4:
+ eq "hellooo", "hello", ERROR
+ OK5:
+ eq "hello", "hella", ERROR
+ OK6:
+ eq "hella", "hello", ERROR
+ OK7:
+ eq "hella", "hellooo", ERROR
+ OK8:
+ eq "hellooo", "hella", ERROR
+ OK9:
+ eq "hElLo", "HeLlO", ERROR
+ OK10:
+ eq "hElLo", "hElLo", OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'eq_sc_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'eq_sc_sc_ic' )
+ END:
+.end
+
+.sub test_ne_s_s_ic
+ set $S0, "hello"
+ set $S1, "hello"
+ ne $S0, $S1, ERROR
+ OK1:
+ set $S0, "hello"
+ set $S1, "world"
+ ne $S0, $S1, OK2
+ branch ERROR
+ OK2:
+ set $S0, "world"
+ set $S1, "hello"
+ ne $S0, $S1, OK3
+ branch ERROR
+ OK3:
+ set $S0, "hello"
+ set $S1, "hellooo"
+ ne $S0, $S1, OK4
+ branch ERROR
+ OK4:
+ set $S0, "hellooo"
+ set $S1, "hello"
+ ne $S0, $S1, OK5
+ branch ERROR
+ OK5:
+ set $S0, "hello"
+ set $S1, "hella"
+ ne $S0, $S1, OK6
+ branch ERROR
+ OK6:
+ set $S0, "hella"
+ set $S1, "hello"
+ ne $S0, $S1, OK7
+ branch ERROR
+ OK7:
+ set $S0, "hella"
+ set $S1, "hellooo"
+ ne $S0, $S1, OK8
+ branch ERROR
+ OK8:
+ set $S0, "hellooo"
+ set $S1, "hella"
+ ne $S0, $S1, OK9
+ branch ERROR
+ OK9:
+ set $S0, "hElLo"
+ set $S1, "HeLlO"
+ ne $S0, $S1, OK10
+ branch ERROR
+ OK10:
+ set $S0, "hElLo"
+ set $S1, "hElLo"
+ ne $S0, $S1, ERROR
+ OK11:
+ ok( 1, 'ne_s_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'ne_s_s_ic' )
+ END:
+.end
+
+.sub test_ne_sc_s_ic
+ set $S0, "hello"
+ ne "hello", $S0, ERROR
+ OK1:
+ set $S0, "world"
+ ne "hello", $S0, OK2
+ branch ERROR
+ OK2:
+ set $S0, "hello"
+ ne "world", $S0, OK3
+ branch ERROR
+ OK3:
+ set $S0, "hellooo"
+ ne "hello", $S0, OK4
+ branch ERROR
+ OK4:
+ set $S0, "hello"
+ ne "hellooo", $S0, OK5
+ branch ERROR
+ OK5:
+ set $S0, "hella"
+ ne "hello", $S0, OK6
+ branch ERROR
+ OK6:
+ set $S0, "hello"
+ ne "hella", $S0, OK7
+ branch ERROR
+ OK7:
+ set $S0, "hellooo"
+ ne "hella", $S0, OK8
+ branch ERROR
+ OK8:
+ set $S0, "hella"
+ ne "hellooo", $S0, OK9
+ branch ERROR
+ OK9:
+ set $S0, "HeLlO"
+ ne "hElLo", $S0, OK10
+ branch ERROR
+ OK10:
+ set $S0, "hElLo"
+ ne "hElLo", $S0, ERROR
+ OK11:
+ ok( 1, 'ne_sc_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'ne_sc_s_ic' )
+ END:
+.end
+
+.sub test_ne_s_sc_ic
+ set $S0, "hello"
+ ne $S0, "hello", ERROR
+ OK1:
+ set $S0, "hello"
+ ne $S0, "world", OK2
+ branch ERROR
+ OK2:
+ set $S0, "world"
+ ne $S0, "hello", OK3
+ branch ERROR
+ OK3:
+ set $S0, "hello"
+ ne $S0, "hellooo", OK4
+ branch ERROR
+ OK4:
+ set $S0, "hellooo"
+ ne $S0, "hello", OK5
+ branch ERROR
+ OK5:
+ set $S0, "hello"
+ ne $S0, "hella", OK6
+ branch ERROR
+ OK6:
+ set $S0, "hella"
+ ne $S0, "hello", OK7
+ branch ERROR
+ OK7:
+ set $S0, "hella"
+ ne $S0, "hellooo", OK8
+ branch ERROR
+ OK8:
+ set $S0, "hellooo"
+ ne $S0, "hella", OK9
+ branch ERROR
+ OK9:
+ set $S0, "hElLo"
+ ne $S0, "HeLlO", OK10
+ branch ERROR
+ OK10:
+ set $S0, "hElLo"
+ ne $S0, "hElLo", ERROR
+ OK11:
+ ok( 1, 'ne_s_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'ne_s_sc_ic' )
+ END:
+.end
+
+.sub test_ne_sc_sc_ic
+ ne "hello", "hello", ERROR
+ OK1:
+ ne "hello", "world", OK2
+ branch ERROR
+ OK2:
+ ne "world", "hello", OK3
+ branch ERROR
+ OK3:
+ ne "hello", "hellooo", OK4
+ branch ERROR
+ OK4:
+ ne "hellooo", "hello", OK5
+ branch ERROR
+ OK5:
+ ne "hello", "hella", OK6
+ branch ERROR
+ OK6:
+ ne "hella", "hello", OK7
+ branch ERROR
+ OK7:
+ ne "hella", "hellooo", OK8
+ branch ERROR
+ OK8:
+ ne "hellooo", "hella", OK9
+ branch ERROR
+ OK9:
+ ne "hElLo", "HeLlO", OK10
+ branch ERROR
+ OK10:
+ ne "hElLo", "hElLo", ERROR
+ OK11:
+ ok( 1, 'ne_sc_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'ne_sc_sc_ic' )
+ END:
+.end
+
+.sub test_lt_s_s_ic
+ set $S0, "hello"
+ set $S1, "hello"
+ lt $S0, $S1, ERROR
+ OK1:
+ set $S0, "hello"
+ set $S1, "world"
+ lt $S0, $S1, OK2
+ branch ERROR
+ OK2:
+ set $S0, "world"
+ set $S1, "hello"
+ lt $S0, $S1, ERROR
+ OK3:
+ set $S0, "hello"
+ set $S1, "hellooo"
+ lt $S0, $S1, OK4
+ branch ERROR
+ OK4:
+ set $S0, "hellooo"
+ set $S1, "hello"
+ lt $S0, $S1, ERROR
+ OK5:
+ set $S0, "hello"
+ set $S1, "hella"
+ lt $S0, $S1, ERROR
+ OK6:
+ set $S0, "hella"
+ set $S1, "hello"
+ lt $S0, $S1, OK7
+ branch ERROR
+ OK7:
+ set $S0, "hella"
+ set $S1, "hellooo"
+ lt $S0, $S1, OK8
+ branch ERROR
+ OK8:
+ set $S0, "hellooo"
+ set $S1, "hella"
+ lt $S0, $S1, ERROR
+ OK9:
+ set $S0, "hElLo"
+ set $S1, "HeLlO"
+ lt $S0, $S1, ERROR
+ OK10:
+ set $S0, "hElLo"
+ set $S1, "hElLo"
+ lt $S0, $S1, ERROR
+ OK11:
+ ok( 1, 'lt_s_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'lt_s_s_ic' )
+ END:
+.end
+
+.sub test_lt_sc_s_ic
+ set $S0, "hello"
+ lt "hello", $S0, ERROR
+ OK1:
+ set $S0, "world"
+ lt "hello", $S0, OK2
+ branch ERROR
+ OK2:
+ set $S0, "hello"
+ lt "world", $S0, ERROR
+ OK3:
+ set $S0, "hellooo"
+ lt "hello", $S0, OK4
+ branch ERROR
+ OK4:
+ set $S0, "hello"
+ lt "hellooo", $S0, ERROR
+ OK5:
+ set $S0, "hella"
+ lt "hello", $S0, ERROR
+ OK6:
+ set $S0, "hello"
+ lt "hella", $S0, OK7
+ branch ERROR
+ OK7:
+ set $S0, "hellooo"
+ lt "hella", $S0, OK8
+ branch ERROR
+ OK8:
+ set $S0, "hella"
+ lt "hellooo", $S0, ERROR
+ OK9:
+ set $S0, "HeLlO"
+ lt "hElLo", $S0, ERROR
+ OK10:
+ set $S0, "hElLo"
+ lt "hElLo", $S0, ERROR
+ OK11:
+ ok( 1, 'lt_sc_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'lt_sc_s_ic' )
+ END:
+.end
+
+.sub test_lt_s_sc_ic
+ set $S0, "hello"
+ lt $S0, "hello", ERROR
+ OK1:
+ set $S0, "hello"
+ lt $S0, "world", OK2
+ branch ERROR
+ OK2:
+ set $S0, "world"
+ lt $S0, "hello", ERROR
+ OK3:
+ set $S0, "hello"
+ lt $S0, "hellooo", OK4
+ branch ERROR
+ OK4:
+ set $S0, "hellooo"
+ lt $S0, "hello", ERROR
+ OK5:
+ set $S0, "hello"
+ lt $S0, "hella", ERROR
+ OK6:
+ set $S0, "hella"
+ lt $S0, "hello", OK7
+ branch ERROR
+ OK7:
+ set $S0, "hella"
+ lt $S0, "hellooo", OK8
+ branch ERROR
+ OK8:
+ set $S0, "hellooo"
+ lt $S0, "hella", ERROR
+ OK9:
+ set $S0, "hElLo"
+ lt $S0, "HeLlO", ERROR
+ OK10:
+ set $S0, "hElLo"
+ lt $S0, "hElLo", ERROR
+ OK11:
+ ok( 1, 'lt_s_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'lt_s_sc_ic' )
+ END:
+.end
+
+.sub test_lt_sc_sc_ic
+ lt "hello", "hello", ERROR
+ OK1:
+ lt "hello", "world", OK2
+ branch ERROR
+ OK2:
+ lt "world", "hello", ERROR
+ OK3:
+ lt "hello", "hellooo", OK4
+ branch ERROR
+ OK4:
+ lt "hellooo", "hello", ERROR
+ OK5:
+ lt "hello", "hella", ERROR
+ OK6:
+ lt "hella", "hello", OK7
+ branch ERROR
+ OK7:
+ lt "hella", "hellooo", OK8
+ branch ERROR
+ OK8:
+ lt "hellooo", "hella", ERROR
+ OK9:
+ lt "hElLo", "HeLlO", ERROR
+ OK10:
+ lt "hElLo", "hElLo", ERROR
+ OK11:
+ ok( 1, 'lt_sc_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'lt_sc_sc_ic' )
+ END:
+.end
+
+.sub test_le_s_s_ic
+ set $S0, "hello"
+ set $S1, "hello"
+ le $S0, $S1, OK1
+ branch ERROR
+ OK1:
+ set $S0, "hello"
+ set $S1, "world"
+ le $S0, $S1, OK2
+ branch ERROR
+ OK2:
+ set $S0, "world"
+ set $S1, "hello"
+ le $S0, $S1, ERROR
+ OK3:
+ set $S0, "hello"
+ set $S1, "hellooo"
+ le $S0, $S1, OK4
+ branch ERROR
+ OK4:
+ set $S0, "hellooo"
+ set $S1, "hello"
+ le $S0, $S1, ERROR
+ OK5:
+ set $S0, "hello"
+ set $S1, "hella"
+ le $S0, $S1, ERROR
+ OK6:
+ set $S0, "hella"
+ set $S1, "hello"
+ le $S0, $S1, OK7
+ branch ERROR
+ OK7:
+ set $S0, "hella"
+ set $S1, "hellooo"
+ le $S0, $S1, OK8
+ branch ERROR
+ OK8:
+ set $S0, "hellooo"
+ set $S1, "hella"
+ le $S0, $S1, ERROR
+ OK9:
+ set $S0, "hElLo"
+ set $S1, "HeLlO"
+ le $S0, $S1, ERROR
+ OK10:
+ set $S0, "hElLo"
+ set $S1, "hElLo"
+ le $S0, $S1, OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'le_s_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'le_s_s_ic' )
+ END:
+.end
+
+.sub test_le_sc_s_ic
+ set $S0, "hello"
+ le "hello", $S0, OK1
+ branch ERROR
+ OK1:
+ set $S0, "world"
+ le "hello", $S0, OK2
+ branch ERROR
+ OK2:
+ set $S0, "hello"
+ le "world", $S0, ERROR
+ OK3:
+ set $S0, "hellooo"
+ le "hello", $S0, OK4
+ branch ERROR
+ OK4:
+ set $S0, "hello"
+ le "hellooo", $S0, ERROR
+ OK5:
+ set $S0, "hella"
+ le "hello", $S0, ERROR
+ OK6:
+ set $S0, "hello"
+ le "hella", $S0, OK7
+ branch ERROR
+ OK7:
+ set $S0, "hellooo"
+ le "hella", $S0, OK8
+ branch ERROR
+ OK8:
+ set $S0, "hella"
+ le "hellooo", $S0, ERROR
+ OK9:
+ set $S0, "HeLlO"
+ le "hElLo", $S0, ERROR
+ OK10:
+ set $S0, "hElLo"
+ le "hElLo", $S0, OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'le_sc_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'le_sc_s_ic' )
+ END:
+.end
+
+.sub test_le_s_sc_ic
+ set $S0, "hello"
+ le $S0, "hello", OK1
+ branch ERROR
+ OK1:
+ set $S0, "hello"
+ le $S0, "world", OK2
+ branch ERROR
+ OK2:
+ set $S0, "world"
+ le $S0, "hello", ERROR
+ OK3:
+ set $S0, "hello"
+ le $S0, "hellooo", OK4
+ branch ERROR
+ OK4:
+ set $S0, "hellooo"
+ le $S0, "hello", ERROR
+ OK5:
+ set $S0, "hello"
+ le $S0, "hella", ERROR
+ OK6:
+ set $S0, "hella"
+ le $S0, "hello", OK7
+ branch ERROR
+ OK7:
+ set $S0, "hella"
+ le $S0, "hellooo", OK8
+ branch ERROR
+ OK8:
+ set $S0, "hellooo"
+ le $S0, "hella", ERROR
+ OK9:
+ set $S0, "hElLo"
+ le $S0, "HeLlO", ERROR
+ OK10:
+ set $S0, "hElLo"
+ le $S0, "hElLo", OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'le_s_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'le_s_sc_ic' )
+ END:
+.end
+
+.sub test_le_sc_sc_ic
+ le "hello", "hello", OK1
+ branch ERROR
+ OK1:
+ le "hello", "world", OK2
+ branch ERROR
+ OK2:
+ le "world", "hello", ERROR
+ OK3:
+ le "hello", "hellooo", OK4
+ branch ERROR
+ OK4:
+ le "hellooo", "hello", ERROR
+ OK5:
+ le "hello", "hella", ERROR
+ OK6:
+ le "hella", "hello", OK7
+ branch ERROR
+ OK7:
+ le "hella", "hellooo", OK8
+ branch ERROR
+ OK8:
+ le "hellooo", "hella", ERROR
+ OK9:
+ le "hElLo", "HeLlO", ERROR
+ OK10:
+ le "hElLo", "hElLo", OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'le_sc_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'le_sc_sc_ic' )
+ END:
+.end
+
+.sub test_gt_s_s_ic
+ set $S0, "hello"
+ set $S1, "hello"
+ gt $S0, $S1, ERROR
+ OK1:
+ set $S0, "hello"
+ set $S1, "world"
+ gt $S0, $S1, ERROR
+ OK2:
+ set $S0, "world"
+ set $S1, "hello"
+ gt $S0, $S1, OK3
+ branch ERROR
+ OK3:
+ set $S0, "hello"
+ set $S1, "hellooo"
+ gt $S0, $S1, ERROR
+ OK4:
+ set $S0, "hellooo"
+ set $S1, "hello"
+ gt $S0, $S1, OK5
+ branch ERROR
+ OK5:
+ set $S0, "hello"
+ set $S1, "hella"
+ gt $S0, $S1, OK6
+ branch ERROR
+ OK6:
+ set $S0, "hella"
+ set $S1, "hello"
+ gt $S0, $S1, ERROR
+ OK7:
+ set $S0, "hella"
+ set $S1, "hellooo"
+ gt $S0, $S1, ERROR
+ OK8:
+ set $S0, "hellooo"
+ set $S1, "hella"
+ gt $S0, $S1, OK9
+ branch ERROR
+ OK9:
+ set $S0, "hElLo"
+ set $S1, "HeLlO"
+ gt $S0, $S1, OK10
+ branch ERROR
+ OK10:
+ set $S0, "hElLo"
+ set $S1, "hElLo"
+ gt $S0, $S1, ERROR
+ OK11:
+ ok( 1, 'gt_s_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'gt_s_s_ic' )
+ END:
+.end
+
+.sub test_gt_sc_s_ic
+ set $S0, "hello"
+ gt "hello", $S0, ERROR
+ OK1:
+ set $S0, "world"
+ gt "hello", $S0, ERROR
+ OK2:
+ set $S0, "hello"
+ gt "world", $S0, OK3
+ branch ERROR
+ OK3:
+ set $S0, "hellooo"
+ gt "hello", $S0, ERROR
+ OK4:
+ set $S0, "hello"
+ gt "hellooo", $S0, OK5
+ branch ERROR
+ OK5:
+ set $S0, "hella"
+ gt "hello", $S0, OK6
+ branch ERROR
+ OK6:
+ set $S0, "hello"
+ gt "hella", $S0, ERROR
+ OK7:
+ set $S0, "hellooo"
+ gt "hella", $S0, ERROR
+ OK8:
+ set $S0, "hella"
+ gt "hellooo", $S0, OK9
+ branch ERROR
+ OK9:
+ set $S0, "HeLlO"
+ gt "hElLo", $S0, OK10
+ branch ERROR
+ OK10:
+ set $S0, "hElLo"
+ gt "hElLo", $S0, ERROR
+ OK11:
+ ok( 1, 'gt_sc_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'gt_sc_s_ic' )
+ END:
+.end
+
+.sub test_gt_s_sc_ic
+ set $S0, "hello"
+ gt $S0, "hello", ERROR
+ OK1:
+ set $S0, "hello"
+ gt $S0, "world", ERROR
+ OK2:
+ set $S0, "world"
+ gt $S0, "hello", OK3
+ branch ERROR
+ OK3:
+ set $S0, "hello"
+ gt $S0, "hellooo", ERROR
+ OK4:
+ set $S0, "hellooo"
+ gt $S0, "hello", OK5
+ branch ERROR
+ OK5:
+ set $S0, "hello"
+ gt $S0, "hella", OK6
+ branch ERROR
+ OK6:
+ set $S0, "hella"
+ gt $S0, "hello", ERROR
+ OK7:
+ set $S0, "hella"
+ gt $S0, "hellooo", ERROR
+ OK8:
+ set $S0, "hellooo"
+ gt $S0, "hella", OK9
+ branch ERROR
+ OK9:
+ set $S0, "hElLo"
+ gt $S0, "HeLlO", OK10
+ branch ERROR
+ OK10:
+ set $S0, "hElLo"
+ gt $S0, "hElLo", ERROR
+ OK11:
+ ok( 1, 'gt_s_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'gt_s_sc_ic' )
+ END:
+.end
+
+.sub test_gt_sc_sc_ic
+ gt "hello", "hello", ERROR
+ OK1:
+ gt "hello", "world", ERROR
+ OK2:
+ gt "world", "hello", OK3
+ branch ERROR
+ OK3:
+ gt "hello", "hellooo", ERROR
+ OK4:
+ gt "hellooo", "hello", OK5
+ branch ERROR
+ OK5:
+ gt "hello", "hella", OK6
+ branch ERROR
+ OK6:
+ gt "hella", "hello", ERROR
+ OK7:
+ gt "hella", "hellooo", ERROR
+ OK8:
+ gt "hellooo", "hella", OK9
+ branch ERROR
+ OK9:
+ gt "hElLo", "HeLlO", OK10
+ branch ERROR
+ OK10:
+ gt "hElLo", "hElLo", ERROR
+ OK11:
+ ok( 1, 'gt_sc_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'gt_sc_sc_ic' )
+ END:
+.end
+
+.sub test_ge_s_s_ic
+ set $S0, "hello"
+ set $S1, "hello"
+ ge $S0, $S1, OK1
+ branch ERROR
+ OK1:
+ set $S0, "hello"
+ set $S1, "world"
+ ge $S0, $S1, ERROR
+ OK2:
+ set $S0, "world"
+ set $S1, "hello"
+ ge $S0, $S1, OK3
+ branch ERROR
+ OK3:
+ set $S0, "hello"
+ set $S1, "hellooo"
+ ge $S0, $S1, ERROR
+ OK4:
+ set $S0, "hellooo"
+ set $S1, "hello"
+ ge $S0, $S1, OK5
+ branch ERROR
+ OK5:
+ set $S0, "hello"
+ set $S1, "hella"
+ ge $S0, $S1, OK6
+ branch ERROR
+ OK6:
+ set $S0, "hella"
+ set $S1, "hello"
+ ge $S0, $S1, ERROR
+ OK7:
+ set $S0, "hella"
+ set $S1, "hellooo"
+ ge $S0, $S1, ERROR
+ OK8:
+ set $S0, "hellooo"
+ set $S1, "hella"
+ ge $S0, $S1, OK9
+ branch ERROR
+ OK9:
+ set $S0, "hElLo"
+ set $S1, "HeLlO"
+ ge $S0, $S1, OK10
+ branch ERROR
+ OK10:
+ set $S0, "hElLo"
+ set $S1, "hElLo"
+ ge $S0, $S1, OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'ge_s_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'ge_s_s_ic' )
+ END:
+.end
+
+.sub test_ge_sc_s_ic
+ set $S0, "hello"
+ ge "hello", $S0, OK1
+ branch ERROR
+ OK1:
+ set $S0, "world"
+ ge "hello", $S0, ERROR
+ OK2:
+ set $S0, "hello"
+ ge "world", $S0, OK3
+ branch ERROR
+ OK3:
+ set $S0, "hellooo"
+ ge "hello", $S0, ERROR
+ OK4:
+ set $S0, "hello"
+ ge "hellooo", $S0, OK5
+ branch ERROR
+ OK5:
+ set $S0, "hella"
+ ge "hello", $S0, OK6
+ branch ERROR
+ OK6:
+ set $S0, "hello"
+ ge "hella", $S0, ERROR
+ OK7:
+ set $S0, "hellooo"
+ ge "hella", $S0, ERROR
+ OK8:
+ set $S0, "hella"
+ ge "hellooo", $S0, OK9
+ branch ERROR
+ OK9:
+ set $S0, "HeLlO"
+ ge "hElLo", $S0, OK10
+ branch ERROR
+ OK10:
+ set $S0, "hElLo"
+ ge "hElLo", $S0, OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'ge_sc_s_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'ge_sc_s_ic' )
+ END:
+.end
+
+.sub test_ge_s_sc_ic
+ set $S0, "hello"
+ ge $S0, "hello", OK1
+ branch ERROR
+ OK1:
+ set $S0, "hello"
+ ge $S0, "world", ERROR
+ OK2:
+ set $S0, "world"
+ ge $S0, "hello", OK3
+ branch ERROR
+ OK3:
+ set $S0, "hello"
+ ge $S0, "hellooo", ERROR
+ OK4:
+ set $S0, "hellooo"
+ ge $S0, "hello", OK5
+ branch ERROR
+ OK5:
+ set $S0, "hello"
+ ge $S0, "hella", OK6
+ branch ERROR
+ OK6:
+ set $S0, "hella"
+ ge $S0, "hello", ERROR
+ OK7:
+ set $S0, "hella"
+ ge $S0, "hellooo", ERROR
+ OK8:
+ set $S0, "hellooo"
+ ge $S0, "hella", OK9
+ branch ERROR
+ OK9:
+ set $S0, "hElLo"
+ ge $S0, "HeLlO", OK10
+ branch ERROR
+ OK10:
+ set $S0, "hElLo"
+ ge $S0, "hElLo", OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'ge_s_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'ge_s_sc_ic' )
+ END:
+.end
+
+.sub test_ge_sc_sc_ic
+ ge "hello", "hello", OK1
+ branch ERROR
+ OK1:
+ ge "hello", "world", ERROR
+ OK2:
+ ge "world", "hello", OK3
+ branch ERROR
+ OK3:
+ ge "hello", "hellooo", ERROR
+ OK4:
+ ge "hellooo", "hello", OK5
+ branch ERROR
+ OK5:
+ ge "hello", "hella", OK6
+ branch ERROR
+ OK6:
+ ge "hella", "hello", ERROR
+ OK7:
+ ge "hella", "hellooo", ERROR
+ OK8:
+ ge "hellooo", "hella", OK9
+ branch ERROR
+ OK9:
+ ge "hElLo", "HeLlO", OK10
+ branch ERROR
+ OK10:
+ ge "hElLo", "hElLo", OK11
+ branch ERROR
+ OK11:
+ ok( 1, 'ge_sc_sc_ic' )
+ goto END
+ ERROR:
+ ok( 0, 'ge_sc_sc_ic' )
+ END:
+.end
+
+# Local Variables:
+# mode: pir
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir :
More information about the parrot-commits
mailing list