cvsuser 03/10/05 06:49:48
Modified: classes array.pmc default.pmc orderedhash.pmc perlarray.pmc
perlhash.pmc pmc2c.pl sarray.pmc
lib/Parrot Vtable.pm
. object.ops vtable.tbl
t/pmc objects.t
Log:
isa and does
* add missing isa vtables
* add missing isa op
* default isa implementation for PMCs
* default does implementation for PMCs (scalar, array, hash only)
* tests
Please run make realclean; perl Configure.pl ...
Revision Changes Path
1.67 +2 -2 parrot/classes/array.pmc
Index: array.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/array.pmc,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -w -r1.66 -r1.67
--- array.pmc 26 Sep 2003 12:28:09 -0000 1.66
+++ array.pmc 5 Oct 2003 13:49:26 -0000 1.67
@@ -1,7 +1,7 @@
/* array.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: array.pmc,v 1.66 2003/09/26 12:28:09 leo Exp $
+ * $Id: array.pmc,v 1.67 2003/10/05 13:49:26 leo Exp $
* Overview:
* These are the vtable functions for the Array base class
* Data Structure and Algorithms:
@@ -76,7 +76,7 @@
}
-pmclass Array need_ext {
+pmclass Array need_ext does array {
void class_init() {
/* class_init_code */
1.66 +22 -5 parrot/classes/default.pmc
Index: default.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/default.pmc,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -w -r1.65 -r1.66
--- default.pmc 26 Sep 2003 18:13:29 -0000 1.65
+++ default.pmc 5 Oct 2003 13:49:26 -0000 1.66
@@ -1,6 +1,6 @@
/* default.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
- * CVS Info $Id: default.pmc,v 1.65 2003/09/26 18:13:29 dan Exp $
+ * CVS Info $Id: default.pmc,v 1.66 2003/10/05 13:49:26 leo Exp $
* Overview:
* These are the vtable functions for the default PMC class
* Data Structure and Algorithms:
@@ -37,6 +37,22 @@
}
}
+static INTVAL
+does_isa (Parrot_Interp interp, STRING *method, STRING *what)
+{
+ INTVAL pos = string_str_index(interp, what, method, 0);
+ INTVAL len;
+
+ if (pos < 0)
+ return 0;
+ if (pos && string_index(what, pos - 1) != 32)
+ return 0;
+ len = string_length(method);
+ if (pos + len < (INTVAL)string_length(what) && string_index(what, pos + len) !=
32)
+ return 0;
+ return 1;
+}
+
pmclass default abstract noinit {
void init () {
@@ -278,10 +294,11 @@
INTVAL does (STRING* method) {
- internal_exception(ILL_INHERIT,
- "does() not implemented in class '%s'\n",
- caller(INTERP, SELF));
- return 0;
+ return does_isa(INTERP, method, SELF->vtable->does_str);
}
+ INTVAL isa (STRING* method) {
+ return does_isa(INTERP, method, SELF->vtable->isa_str);
+
+ }
}
1.9 +2 -2 parrot/classes/orderedhash.pmc
Index: orderedhash.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/orderedhash.pmc,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -w -r1.8 -r1.9
--- orderedhash.pmc 27 Sep 2003 18:31:38 -0000 1.8
+++ orderedhash.pmc 5 Oct 2003 13:49:26 -0000 1.9
@@ -1,7 +1,7 @@
/* orderedhash.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: orderedhash.pmc,v 1.8 2003/09/27 18:31:38 dan Exp $
+ * $Id: orderedhash.pmc,v 1.9 2003/10/05 13:49:26 leo Exp $
* Overview:
* These are the vtable functions for the OrderedHash base class
* Data Structure and Algorithms:
@@ -28,7 +28,7 @@
#include "parrot/parrot.h"
#include "pmc_perlhash.h"
-pmclass OrderedHash extends PerlArray need_ext {
+pmclass OrderedHash extends PerlArray need_ext does array does hash {
void init () {
SUPER();
PerlHash.SUPER();
1.60 +2 -2 parrot/classes/perlarray.pmc
Index: perlarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlarray.pmc,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -w -r1.59 -r1.60
--- perlarray.pmc 28 Aug 2003 13:17:01 -0000 1.59
+++ perlarray.pmc 5 Oct 2003 13:49:26 -0000 1.60
@@ -1,7 +1,7 @@
/* perlarray.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: perlarray.pmc,v 1.59 2003/08/28 13:17:01 leo Exp $
+ * $Id: perlarray.pmc,v 1.60 2003/10/05 13:49:26 leo Exp $
* Overview:
* These are the vtable functions for the PerlArray base class
* Data Structure and Algorithms:
@@ -36,7 +36,7 @@
return value;
}
-pmclass PerlArray extends Array need_ext {
+pmclass PerlArray extends Array need_ext does array {
void set_integer_keyed_int (INTVAL key, INTVAL value) {
PMC *src = pmc_new_noinit(INTERP, enum_class_PerlInt);
1.56 +2 -2 parrot/classes/perlhash.pmc
Index: perlhash.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlhash.pmc,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -w -r1.55 -r1.56
--- perlhash.pmc 5 Sep 2003 09:24:33 -0000 1.55
+++ perlhash.pmc 5 Oct 2003 13:49:26 -0000 1.56
@@ -1,7 +1,7 @@
/* perlhash.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: perlhash.pmc,v 1.55 2003/09/05 09:24:33 leo Exp $
+ * $Id: perlhash.pmc,v 1.56 2003/10/05 13:49:26 leo Exp $
* Overview:
* These are the vtable functions for the PerlHash base class
* Data Structure and Algorithms:
@@ -31,7 +31,7 @@
/* Albeit PerlHash doesn't use PMC_data, it needs the next_fo_GC pointer
* We would get recursive marking of a deeply nested HoHoH...
*/
-pmclass PerlHash need_ext {
+pmclass PerlHash need_ext does hash {
void class_init() {
/* class_init_code */
1.49 +50 -15 parrot/classes/pmc2c.pl
Index: pmc2c.pl
===================================================================
RCS file: /cvs/public/parrot/classes/pmc2c.pl,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -w -r1.48 -r1.49
--- pmc2c.pl 2 Oct 2003 08:09:03 -0000 1.48
+++ pmc2c.pl 5 Oct 2003 13:49:26 -0000 1.49
@@ -97,6 +97,16 @@
The class needs a PMC_EXT structure (its using e.g. PMC_data).
+=item does interface
+
+The class does the given interfaces (the collection of methods
+which the class implements).
+
+The default is "scalar". Other currently used interfaces are:
+
+ array
+ hash
+
=back
=item 3.
@@ -547,15 +557,25 @@
return if $print_tree || $print_meth;
# look through the pmc declaration header for flags such as noinit
- my $saw_extends;
+ my ($saw_extends, $saw_does);
my $superpmc = 'default';
while ($contents =~ s/^(\s*)(\w+)//s) {
$lineno += count_newlines($1);
if ($saw_extends) {
$superpmc = $2;
$saw_extends = 0;
+ } elsif ($saw_does) {
+ if ($flags{does}) {
+ $flags{does} = "$flags{does},$2";
+ }
+ else {
+ $flags{does} = $2;
+ }
+ $saw_does = 0;
} elsif ($2 eq 'extends') {
$saw_extends = 1;
+ } elsif ($2 eq 'does') {
+ $saw_does = 1;
} else {
$flags{$2}++;
}
@@ -730,6 +750,13 @@
}
}
+ my $isa = join(" ", grep { $_ ne 'default' } (keys %visible_supers));
+
+ my $does = "scalar";
+ if ($flags{does}) {
+ $does = join(" ", split/,/, $flags{does});
+ }
+
# this collapses the array and makes sure the spacing is right for
# the vtable
my $methodlist = join (",\n ", @methods);
@@ -751,27 +778,28 @@
struct _vtable temp_base_vtable = {
NULL, /* package */
- 0, /* base_type */
+ enum_class_$classname, /* base_type */
NULL, /* whoami */
NULL, /* method_table */
$vtbl_flag, /* flags */
- 0, /* reserved */
- 0, /* extra data */
+ NULL, /* does_str */
+ NULL, /* isa_str */
+ NULL, /* extra data */
$methodlist
};
- /* must set it here:
- * Sun's Workshop compiler complains about the use of a non-constant
- * initializer
- */
- temp_base_vtable.base_type = entry;
/*
* parrotio calls some class_init functions during its class_init
* code, so some of the slots might already be allocated
+ * class isa '$isa'
*/
if (!Parrot_base_vtables[entry]) {
temp_base_vtable.whoami = string_make(interp,
"$classname", @{[length($classname)]}, 0, PObj_constant_FLAG, 0);
+ temp_base_vtable.isa_str = string_make(interp,
+ "$isa", @{[length($isa)]}, 0, PObj_constant_FLAG, 0);
+ temp_base_vtable.does_str = string_make(interp,
+ "$does", @{[length($does)]}, 0, PObj_constant_FLAG, 0);
Parrot_base_vtables[entry] =
Parrot_clone_vtable(interp, &temp_base_vtable);
@@ -797,20 +825,27 @@
struct _vtable temp_base_vtable = {
NULL, /* package */
- enum_class_Const$classname,
+ enum_class_Const$classname, /* base_type */
NULL, /* whoami */
NULL, /* method_table */
$vtbl_flag, /* flags */
- 0, /* reserved */
- 0, /* extra data */
+ NULL, /* does_str */
+ NULL, /* isa_str */
+ NULL, /* extra data */
$cmethodlist
};
- if (!temp_base_vtable.whoami)
+ if (!temp_base_vtable.whoami) {
temp_base_vtable.whoami = string_make(interp,
"Const$classname", @{[length("Const$classname")]}, 0, PObj_constant_FLAG,
0);
+ temp_base_vtable.isa_str = string_make(interp,
+ "$isa", @{[length($isa)]}, 0, PObj_constant_FLAG, 0);
+ temp_base_vtable.does_str = string_make(interp,
+ "$does", @{[length($does)]}, 0, PObj_constant_FLAG, 0);
- Parrot_base_vtables[entry] = Parrot_clone_vtable(interp, &temp_base_vtable);
+ Parrot_base_vtables[entry] =
+ Parrot_clone_vtable(interp, &temp_base_vtable);
+ }
$class_init_code
}
EOC
1.18 +2 -2 parrot/classes/sarray.pmc
Index: sarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/sarray.pmc,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -w -r1.17 -r1.18
--- sarray.pmc 28 Aug 2003 14:56:46 -0000 1.17
+++ sarray.pmc 5 Oct 2003 13:49:26 -0000 1.18
@@ -1,7 +1,7 @@
/* sarray.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: sarray.pmc,v 1.17 2003/08/28 14:56:46 leo Exp $
+ * $Id: sarray.pmc,v 1.18 2003/10/05 13:49:26 leo Exp $
* Overview:
* These are the vtable functions for the SArray base class
* Data Structure and Algorithms:
@@ -23,7 +23,7 @@
#include "parrot/parrot.h"
-pmclass SArray const_too need_ext {
+pmclass SArray const_too need_ext does array {
void init () {
SELF->cache.int_val = 0;
PMC_data(SELF) = NULL;
1.24 +3 -2 parrot/lib/Parrot/Vtable.pm
Index: Vtable.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Vtable.pm,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -w -r1.23 -r1.24
--- Vtable.pm 2 Oct 2003 08:35:06 -0000 1.23
+++ Vtable.pm 5 Oct 2003 13:49:36 -0000 1.24
@@ -82,7 +82,8 @@
STRING* whoami; /* Name of class this vtable is for */
PMC* method_table; /* Method table PMC (?) */
UINTVAL flags; /* Flags. Duh */
- INTVAL reserved; /* For later use */
+ STRING* does_str; /* space separated list of interfaces */
+ STRING* isa_str; /* space separated list of classes */
void *data; /* To hang data off this vtable */
/* Vtable Functions */
1.9 +16 -8 parrot/object.ops
Index: object.ops
===================================================================
RCS file: /cvs/public/parrot/object.ops,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -w -r1.8 -r1.9
--- object.ops 22 Jul 2003 18:29:30 -0000 1.8
+++ object.ops 5 Oct 2003 13:49:42 -0000 1.9
@@ -56,8 +56,11 @@
=item B<does>(out INT, in PMC, in STR)
-Sets $1 to true or false, depending on whether $2 ->does the interface in
-$3
+Sets $1 to true or false, depending on whether $2 ->does the interface in $3.
+
+=item B<isa>(out INT, in PMC, in STR)
+
+Sets $1 to true or false, depending on whether $2 isa $3.
=cut
@@ -66,6 +69,11 @@
goto NEXT();
}
+inline op isa(out INT, in PMC, in STR) {
+ $1 = $2->vtable->isa(interpreter, $2, $3);
+ goto NEXT();
+}
+
###############################################################################
=item B<newclass>(out PMC, in STR)
1.45 +6 -1 parrot/vtable.tbl
Index: vtable.tbl
===================================================================
RCS file: /cvs/public/parrot/vtable.tbl,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -w -r1.44 -r1.45
--- vtable.tbl 26 Sep 2003 17:38:00 -0000 1.44
+++ vtable.tbl 5 Oct 2003 13:49:42 -0000 1.45
@@ -1,4 +1,4 @@
-# $Id: vtable.tbl,v 1.44 2003/09/26 17:38:00 dan Exp $
+# $Id: vtable.tbl,v 1.45 2003/10/05 13:49:42 leo Exp $
# [MAIN] #default section name
void init()
@@ -271,3 +271,8 @@
INTVAL does(STRING* method)
INTVAL does_keyed(PMC* key, STRING* method)
INTVAL does_keyed_int(INTVAL key, STRING* method)
+
+INTVAL isa(STRING* method)
+INTVAL isa_keyed(PMC* key, STRING* method)
+INTVAL isa_keyed_int(INTVAL key, STRING* method)
+
1.4 +70 -1 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- objects.t 25 Aug 2003 17:49:02 -0000 1.3
+++ objects.t 5 Oct 2003 13:49:48 -0000 1.4
@@ -1,6 +1,6 @@
#! perl -w
-use Parrot::Test tests => 4;
+use Parrot::Test tests => 7;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -74,4 +74,73 @@
/ok 1
Class doesn't exist/
OUTPUT
+# ' for vim
+output_is(<<'CODE', <<'OUTPUT', "isa");
+ new P1, .Boolean
+ isa I0, P1, "Boolean"
+ print I0
+ isa I0, P1, "Bool"
+ print I0
+ isa I0, P1, "scalar"
+ print I0
+ isa I0, P1, "calar"
+ print I0
+ print "\n"
+
+ isa I0, P1, "PerlInt"
+ print I0
+ isa I0, P1, "PerlIn"
+ print I0
+ isa I0, P1, "erl"
+ print I0
+ isa I0, P1, " "
+ print I0
+ print "\n"
+
+ isa I0, P1, ""
+ print I0
+ null S0
+ isa I0, P1, S0
+ print I0
+ set S0, "scalar"
+ isa I0, P1, S0
+ print I0
+
+ print "\n"
+ end
+CODE
+1010
+1000
+001
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "does scalar");
+ new P1, .Boolean
+ does I0, P1, "Boolean"
+ print I0
+ does I0, P1, "Bool"
+ print I0
+ does I0, P1, "scalar"
+ print I0
+ print "\n"
+ end
+CODE
+001
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "does array");
+ new P1, .OrderedHash
+ does I0, P1, "Boolean"
+ print I0
+ does I0, P1, "Bool"
+ print I0
+ does I0, P1, "hash"
+ print I0
+ does I0, P1, "array"
+ print I0
+ print "\n"
+ end
+CODE
+0011
+OUTPUT
