# New Ticket Created by Alberto Manuel Brandão Simões
# Please include the string: [perl #15340]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=15340 >
While it can be thought as too simple and stupid PMC, it can be very
usefull. (At least for my project it would be).
Still a simple implementation based on PerlInt. Stores 0 for false, 1
for true. Assignment of other values is available in the same way as
Perl trueness.
Still only one test.
In Attach, boolean.t (test file), boolean.pmc (PMC File) and diff for
other files.
Opefully, this can be accepted ;)
Alberto
--
Alberto Manuel B. Simoes
Departamento de Informática - Universidade do Minho
http://alfarrabio.di.uminho.pt/~albie - http://numexp.sf.net
-- attachment 1 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/30983/25965/ac3f25/diff_file
-- attachment 2 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/30983/25966/8bc81e/boolean.t
-- attachment 3 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/30983/25967/dcaea8/boolean.pmc
Index: assemble.pl
===================================================================
RCS file: /cvs/public/parrot/assemble.pl,v
retrieving revision 1.82
diff -u -r1.82 assemble.pl
--- assemble.pl 18 Jul 2002 02:13:27 -0000 1.82
+++ assemble.pl 22 Jul 2002 16:16:51 -0000
@@ -138,6 +138,7 @@
$self->{constants}{IntQueue} = 8;
$self->{constants}{Sub} = 9;
$self->{constants}{Coroutine} = 10;
+ $self->{constants}{Boolean} = 11;
$self;
}
Index: global_setup.c
===================================================================
RCS file: /cvs/public/parrot/global_setup.c,v
retrieving revision 1.28
diff -u -r1.28 global_setup.c
--- global_setup.c 4 Jul 2002 18:32:38 -0000 1.28
+++ global_setup.c 22 Jul 2002 16:16:51 -0000
@@ -33,6 +33,8 @@
Parrot_Sub_class_init(enum_class_Sub);
Parrot_Coroutine_class_init(enum_class_Coroutine);
+ Parrot_Boolean_class_init(enum_class_Boolean);
+
/* Now register the names of the PMCs */
/* We need a key to work with */
@@ -112,6 +114,12 @@
key->atom.type = enum_key_string;
Parrot_base_classname_hash->vtable->set_integer_keyed(NULL,
Parrot_base_classname_hash,
key, enum_class_Coroutine);
+
+ key->atom.val.string_val = (STRING*)
+ Parrot_base_vtables[enum_class_Boolean].name(NULL, NULL);
+ key->atom.type = enum_key_string;
+ Parrot_base_classname_hash->vtable->set_integer_keyed(NULL,
+ Parrot_base_classname_hash,
+key, enum_class_Boolean);
}
Index: include/parrot/pmc.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/pmc.h,v
retrieving revision 1.32
diff -u -r1.32 pmc.h
--- include/parrot/pmc.h 18 Jul 2002 04:30:42 -0000 1.32
+++ include/parrot/pmc.h 22 Jul 2002 16:16:51 -0000
@@ -25,8 +25,12 @@
enum_class_IntQueue,
enum_class_Sub,
enum_class_Coroutine,
+
+ enum_class_Boolean,
+
enum_class_Closure,
enum_class_Continuation,
+
enum_class_max = 100
};
VAR_SCOPE VTABLE Parrot_base_vtables[enum_class_max];
#! perl -w
use Parrot::Test tests => 1;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "Initialization");
new P0,.Boolean
set I0, P0
eq I0,0,OK_1
print "not "
OK_1: print "ok 1\n"
end
CODE
ok 1
OUTPUT
1;
__END__
output_is(<<'CODE', <<'OUTPUT', "Setting first element");
new P0, .Array
set P0, 1
set P0[0],-7
set I0,P0[0]
eq I0,-7,OK_1
print "not "
OK_1: print "ok 1\n"
set P0[0],3.7
set N0,P0[0]
eq N0,3.7,OK_2
print "not "
OK_2: print "ok 2\n"
set P0[0],"Buckaroo"
set S0,P0[0]
eq S0,"Buckaroo",OK_3
print "not "
OK_3: print "ok 3\n"
end
CODE
ok 1
ok 2
ok 3
OUTPUT
output_is(<<'CODE', <<'OUTPUT', "Setting second element");
new P0, .Array
set P0, 2
set P0[1], -7
set I0, P0[1]
eq I0,-7,OK_1
print "not "
OK_1: print "ok 1\n"
set P0[1], 3.7
set N0, P0[1]
eq N0,3.7,OK_2
print "not "
OK_2: print "ok 2\n"
set P0[1],"Buckaroo"
set S0, P0[1]
eq S0,"Buckaroo",OK_3
print "not "
OK_3: print "ok 3\n"
end
CODE
ok 1
ok 2
ok 3
OUTPUT
# TODO: Rewrite these properly when we have exceptions
output_is(<<'CODE', <<'OUTPUT', "Setting out-of-bounds elements");
new P0, .Array
set P0, 1
set P0[1], -7
end
CODE
Array element out of bounds!
OUTPUT
output_is(<<'CODE', <<'OUTPUT', "Getting out-of-bounds elements");
new P0, .Array
set P0, 1
set I0, P0[1]
end
CODE
Array element out of bounds!
OUTPUT
1;
/* boolean.pmc
* Copyright: (When this is determined...it will go here)
* CVS Info
* $Id$
* Overview:
* These are the vtable functions for the Boolean base class
* Data Structure and Algorithms:
* History:
* Notes:
* References:
*/
#include "parrot/parrot.h"
#include "parrot/perltypes.h"
pmclass Boolean {
void init () {
SELF->cache.int_val = 0;
}
void morph (INTVAL type) {
}
void destroy () {
/* Integers need no destruction! */
}
STRING* name() {
return whoami;
}
PMC* clone () {
PMC* dest;
dest = pmc_new(INTERP, SELF->vtable->base_type);
dest->cache.int_val = SELF->cache.int_val;
return dest;
}
INTVAL get_integer () {
return SELF->cache.int_val;
}
FLOATVAL get_number () {
return (FLOATVAL)SELF->cache.int_val;
}
BIGNUM* get_bignum () {
/* XXX */
return NULL;
}
STRING* get_string () {
return string_from_int(INTERP, SELF->cache.int_val);
}
INTVAL get_bool () {
return (INTVAL)(pmc->cache.int_val != 0);
}
INTVAL is_same (PMC* pmc2) {
/* Do you refer to exactly the same data that I do? */
return (INTVAL)( pmc2->vtable == SELF->vtable /* You never know if you've been
inherited...*/
&& SELF->cache.int_val == pmc2->cache.int_val );
}
void set_integer (PMC* value) {
SELF->cache.int_val = ((INTVAL)value->vtable->get_integer(INTERP, value) != 0);
}
void set_integer_native (INTVAL value) {
SELF->cache.int_val = (value != 0);
}
void set_integer_bignum (BIGNUM* value) {
SELF->cache.int_val = (value != 0); /* Maybe we need a copy */
/* SELF->vtable = &(Parrot_base_vtables[enum_class_PerlBignum]); */
}
void set_integer_same (PMC * value) {
SELF->cache.int_val = value->cache.int_val;
}
void set_number (PMC * value) {
SELF->cache.int_val = (value!=0);
}
void set_number_native (FLOATVAL value) {
SELF->cache.int_val = (value!=0);
}
void set_number_bignum (BIGNUM* value) {
/* SELF->vtable = &(Parrot_base_vtables[enum_class_PerlBigNum]); */
}
void set_number_same (PMC * value) {
SELF->cache.int_val = value->cache.int_val;
}
void set_bignum (PMC* value) {
/* XXX not sure if this can be optimized further safely */
// SELF->cache.struct_val = (DPOINTER*)value->vtable->get_bignum(INTERP,
value);
/* SELF->vtable = &(Parrot_base_vtables[enum_class_PerlBigNum]); */
}
void set_bignum_int (INTVAL value) {
/* XXX Make bignum from value */
}
void set_bignum_native (BIGNUM* value) {
/* XXX Some of this bignum stuff is starting to look pretty redundant -DML */
// SELF->cache.struct_val = value; /* Maybe we need a copy */
/* SELF->vtable = &(Parrot_base_vtables[enum_class_PerlBignum]); */
}
void set_bignum_float (FLOATVAL value) {
/* XXX */
}
void set_bignum_same (PMC* value) {
/* XXX not sure if this can be optimized further safely */
// SELF->cache.struct_val = (DPOINTER*)value->vtable->get_bignum(INTERP,
value);
/* SELF->vtable = &(Parrot_base_vtables[enum_class_PerlBigNum]); */
}
void set_string (PMC* value) {
SELF->cache.int_val = string_to_int(value->data);
}
void set_string_native (STRING* value) {
SELF->cache.int_val = string_to_int(value);
}
void set_string_unicode (STRING* value) {
SELF->cache.int_val = string_to_int(value);
}
void set_string_other (STRING* value) {
SELF->cache.int_val = string_to_int(value);
}
void set_string_same (PMC* value) {
SELF->cache.int_val = string_to_int(value->data);
}
void add (PMC* value, PMC* dest) {
/* Adding two booleans? */
/* if(value->vtable == &Parrot_base_vtables[enum_class_PerlNum]) {
CHANGE_TYPE(dest, PerlNum);
dest->vtable->set_number_native(INTERP, dest,
SELF->cache.int_val +
value->vtable->get_number(INTERP, value)
);
}
else if(value->vtable == &Parrot_base_vtables[enum_class_PerlString]) {
FLOATVAL f = value->vtable->get_number(INTERP, value);
INTVAL i = value->vtable->get_integer(INTERP, value);
if(f != i) {
CHANGE_TYPE(dest, PerlNum);
dest->vtable->set_number_native(INTERP, dest,
SELF->cache.int_val +
value->vtable->get_number(INTERP, value)
);
}
else {
CHANGE_TYPE(dest, PerlInt);
dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val +
value->vtable->get_integer(INTERP, value)
);
}
}
else {
CHANGE_TYPE(dest, PerlInt);
dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val +
value->vtable->get_integer(INTERP, value)
);
} */
}
void add_int (INTVAL value, PMC* dest) {
// dest->vtable->set_integer_native(INTERP, dest, SELF->cache.int_val + value);
}
void add_bignum (BIGNUM* value, PMC* dest) {
//
}
void add_same (PMC* value, PMC* dest) {
// dest->cache.int_val = SELF->cache.int_val + value->cache.int_val;
}
void subtract (PMC* value, PMC* dest) {
/*if(value->vtable == &Parrot_base_vtables[enum_class_PerlNum]) {
CHANGE_TYPE(dest, PerlNum);
dest->vtable->set_number_native(INTERP, dest,
SELF->cache.int_val -
value->vtable->get_number(INTERP, value)
);
}
else if(value->vtable == &Parrot_base_vtables[enum_class_PerlString]) {
FLOATVAL f = value->vtable->get_number(INTERP, value);
INTVAL i = value->vtable->get_integer(INTERP, value);
if(f != i) {
CHANGE_TYPE(dest, PerlNum);
dest->vtable->set_number_native(INTERP, dest,
SELF->cache.int_val -
value->vtable->get_number(INTERP, value)
);
}
else {
CHANGE_TYPE(dest, PerlInt);
dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val -
value->vtable->get_integer(INTERP, value)
);
}
}
else {
CHANGE_TYPE(dest, PerlInt);
dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val -
value->vtable->get_integer(INTERP, value)
);
}*/
}
void subtract_int (INTVAL value, PMC* dest) {
// dest->vtable->set_integer_native(INTERP, dest,
// SELF->cache.int_val - value
// );
}
void subtract_bignum (BIGNUM* value, PMC* dest) {
//
}
void subtract_float (FLOATVAL value, PMC* dest) {
//
}
void subtract_same (PMC* value, PMC* dest) {
// dest->cache.int_val = SELF->cache.int_val - value->cache.int_val;
}
void multiply (PMC* value, PMC* dest) {
/*if(value->vtable == &Parrot_base_vtables[enum_class_PerlNum]) {
CHANGE_TYPE(dest, PerlNum);
dest->vtable->set_number_native(INTERP, dest,
SELF->cache.int_val *
value->vtable->get_number(INTERP, value)
);
}
else if(value->vtable == &Parrot_base_vtables[enum_class_PerlString]) {
FLOATVAL f = value->vtable->get_number(INTERP, value);
INTVAL i = value->vtable->get_integer(INTERP, value);
if(f != i) {
CHANGE_TYPE(dest, PerlNum);
dest->vtable->set_number_native(INTERP, dest,
SELF->cache.int_val *
value->vtable->get_number(INTERP, value)
);
}
else {
CHANGE_TYPE(dest, PerlInt);
dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val *
value->vtable->get_integer(INTERP, value)
);
}
}
else {
CHANGE_TYPE(dest, PerlInt);
dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val *
value->vtable->get_integer(INTERP, value)
);
}*/
}
void multiply_int (INTVAL value, PMC* dest) {
// dest->vtable->set_integer_native(INTERP, dest,
// SELF->cache.int_val * value
// );
}
void multiply_bignum (BIGNUM* value, PMC* dest) {
//
}
void multiply_float (FLOATVAL value, PMC* dest) {
//
}
void multiply_same (PMC* value, PMC* dest) {
// dest->cache.int_val = SELF->cache.int_val * value->cache.int_val;
}
void divide (PMC* value, PMC* dest) {
/* if(value->vtable == &Parrot_base_vtables[enum_class_PerlNum]) {
CHANGE_TYPE(dest, PerlNum);
dest->vtable->set_number_native(INTERP, dest,
SELF->cache.int_val /
value->vtable->get_number(INTERP, value)
);
}
else if(value->vtable == &Parrot_base_vtables[enum_class_PerlString]) {
FLOATVAL f = value->vtable->get_number(INTERP, value);
INTVAL i = value->vtable->get_integer(INTERP, value);
if(f != i) {
CHANGE_TYPE(dest, PerlNum);
dest->vtable->set_number_native(INTERP, dest,
SELF->cache.int_val /
value->vtable->get_number(INTERP, value)
);
}
else {
CHANGE_TYPE(dest, PerlInt);
dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val /
value->vtable->get_integer(INTERP, value)
);
}
}
else {*/
/* Interesting race condition if SELF == dest */
/* FLOATVAL result = SELF->cache.int_val /
(FLOATVAL)value->vtable->get_integer(INTERP, value);
CHANGE_TYPE(dest, PerlNum);
dest->vtable->set_number_native(INTERP, dest, result);
}*/
}
void divide_int (INTVAL value, PMC* dest) {
// dest->vtable->set_number_native(INTERP, dest,
// (FLOATVAL)SELF->cache.int_val / value
// );
}
void divide_bignum (BIGNUM* value, PMC* dest) {
//
}
void divide_float (FLOATVAL value, PMC* dest) {
//
}
void divide_same (PMC* value, PMC* dest) {
// dest->cache.int_val = SELF->cache.int_val / value->cache.int_val;
}
void modulus (PMC* value, PMC* dest) {
/* if(value->vtable == &Parrot_base_vtables[enum_class_PerlNum]) {
fprintf(stderr,"perlint_modulus not implemented for floating point\n");
}
else if(value->vtable == &Parrot_base_vtables[enum_class_PerlString]) {
FLOATVAL f = value->vtable->get_number(INTERP, value);
INTVAL i = value->vtable->get_integer(INTERP, value);
if(f != i) {
fprintf(stderr,"perlint_modulus not implemented for floating point\n");
}
else {
CHANGE_TYPE(dest, PerlInt);
dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val %
value->vtable->get_integer(INTERP, value)
);
}
}
else {
CHANGE_TYPE(dest, PerlInt);
dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val %
value->vtable->get_integer(INTERP, value)
);
}*/
}
void modulus_int (INTVAL value, PMC* dest) {
// dest->vtable->set_integer_native(INTERP, dest,
// SELF->cache.int_val % value
// );
}
void modulus_bignum (BIGNUM* value, PMC* dest) {
//
}
void modulus_float (FLOATVAL value, PMC* dest) {
//
}
void modulus_same (PMC* value, PMC* dest) {
// dest->cache.int_val = SELF->cache.int_val % value->cache.int_val;
}
void neg (PMC* dest) {
dest->vtable->set_integer_native(INTERP, dest, !SELF->cache.int_val);
}
void bitwise_or (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val |
value->vtable->get_integer(INTERP, value)
);*/
}
void bitwise_or_int (INTVAL value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val | value
);*/
}
void bitwise_or_same (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val |
value->cache.int_val
);*/
}
void bitwise_and (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val &
value->vtable->get_integer(INTERP, value)
);*/
}
void bitwise_and_int (INTVAL value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val & value
);*/
}
void bitwise_and_same (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val &
value->cache.int_val
);*/
}
void bitwise_xor (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val ^
value->vtable->get_integer(INTERP, value)
);*/
}
void bitwise_xor_int (INTVAL value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val ^ value
);*/
}
void bitwise_xor_same (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val ^
value->cache.int_val
);*/
}
void bitwise_not (PMC* dest) {
// dest->vtable->set_integer_native(INTERP, dest, ~SELF->cache.int_val);
}
void bitwise_shr (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val >>
value->vtable->get_integer(INTERP, value)
);*/
}
void bitwise_shr_int (INTVAL value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val >> value
);*/
}
void bitwise_shr_same (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val >> value->cache.int_val
);*/
}
void bitwise_shl (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val <<
value->vtable->get_integer(INTERP, value)
);*/
}
void bitwise_shl_int (INTVAL value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val << value
);*/
}
void bitwise_shl_same (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val << value->cache.int_val
);*/
}
void concatenate (PMC* value, PMC* dest) {
/* STRING* s;
s = string_concat(INTERP,
SELF->vtable->get_string(INTERP, SELF),
value->vtable->get_string(INTERP, value),
0
);
CHANGE_TYPE(dest, PerlString);
dest->vtable->set_string_native(INTERP,dest,s);*/
}
void concatenate_native (STRING* value, PMC* dest) {
/* STRING* s;
s = string_concat(INTERP,
SELF->vtable->get_string(INTERP, SELF),
value,
0
);
CHANGE_TYPE(dest, PerlString);
dest->vtable->set_string_native(INTERP,dest,s);*/
}
void concatenate_unicode (STRING* value, PMC* dest) {
/* STRING* s;
s = string_concat(INTERP,
SELF->vtable->get_string(INTERP, SELF),
value,
0
);
CHANGE_TYPE(dest, PerlString);
dest->vtable->set_string_native(INTERP,dest,s);*/
}
void concatenate_other (STRING* value, PMC* dest) {
/* STRING* s;
s = string_concat(INTERP,
SELF->vtable->get_string(INTERP, SELF),
value,
0
);
CHANGE_TYPE(dest, PerlString);
dest->vtable->set_string_native(INTERP,dest,s);*/
}
void concatenate_same (PMC* value, PMC* dest) {
/* STRING* s;
s = string_concat(INTERP,
SELF->vtable->get_string(INTERP, SELF),
value->vtable->get_string(INTERP, value),
0
);
CHANGE_TYPE(dest, PerlString);
dest->vtable->set_string_native(INTERP,dest,s);*/
}
/* == operation */
INTVAL is_equal (PMC* value) {
return (INTVAL)(SELF->cache.int_val == value->vtable->get_integer(INTERP,
value));
}
/* INTVAL cmp(PMC* value) {
}
INTVAL cmp_num(PMC* value) {
}*/
void logical_or (PMC* value, PMC* dest) {
//
}
void logical_and (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
SELF->cache.int_val &&
value->vtable->get_bool(INTERP, value)
);*/
}
void logical_xor (PMC* value, PMC* dest) {
/* dest->vtable->set_integer_native(INTERP, dest,
( SELF->cache.int_val ? 1 : 0 ) ^
value->vtable->get_bool(INTERP, value)
);*/
}
void logical_not (PMC* value) {
value->vtable->set_integer_native(INTERP, value, !SELF->cache.int_val);
}
void repeat (PMC* value, PMC* dest) {
}
void repeat_int (INTVAL value, PMC* dest) {
}
void increment () {
// SELF->cache.int_val ++;
}
void decrement () {
// SELF->cache.int_val --;
}
}
