t/pmc/pmc.t

   1 #!perl
   2 # Copyright (C) 2001-2009, Parrot Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8
   9 use Test::More;
  10 use Parrot::Test tests => 15;
  11 use Parrot::PMC '%pmc_types';
  12
  13 =head1 NAME
  14
  15 t/pmc/pmc.t - PMCs
  16
  17 =head1 SYNOPSIS
  18
  19     % prove t/pmc/pmc.t
  20
  21 =head1 DESCRIPTION
  22
  23 Contains a lot of PMC related tests.
  24
  25 =cut
  26
  27 pir_output_is( <<'CODE', <<'OUTPUT', "newpmc" );
  28 .sub main
  29     say "starting"
  30     new $P0, ['Integer']
  31     say "ending"
  32 .end
  33 CODE
  34 starting
  35 ending
  36 OUTPUT
  37
  38 pir_output_is( <<'CODE', <<'OUTPUT', 'typeof' );
  39 .sub main
  40     new $P0, ['Integer']
  41     typeof $S0, $P0
  42     eq     $S0, "Integer", OK_1
  43     print  "not "
  44 OK_1:
  45     print  "ok 1\n"
  46 .end
  47 CODE
  48 ok 1
  49 OUTPUT
  50
  51 my $checkTypes;
  52 my %types_we_cant_test
  53     = map { $_ => 1; } (    # These require initializers.
  54     qw(default Null Iterator ArrayIterator HashIterator StringIterator
  55         OrderedHashIterator Enumerate ParrotObject ParrotThread BigInt LexInfo
  56         LexPad Object Handle Opcode OpLib),
  57
  58     # Instances of these appear to have other types.
  59     qw(PMCProxy Class) );
  60 while ( my ( $type, $id ) = each %pmc_types ) {
  61     next
  62         if $types_we_cant_test{$type};
  63     my $set_ro = ( $type =~ /^Const\w+/ ) ? <<'PIR' : '';
  64     new $P10, ['Integer']
  65     set $P10, 1
  66     setprop $P0, "_ro", $P10
  67 PIR
  68     $checkTypes .= qq{ new \$P0, '$type'\n$set_ro\n};
  69     $checkTypes .= qq{ set \$S1, "$type"\n};
  70     $checkTypes .= <<'CHECK';
  71     typeof $S0, $P0
  72     ne $S0, $S1, L_BadName
  73 CHECK
  74 }
  75
  76 pir_output_like( <<"CODE", qr/All names ok/, "PMC type check" );
  77 .sub main
  78     new \$P10, ['Hash']
  79     new \$P11, ['Hash']
  80 $checkTypes
  81     say "All names ok."
  82     end
  83 L_BadName:
  84     print \$S1
  85     print " PMCs have incorrect name \\""
  86     print \$S0
  87     print "\\"\\n"
  88 .end
  89 CODE
  90
  91 pir_error_output_like( <<'CODE', <<'OUTPUT', 'find_method' );
  92 .sub main
  93     new $P1, ['Integer']
  94     find_method $P0, $P1, "no_such_meth"
  95 .end
  96 CODE
  97 /Method 'no_such_meth' not found for invocant of class 'Integer'/
  98 OUTPUT
  99
 100 pir_output_is( <<'CODE', <<'OUTPUT', "eq_addr same" );
 101 .sub main
 102       new $P0, ['Integer']
 103       set $P1, $P0
 104       eq_addr $P0, $P1, OK1
 105       print "not "
 106 OK1:  print "ok 1\n"
 107       ne_addr $P0, $P1, BAD2
 108       branch OK2
 109 BAD2: print "not "
 110 OK2:  print "ok 2\n"
 111 .end
 112 CODE
 113 ok 1
 114 ok 2
 115 OUTPUT
 116
 117 pir_output_is( <<'CODE', <<'OUTPUT', "eq_addr diff" );
 118 .sub main
 119       new $P0, ['Integer']
 120       new $P1, ['Integer']
 121       ne_addr $P0, $P1, OK1
 122       print "not "
 123 OK1:  print "ok 1\n"
 124       eq_addr $P0, $P1, BAD2
 125       branch OK2
 126 BAD2: print "not "
 127 OK2:  print "ok 2\n"
 128 .end
 129 CODE
 130 ok 1
 131 ok 2
 132 OUTPUT
 133
 134 pir_output_is( <<'CODE', <<'OUTPUT', "if_null" );
 135 .sub main
 136       null $P0
 137       if_null $P0, OK1
 138       print "not "
 139 OK1:  print "ok 1\n"
 140       new $P0, ['Integer']
 141       if_null $P0, BAD2
 142       branch OK2
 143 BAD2: print "not "
 144 OK2:  print "ok 2\n"
 145 .end
 146 CODE
 147 ok 1
 148 ok 2
 149 OUTPUT
 150
 151 pir_output_is( <<'CODE', <<'OUTPUT', "Env PMCs are singletons" );
 152 .sub main
 153     new $P0, ['Env']
 154     new $P1, ['Env']
 155     eq_addr $P0, $P1, ok
 156     print "not the same "
 157 ok: print "ok\n"
 158 .end
 159 CODE
 160 ok
 161 OUTPUT
 162
 163 pir_output_is( <<'CODE', <<'OUTPUT', "issame" );
 164 .sub main
 165     new $P0, ['Undef']
 166     new $P1, ['Undef']
 167     set $P1, $P0
 168     issame $I0, $P0, $P1
 169     print $I0
 170     isntsame $I0, $P0, $P1
 171     print $I0
 172     new $P2, ['Undef']
 173     issame $I0, $P0, $P2
 174     print $I0
 175     isntsame $I0, $P0, $P2
 176     say $I0
 177 .end
 178 CODE
 179 1001
 180 OUTPUT
 181
 182 pir_output_is( <<'CODE', <<'OUT', ".const - Sub constant" );
 183 .sub main
 184     print "ok 1\n"
 185     .const 'Sub' $P0 = "foo"
 186     invokecc $P0
 187     print "ok 3\n"
 188 .end
 189 .sub foo
 190     print "ok 2\n"
 191     returncc
 192 .end
 193 CODE
 194 ok 1
 195 ok 2
 196 ok 3
 197 OUT
 198
 199 pir_output_is( <<'CODE', <<'OUT', "Integer pmc constant " );
 200 .sub main :main
 201     .const 'Integer' i = "42"
 202     say i
 203 .end
 204 CODE
 205 42
 206 OUT
 207
 208 pir_output_is( <<'CODE', <<'OUT', "Float pmc constant " );
 209 .sub main :main
 210     .const 'Float' j = "4.2"
 211     say j
 212 .end
 213 CODE
 214 4.2
 215 OUT
 216
 217 pir_output_is( <<'CODE', <<'OUT', "pmc constant" );
 218 .sub main
 219     .const 'Integer' $P0 = "42"
 220     say $P0
 221 .end
 222 CODE
 223 42
 224 OUT
 225
 226 pir_output_is( <<'CODE', <<'OUT', "logical or, and, xor" );
 227 .sub main
 228     new $P0, ['Integer']
 229     set $P0, 2
 230     new $P1, ['Undef']
 231     or $P2, $P0, $P1
 232     eq_addr $P2, $P0, ok1
 233     print "not "
 234 ok1:
 235     print "ok 1\n"
 236     and $P2, $P0, $P1
 237     eq_addr $P2, $P1, ok2
 238     print "not "
 239 ok2:
 240     print "ok 2\n"
 241     xor $P2, $P0, $P1
 242     eq_addr $P2, $P0, ok3
 243     print "not "
 244 ok3:
 245     print "ok 3\n"
 246 .end
 247 CODE
 248 ok 1
 249 ok 2
 250 ok 3
 251 OUT
 252
 253 pir_output_is( <<'CODE', <<'OUTPUT', "new_p_s" );
 254 .sub main
 255     new $P3, ['Integer']
 256     set $P3, "42"
 257     typeof $S0, $P3
 258     print $S0
 259     print "\n"
 260     set $I0, $P3
 261     print $I0
 262     print "\n"
 263 .end
 264 CODE
 265 String
 266 42
 267 OUTPUT
 268
 269 # Local Variables:
 270 #   mode: cperl
 271 #   cperl-indent-level: 4
 272 #   fill-column: 100
 273 # End:
 274 # vim: expandtab shiftwidth=4: