#!perl
# Copyright (C) 2001-2007, The Perl Foundation.
# $Id: pmc.t 22594 2007-10-29 18:40:31Z bernhard $
use strict;
use warnings;
use lib qw( . lib ../lib ../../lib );
use Test::More;
use Parrot::Test tests => 20;
use Parrot::PMC qw(%pmc_types);
=head1 NAME
t/pmc/pmc.t - PMCs
=head1 SYNOPSIS
% prove t/pmc/pmc.t
=head1 DESCRIPTION
Contains a lot of PMC related tests.
=cut
my $max_pmc = scalar( keys(%pmc_types) ) + 1;
my $fp_equality_macro = <<'ENDOFMACRO';
.macro fp_eq ( J, K, L )
save N0
save N1
save N2
set N0, .J
set N1, .K
sub N2, N1,N0
abs N2, N2
gt N2, 0.000001, .$FPEQNOK
restore N2
restore N1
restore N0
branch .L
.local $FPEQNOK:
restore N2
restore N1
restore N0
.endm
.macro fp_ne( J,K,L)
save N0
save N1
save N2
set N0, .J
set N1, .K
sub N2, N1,N0
abs N2, N2
lt N2, 0.000001, .$FPNENOK
restore N2
restore N1
restore N0
branch .L
.local $FPNENOK:
restore N2
restore N1
restore N0
.endm
ENDOFMACRO
pasm_output_is( <<'CODE', <<'OUTPUT', "newpmc" );
print "starting\n"
new P0, 'Integer'
print "ending\n"
end
CODE
starting
ending
OUTPUT
pasm_error_output_like( <<'CODE', <<'OUTPUT', "illegal min newpmc" );
new P0, 0
end
CODE
/Illegal PMC enum \(0\) in new/
OUTPUT
pasm_error_output_like( <<"CODE", <<'OUTPUT', "illegal max newpmc" );
new P0, $max_pmc
end
CODE
/Illegal PMC enum \(\d+\) in new/
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', 'typeof' );
new P0, 'Integer'
typeof S0,P0
eq S0, "Integer", OK_1
print "not "
OK_1:
print "ok 1\n"
typeof I0,P0
eq I0, .Integer, OK_2
print "not "
OK_2:
print "ok 2\n"
end
CODE
ok 1
ok 2
OUTPUT
my $checkTypes;
my %types_we_cant_test
= map { $_ => 1; } ( # These require initializers.
qw(Null Iterator Enumerate Ref STMRef SharedRef
ParrotObject ParrotThread
deleg_pmc BigInt LexInfo LexPad Slice Object),
# Instances of these appear to have other types.
qw(PMCProxy Class) );
while ( my ( $type, $id ) = each %pmc_types ) {
next
if $types_we_cant_test{$type};
my $set_ro = ( $type =~ /^Const\w+/ ) ? <<EOPASM : '';
new P10, 'Integer'
set P10, 1
setprop P0, "_ro", P10
EOPASM
$checkTypes .= <<"CHECK";
new P0, .$type
$set_ro
set S1, "$type"
typeof S0, P0
ne S0, S1, L_BadName
set I1, $id
typeof I0, P0
ne I0, I1, L_BadId
CHECK
}
pasm_output_like( <<"CODE", <<OUTPUT, "PMC type check" );
new P10, 'Hash'
new P11, 'Hash'
$checkTypes
print "All names and ids ok.\\n"
end
L_BadName:
print S1
print " PMCs have incorrect name \\""
print S0
print "\\"\\n"
end
L_BadId:
print S1
print " PMCs should be type "
print I1
print " but have incorrect type "
print I0
print "\\n"
end
CODE
/All names and ids ok/
OUTPUT
pasm_error_output_like( <<'CODE', <<'OUTPUT', 'find_method' );
new P1, 'Integer'
find_method P0, P1, "no_such_meth"
end
CODE
/Method 'no_such_meth' not found/
OUTPUT
pasm_error_output_like( <<'CODE', <<'OUTPUT', "new with a native type" );
new P1, .INTVAL
print "never\n"
end
CODE
/(unknown macro|unexpected DOT)/
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "eq_addr same" );
new P0, 'Integer'
set P1, P0
eq_addr P0, P1, OK1
print "not "
OK1: print "ok 1\n"
ne_addr P0, P1, BAD2
branch OK2
BAD2: print "not "
OK2: print "ok 2\n"
end
CODE
ok 1
ok 2
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "eq_addr diff" );
new P0, 'Integer'
new P1, 'Integer'
ne_addr P0, P1, OK1
print "not "
OK1: print "ok 1\n"
eq_addr P0, P1, BAD2
branch OK2
BAD2: print "not "
OK2: print "ok 2\n"
end
CODE
ok 1
ok 2
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "if_null" );
null P0
if_null P0, OK1
print "not "
OK1: print "ok 1\n"
new P0, 'Integer'
if_null P0, BAD2
branch OK2
BAD2: print "not "
OK2: print "ok 2\n"
end
CODE
ok 1
ok 2
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "Random PMCs are singletons" );
new P0, 'Random'
new P1, 'Random'
eq_addr P0, P1, ok
print "not the same "
ok: print "ok\n"
end
CODE
ok
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "issame" );
new P0, 'Undef'
new P1, 'Undef'
set P1, P0
issame I0, P0, P1
print I0
isntsame I0, P0, P1
print I0
new P2, 'Undef'
issame I0, P0, P2
print I0
isntsame I0, P0, P2
print I0
print "\n"
end
CODE
1001
OUTPUT
SKIP: {
skip( "no instantiate", 1 );
pasm_output_is( <<'CODE', <<'OUTPUT', "instantiate - no args" );
getclass P2, "Integer"
set I0, 0 # unproto
set I3, 0 # no P args
instantiate P3
typeof S0, P3
print S0
print "\n"
set I0, P3
print I0
print "\n"
end
CODE
Integer
0
OUTPUT
}
pasm_output_is( <<'CODE', <<'OUT', ".const - Sub constant" );
.pcc_sub :main main:
print "ok 1\n"
.const .Sub P0 = "foo"
invokecc P0
print "ok 3\n"
end
.pcc_sub foo:
print "ok 2\n"
returncc
CODE
ok 1
ok 2
ok 3
OUT
pir_output_is( <<'CODE', <<'OUT', "pmc constant 1" );
.sub main :main
.const Integer i = "42"
print i
print "\n"
.end
CODE
42
OUT
pir_output_is( <<'CODE', <<'OUT', "pmc constant 2" );
.sub main :main
.const .Integer i = "42"
print i
print "\n"
.end
CODE
42
OUT
pasm_output_is( <<'CODE', <<'OUT', "pmc constant PASM" );
.const .Integer P0 = "42"
print P0
print "\n"
end
CODE
42
OUT
pasm_output_is( <<'CODE', <<'OUT', "logical or, and, xor" );
new P0, 'Integer'
set P0, 2
new P1, 'Undef'
or P2, P0, P1
eq_addr P2, P0, ok1
print "not "
ok1:
print "ok 1\n"
and P2, P0, P1
eq_addr P2, P1, ok2
print "not "
ok2:
print "ok 2\n"
xor P2, P0, P1
eq_addr P2, P0, ok3
print "not "
ok3:
print "ok 3\n"
end
CODE
ok 1
ok 2
ok 3
OUT
pasm_output_is( <<'CODE', <<'OUTPUT', "new_p_s" );
new P3, "Integer"
set P3, "42"
typeof S0, P3
print S0
print "\n"
set I0, P3
print I0
print "\n"
end
CODE
String
42
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "pmcinfo_i_p_ic" );
.include "pmcinfo.pasm"
new P0, 'Integer'
pmcinfo I0, P0, .PMCINFO_FLAGS
shl I2, 1, 9 # PObj_is_PMC_FLAG s. pobj.h
band I1, I0, I2
if I1, ok
print "PMC flag not set\n"
end
ok:
print "ok\n"
end
CODE
ok
OUTPUT
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
syntax highlighted by Code2HTML, v. 0.9.1