cvsuser 03/12/10 09:18:38
Modified: . MANIFEST
classes env.pmc
lib/Parrot Pmc2c.pm Vtable.pm
src pmc.c
t/pmc env.t pmc.t
Added: classes random.pmc
Log:
framework for creating singletion PMC class objs
Revision Changes Path
1.513 +1 -0 parrot/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.512
retrieving revision 1.513
diff -u -w -r1.512 -r1.513
--- MANIFEST 5 Dec 2003 15:54:43 -0000 1.512
+++ MANIFEST 10 Dec 2003 17:18:27 -0000 1.513
@@ -68,6 +68,7 @@
classes/pmc2c.pl []
classes/pmc2c2.pl []
classes/pointer.pmc []
+classes/random.pmc []
classes/ref.pmc []
classes/retcontinuation.pmc []
classes/sarray.pmc []
1.9 +2 -2 parrot/classes/env.pmc
Index: env.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/env.pmc,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -w -r1.8 -r1.9
--- env.pmc 25 Aug 2003 09:46:23 -0000 1.8
+++ env.pmc 10 Dec 2003 17:18:30 -0000 1.9
@@ -1,7 +1,7 @@
/* env.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: env.pmc,v 1.8 2003/08/25 09:46:23 leo Exp $
+ * $Id: env.pmc,v 1.9 2003/12/10 17:18:30 leo Exp $
* Overview:
* These are the vtable functions for the Env base class, which
* accesses the system environment
@@ -13,7 +13,7 @@
#include "parrot/parrot.h"
-pmclass Env extends default {
+pmclass Env singleton {
STRING* get_string_keyed(PMC* key) {
char *keyname = string_to_cstring(interpreter,
1.1 parrot/classes/random.pmc
Index: random.pmc
===================================================================
/* random.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
* $Id: random.pmc,v 1.1 2003/12/10 17:18:30 leo Exp $
* Overview:
* These are the vtable functions for the Random base class.
* This is a singleton (monadic) class - only one instance exists.
* Data Structure and Algorithms:
* History:
* 2003.12.10 first rev by leo
* Notes:
* References:
*/
#include "parrot/parrot.h"
#include <assert.h>
static PMC * Rand_PMC;
pmclass Random singleton {
/*
* singleton creation interface s. pmc.c
*/
void* get_pointer() {
return Rand_PMC;
}
void set_pointer(void* ptr) {
assert(!Rand_PMC);
Rand_PMC = (PMC*) ptr;
}
}
1.8 +3 -0 parrot/lib/Parrot/Pmc2c.pm
Index: Pmc2c.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Pmc2c.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -w -r1.7 -r1.8
--- Pmc2c.pm 4 Dec 2003 12:43:14 -0000 1.7
+++ Pmc2c.pm 10 Dec 2003 17:18:33 -0000 1.8
@@ -307,6 +307,9 @@
if (exists $self->{flags}{need_ext}) {
$vtbl_flag .= '|VTABLE_PMC_NEEDS_EXT';
}
+ if (exists $self->{flags}{singleton}) {
+ $vtbl_flag .= '|VTABLE_PMC_IS_SINGLETON';
+ }
my @meths;
foreach my $method (@{ $self->{vtable}{methods}} ) {
my $meth = $method->{meth};
1.28 +2 -1 parrot/lib/Parrot/Vtable.pm
Index: Vtable.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Vtable.pm,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -w -r1.27 -r1.28
--- Vtable.pm 23 Oct 2003 10:21:15 -0000 1.27
+++ Vtable.pm 10 Dec 2003 17:18:33 -0000 1.28
@@ -73,7 +73,8 @@
VTABLE_IS_CONST_FLAG = 0x01,
VTABLE_HAS_CONST_TOO = 0x02,
VTABLE_PMC_NEEDS_EXT = 0x04,
- VTABLE_DATA_IS_PMC = 0x08
+ VTABLE_DATA_IS_PMC = 0x08,
+ VTABLE_PMC_IS_SINGLETON = 0x10
} vtable_flags_t;
struct _vtable {
1.59 +23 -6 parrot/src/pmc.c
Index: pmc.c
===================================================================
RCS file: /cvs/public/parrot/src/pmc.c,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -w -r1.58 -r1.59
--- pmc.c 3 Dec 2003 14:43:17 -0000 1.58
+++ pmc.c 10 Dec 2003 17:18:35 -0000 1.59
@@ -1,7 +1,7 @@
/* pmc.c
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: pmc.c,v 1.58 2003/12/03 14:43:17 leo Exp $
+ * $Id: pmc.c,v 1.59 2003/12/10 17:18:35 leo Exp $
* Overview:
* The base vtable calling functions.
* Data Structure and Algorithms:
@@ -116,13 +116,30 @@
{
PMC *pmc;
/* we only have one global Env object, livin in the interpreter */
+ if (Parrot_base_vtables[base_type]->flags & VTABLE_PMC_IS_SINGLETON) {
if (base_type == enum_class_Env) {
+ /* XXX need probably a lock around this code
+ */
pmc = VTABLE_get_pmc_keyed_int(interpreter, interpreter->iglobals,
(INTVAL)IGLOBALS_ENV_HASH);
if (!pmc) {
pmc = get_new_pmc_header(interpreter, base_type, 0);
VTABLE_set_pmc_keyed_int(interpreter, interpreter->iglobals,
(INTVAL)IGLOBALS_ENV_HASH, pmc);
+ /* UNLOCK */}
+ return pmc;
+ }
+ /*
+ * singletons (monadic objects) exist only once, the interface
+ * with the class is:
+ * - get_pointer: return NULL or a pointer to the single instance
+ * - set_pointer: set the only instance once
+ */
+ pmc = (Parrot_base_vtables[base_type]->get_pointer)(interpreter, NULL);
+ /* LOCK */
+ if (!pmc) {
+ pmc = get_new_pmc_header(interpreter, base_type, 0);
+ VTABLE_set_pointer(interpreter, pmc, pmc);
}
return pmc;
}
1.6 +13 -1 parrot/t/pmc/env.t
Index: env.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/env.t,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- env.t 9 Aug 2003 07:22:02 -0000 1.5
+++ env.t 10 Dec 2003 17:18:38 -0000 1.6
@@ -1,8 +1,20 @@
#! perl -w
-use Parrot::Test tests => 5;
+use Parrot::Test tests => 6;
use Test::More;
use Parrot::Config;
+
+
+output_is(<<'CODE', <<OUT, "all Envs are ident");
+ new P0, .Env
+ new P1, .Env
+ eq_addr P0, P1, ok
+ print "not the same "
+ok: print "ok\n"
+ end
+CODE
+ok
+OUT
$ENV{"PARROT_TMP"} = "riding a ponie";
output_like(<<'CODE', <<OUT, "getenv");
1.77 +12 -1 parrot/t/pmc/pmc.t
Index: pmc.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/pmc.t,v
retrieving revision 1.76
retrieving revision 1.77
diff -u -w -r1.76 -r1.77
--- pmc.t 10 Dec 2003 11:44:12 -0000 1.76
+++ pmc.t 10 Dec 2003 17:18:38 -0000 1.77
@@ -1,6 +1,6 @@
#! perl -w
-use Parrot::Test tests => 89;
+use Parrot::Test tests => 90;
use Test::More;
use Parrot::PMC qw(%pmc_types);
my $max_pmc = scalar(keys(%pmc_types)) + 1;
@@ -2481,6 +2481,17 @@
CODE
ok 1
ok 2
+OUTPUT
+
+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
1;
