Author: infinoid
Date: Wed Aug 6 21:12:12 2008
New Revision: 30080
Modified:
branches/pdd13pbc/include/parrot/string_funcs.h
branches/pdd13pbc/languages/lua/src/lib/alarm.pir
branches/pdd13pbc/languages/lua/src/lib/base64.pir
branches/pdd13pbc/languages/lua/src/lib/bc.pir
branches/pdd13pbc/languages/lua/src/lib/bitlib.pir
branches/pdd13pbc/languages/lua/src/lib/gl.pir
branches/pdd13pbc/languages/lua/src/lib/glut.pir
branches/pdd13pbc/languages/lua/src/lib/lfs.pir
branches/pdd13pbc/languages/lua/src/lib/luafile.pir
branches/pdd13pbc/languages/lua/src/lib/luaio.pir
branches/pdd13pbc/languages/lua/src/lib/md5.pir
branches/pdd13pbc/languages/lua/src/lib/random.pir
branches/pdd13pbc/languages/lua/src/lib/uuid.pir
branches/pdd13pbc/languages/perl6/src/pmc/perl6multisub.pmc
branches/pdd13pbc/languages/perl6/t/pmc/perl6multisub-basic.t
branches/pdd13pbc/src/pmc.c
branches/pdd13pbc/src/stm/backend.c
branches/pdd13pbc/src/string.c
branches/pdd13pbc/t/codingstd/filenames.t
Log:
[pdd13] Merge changes from trunk (-30063:30079) into pdd13pbc branch.
This gets all the tests passing again.
Modified: branches/pdd13pbc/include/parrot/string_funcs.h
==============================================================================
--- branches/pdd13pbc/include/parrot/string_funcs.h (original)
+++ branches/pdd13pbc/include/parrot/string_funcs.h Wed Aug 6 21:12:12 2008
@@ -474,8 +474,7 @@
PARROT_API
PARROT_WARN_UNUSED_RESULT
-INTVAL string_to_int(SHIM_INTERP, ARGIN(const STRING *s))
- __attribute__nonnull__(2);
+INTVAL string_to_int(SHIM_INTERP, ARGIN_NULLOK(const STRING *s));
PARROT_API
PARROT_WARN_UNUSED_RESULT
Modified: branches/pdd13pbc/languages/lua/src/lib/alarm.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/alarm.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/alarm.pir Wed Aug 6 21:12:12 2008
@@ -18,7 +18,7 @@
=cut
.HLL 'Lua', 'lua_group'
-.namespace [ 'Lua'; 'alarm' ]
+.namespace [ 'alarm' ]
.sub '__onload' :anon :load
# print "__onload alarm\n"
Modified: branches/pdd13pbc/languages/lua/src/lib/base64.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/base64.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/base64.pir Wed Aug 6 21:12:12 2008
@@ -18,7 +18,7 @@
=cut
.HLL 'Lua', 'lua_group'
-.namespace [ 'Lua'; 'base64' ]
+.namespace [ 'base64' ]
.sub '__onload' :anon :load
# print "__onload base64\n"
@@ -70,6 +70,11 @@
# set $P1, "_VERSION"
# _base64[$P1] = $P2
+ $P0 = get_hll_namespace ['MIME'; 'Base64']
+ $P1 = get_namespace
+ $P2 = split ' ', 'decode_base64 encode_base64'
+ $P0.'export_to'($P1, $P2)
+
.return (_base64)
.end
@@ -79,12 +84,11 @@
=cut
.sub 'decode' :anon
- .param pmc s :optional
+ .param pmc str :optional
.param pmc extra :slurpy
.local pmc res
- $S1 = lua_checkstring(1, s)
- $P0 = get_hll_global ['MIME'; 'Base64'], 'decode_base64'
- $S0 = $P0($S1)
+ $S1 = lua_checkstring(1, str)
+ $S0 = decode_base64($S1)
new res, 'LuaString'
set res, $S0
.return (res)
@@ -96,12 +100,11 @@
=cut
.sub 'encode' :anon
- .param pmc s :optional
+ .param pmc str :optional
.param pmc extra :slurpy
.local pmc res
- $S1 = lua_checkstring(1, s)
- $P0 = get_hll_global ['MIME'; 'Base64'], 'encode_base64'
- $S0 = $P0($S1)
+ $S1 = lua_checkstring(1, str)
+ $S0 = encode_base64($S1)
new res, 'LuaString'
set res, $S0
.return (res)
Modified: branches/pdd13pbc/languages/lua/src/lib/bc.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/bc.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/bc.pir Wed Aug 6 21:12:12 2008
@@ -21,7 +21,7 @@
=cut
.HLL 'Lua', 'lua_group'
-.namespace [ 'Lua'; 'bc' ]
+.namespace [ 'bc' ]
.sub '__onload' :anon :load
# print "__onload bc\n"
@@ -161,7 +161,7 @@
new $P0, 'LuaNumber'
set $P0, 0
- set_hll_global ['Lua'; 'bc'], 'DIGITS', $P0
+ set_hll_global ['bc'], 'DIGITS', $P0
.return (_bc)
.end
@@ -236,7 +236,7 @@
.param pmc extra :slurpy
.local pmc res
.local int DIGITS
- $P0 = get_hll_global ['Lua'; 'bc'], 'DIGITS'
+ $P0 = get_hll_global ['bc'], 'DIGITS'
res = clone $P0
DIGITS = $P0
$I1 = lua_optint(1, n, DIGITS)
Modified: branches/pdd13pbc/languages/lua/src/lib/bitlib.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/bitlib.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/bitlib.pir Wed Aug 6 21:12:12 2008
@@ -21,7 +21,7 @@
=cut
.HLL 'Lua', 'lua_group'
-.namespace [ 'Lua'; 'bitlib' ]
+.namespace [ 'bitlib' ]
.sub '__onload' :anon :load
# print "__onload bitlib\n"
@@ -112,14 +112,14 @@
L1:
new $P0, 'Integer'
set $P0, max
- set_hll_global ['Lua'; 'bit'], 'BIT_MAX', $P0
+ set_hll_global ['bit'], 'BIT_MAX', $P0
.return (bits)
.end
.macro MONADIC(op, a)
.local pmc res
.local int BIT_MAX
- $P0 = get_hll_global ['Lua'; 'bit'], 'BIT_MAX'
+ $P0 = get_hll_global ['bit'], 'BIT_MAX'
BIT_MAX = $P0
$I1 = lua_checknumber(1, .a)
.op $I0, $I1
@@ -132,7 +132,7 @@
.macro VARIADIC(op, a, vararg)
.local pmc res
.local int BIT_MAX
- $P0 = get_hll_global ['Lua'; 'bit'], 'BIT_MAX'
+ $P0 = get_hll_global ['bit'], 'BIT_MAX'
BIT_MAX = $P0
$I1 = lua_checknumber(1, .a)
.local int i
@@ -154,7 +154,7 @@
.macro LOGICAL_SHIFT(op, a, b)
.local pmc res
.local int BIT_MAX
- $P0 = get_hll_global ['Lua'; 'bit'], 'BIT_MAX'
+ $P0 = get_hll_global ['bit'], 'BIT_MAX'
BIT_MAX = $P0
$I1 = lua_checknumber(1, .a)
band $I1, BIT_MAX
@@ -169,7 +169,7 @@
.macro ARITHMETIC_SHIFT(op, a, b)
.local pmc res
.local int BIT_MAX
- $P0 = get_hll_global ['Lua'; 'bit'], 'BIT_MAX'
+ $P0 = get_hll_global ['bit'], 'BIT_MAX'
BIT_MAX = $P0
$I1 = lua_checknumber(1, .a)
$I2 = lua_checknumber(2, .b)
Modified: branches/pdd13pbc/languages/lua/src/lib/gl.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/gl.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/gl.pir Wed Aug 6 21:12:12 2008
@@ -19,7 +19,7 @@
=cut
.HLL 'Lua', 'lua_group'
-.namespace [ 'Lua'; 'gl' ]
+.namespace [ 'gl' ]
.sub '__onload' :anon :load
# print "__onload gl\n"
@@ -738,7 +738,7 @@
_gl[$P1] = _gl_Viewport
$P0 = _gl_str()
- set_hll_global ['Lua'; 'gl'], 'gl_str', $P0
+ set_hll_global ['gl'], 'gl_str', $P0
.return (_gl)
.end
@@ -1340,7 +1340,7 @@
.sub 'get_gl_enum' :anon
.param string str
.local pmc gl_str
- gl_str = get_hll_global ['Lua'; 'gl'], 'gl_str'
+ gl_str = get_hll_global ['gl'], 'gl_str'
.local int ret
ret = 0
$P0 = split ',', str
@@ -1362,7 +1362,7 @@
.sub 'get_str_gl_enum' :anon
.param int enum
.local pmc gl_str
- gl_str = get_hll_global ['Lua'; 'gl'], 'gl_str'
+ gl_str = get_hll_global ['gl'], 'gl_str'
new $P0, 'Iterator', gl_str
L1:
unless $P0 goto L2
Modified: branches/pdd13pbc/languages/lua/src/lib/glut.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/glut.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/glut.pir Wed Aug 6 21:12:12 2008
@@ -19,7 +19,7 @@
=cut
.HLL 'Lua', 'lua_group'
-.namespace [ 'Lua'; 'glut' ]
+.namespace [ 'glut' ]
.sub '__onload' :anon :load
# print "__onload glut\n"
Modified: branches/pdd13pbc/languages/lua/src/lib/lfs.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/lfs.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/lfs.pir Wed Aug 6 21:12:12 2008
@@ -22,7 +22,7 @@
=cut
.HLL 'Lua', 'lua_group'
-.namespace [ 'Lua'; 'lfs' ]
+.namespace [ 'lfs' ]
.sub '__onload' :anon :load
# print "__onload lfs\n"
Modified: branches/pdd13pbc/languages/lua/src/lib/luafile.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/luafile.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/luafile.pir Wed Aug 6 21:12:12 2008
@@ -74,6 +74,11 @@
set $P1, '__tostring'
_file[$P1] = _file__tostring
+ $P0 = get_hll_namespace ['io']
+ $P1 = get_namespace
+ $P2 = split ' ', 'aux_close aux_lines read_chars read_number read_line
test_eof tofile tofilep'
+ $P0.'export_to'($P1, $P2)
+
.return (_file)
.end
@@ -88,10 +93,8 @@
.sub 'close' :method :anon
.param pmc extra :slurpy
.local pmc res
- $P0 = get_hll_global ['io'], 'tofile'
- $P0(self)
- $P0 = get_hll_global ['io'], 'aux_close'
- (res :slurpy) = $P0(self)
+ tofile(self)
+ (res :slurpy) = aux_close(self)
.return (res :flat)
.end
@@ -106,8 +109,7 @@
.param pmc extra :slurpy
.local pmc f
.local pmc res
- $P0 = get_hll_global ['io'], 'tofile'
- f = $P0(self)
+ f = tofile(self)
f.'flush'()
new res, 'LuaBoolean'
set res, 1
@@ -129,10 +131,8 @@
.sub 'lines' :method :anon
.param pmc extra :slurpy
- $P0 = get_hll_global ['io'], 'tofile'
- $P0(self)
- $P0 = get_hll_global ['io'], 'aux_lines'
- .return $P0(self, 0)
+ tofile(self)
+ .return aux_lines(self, 0)
.end
@@ -177,12 +177,10 @@
.param pmc formats :slurpy
.local pmc res
.local pmc f
- $P0 = get_hll_global ['io'], 'tofile'
- $P0(self)
+ tofile(self)
f = getattribute self, 'data'
if formats goto L1
- $P0 = get_hll_global ['io'], 'read_line'
- .return $P0(f)
+ .return read_line(f)
L1:
.local int narg
.local int i
@@ -199,13 +197,11 @@
.local int l
l = format
unless l == 0 goto L5
- $P0 = get_hll_global ['io'], 'test_eof'
- $P0 = $P0(f)
+ $P0 = test_eof(f)
res[i] = $P0
goto L6
L5:
- $P0 = get_hll_global ['io'], 'read_chars'
- $P0 = $P0(f, l)
+ $P0 = read_chars(f, l)
res[i] = $P0
goto L6
L4:
@@ -213,24 +209,21 @@
$I0 = index $S0, '*n'
unless $I0 == 0 goto L7
# number
- $P0 = get_hll_global ['io'], 'read_number'
- $P0 = $P0(f)
+ $P0 = read_number(f)
res[i] = $P0
goto L6
L7:
$I0 = index $S0, '*l'
unless $I0 == 0 goto L8
# line
- $P0 = get_hll_global ['io'], 'read_line'
- $P0 = $P0(f)
+ $P0 = read_line(f)
res[i] = $P0
goto L6
L8:
$I0 = index $S0, '*a'
unless $I0 == 0 goto L9
# file
- $P0 = get_hll_global ['io'], 'read_chars'
- $P0 = $P0(f, 65535)
+ $P0 = read_chars(f, 65535)
res[i] = $P0
goto L6
L9:
@@ -284,8 +277,7 @@
.param pmc extra :slurpy
.local pmc f
.local pmc res
- $P0 = get_hll_global ['io'], 'tofile'
- $P0(self)
+ tofile(self)
$S1 = lua_optstring(1, whence, 'cur')
$I1 = lua_checkoption(1, $S1, 'set cur end')
$I2 = lua_optint(2, offset, 0)
@@ -334,8 +326,7 @@
.local pmc mode
.local pmc f
.local pmc res
- $P0 = get_hll_global ['io'], 'tofile'
- $P0(self)
+ tofile(self)
$S1 = lua_checkstring(1, mode)
$I1 = lua_checkoption(1, $S1, 'no full line')
$I2 = lua_optint(2, size, 512) # LUAL_BUFFERSIZE
@@ -371,8 +362,7 @@
.local int argc
.local int i
.local pmc f
- $P0 = get_hll_global ['io'], 'tofile'
- $P0(self)
+ tofile(self)
f = getattribute self, 'data'
argc = argv
i = 0
@@ -397,12 +387,10 @@
.sub '__gc' :method :anon
.local pmc f
- $P0 = get_hll_global ['io'], 'tofilep'
- f = $P0(self)
+ f = tofilep(self)
# ignore closed files
if null f goto L1
- $P0 = get_hll_global ['io'], 'aux_close'
- $P0(self)
+ aux_close(self)
L1:
.return ()
.end
@@ -411,8 +399,7 @@
.sub '__tostring' :method :anon
.local pmc f
.local pmc res
- $P0 = get_hll_global ['io'], 'tofilep'
- f = $P0(self)
+ f = tofilep(self)
new res, 'LuaString'
if f goto L1
$S0 = "file (closed)"
Modified: branches/pdd13pbc/languages/lua/src/lib/luaio.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/luaio.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/luaio.pir Wed Aug 6 21:12:12 2008
@@ -39,10 +39,6 @@
.sub 'luaopen_io'
# print "init Lua I/O\n"
- .local pmc _file
- $P0 = get_hll_global ['io'; 'file'], 'createmeta'
- _file = $P0()
-
# create (private) environment (with fields IO_INPUT, IO_OUTPUT, __close)
.local pmc _io_env
.const .Sub _io_fclose = 'fclose'
@@ -117,6 +113,14 @@
.const .Sub _readline = 'readline'
_readline.'setfenv'(_io_env)
+ $P0 = get_hll_namespace ['io'; 'file']
+ $P1 = get_namespace
+ $P2 = split ' ', 'createmeta'
+ $P0.'export_to'($P1, $P2)
+
+ .local pmc _file
+ _file = createmeta()
+
# create (and set) default files
createstdfiles(_file, _io, _io_env)
Modified: branches/pdd13pbc/languages/lua/src/lib/md5.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/md5.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/md5.pir Wed Aug 6 21:12:12 2008
@@ -19,7 +19,7 @@
=cut
.HLL 'Lua', 'lua_group'
-.namespace [ 'Lua'; 'md5' ]
+.namespace [ 'md5' ]
.sub '__onload' :anon :load
# print "__onload md5\n"
Modified: branches/pdd13pbc/languages/lua/src/lib/random.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/random.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/random.pir Wed Aug 6 21:12:12 2008
@@ -19,7 +19,7 @@
=cut
.HLL 'Lua', 'lua_group'
-.namespace [ 'Lua'; 'random' ]
+.namespace [ 'random' ]
.sub '__onload' :anon :load
# print "__onload random\n"
Modified: branches/pdd13pbc/languages/lua/src/lib/uuid.pir
==============================================================================
--- branches/pdd13pbc/languages/lua/src/lib/uuid.pir (original)
+++ branches/pdd13pbc/languages/lua/src/lib/uuid.pir Wed Aug 6 21:12:12 2008
@@ -18,7 +18,7 @@
=cut
.HLL 'Lua', 'lua_group'
-.namespace [ 'Lua'; 'uuid' ]
+.namespace [ 'uuid' ]
.sub '__onload' :anon :load
# print "__onload uuid\n"
@@ -73,6 +73,11 @@
# set $P1, "_VERSION"
# _uuid[$P1] = $P2
+ $P0 = get_hll_namespace ['uuid']
+ $P1 = get_namespace
+ $P2 = split ' ', 'generate generate_random generate_time parse'
+ $P0.'export_to'($P1, $P2)
+
.return (_uuid)
.end
@@ -88,19 +93,17 @@
$S1 = lua_optstring(1, str, '')
$I0 = index $S1, 'r'
unless $I0 == 0 goto L1
- $S0 = 'generate_random'
+ $P0 = generate_random()
goto L3
L1:
$I0 = index $S1, 't'
unless $I0 == 0 goto L2
- $S0 = 'generate_time'
+ $P0 = generate_time()
goto L3
L2:
- $S0 = 'generate'
+ $P0 = generate()
L3:
- $P0 = get_hll_global ['uuid'], $S0
- $P1 = $P0()
- $S0 = $P1
+ $S0 = $P0
new res, 'LuaString'
set res, $S0
.return (res)
@@ -116,8 +119,7 @@
.param pmc extra :slurpy
.local pmc res
$S1 = lua_checkstring(1, str)
- $P0 = get_hll_global ['uuid'], 'parse'
- $I0 = $P0($S1)
+ $I0 = parse($S1)
not $I0
new res, 'LuaBoolean'
set res, $I0
@@ -133,8 +135,7 @@
.param pmc str :optional
.param pmc extra :slurpy
$S1 = lua_checkstring(1, str)
- $P0 = get_hll_global ['uuid'], 'parse'
- ($I0, $P1) = $P0($S1)
+ ($I0, $P1) = parse($S1)
unless $I0 goto L1
.return ()
L1:
Modified: branches/pdd13pbc/languages/perl6/src/pmc/perl6multisub.pmc
==============================================================================
--- branches/pdd13pbc/languages/perl6/src/pmc/perl6multisub.pmc (original)
+++ branches/pdd13pbc/languages/perl6/src/pmc/perl6multisub.pmc Wed Aug 6
21:12:12 2008
@@ -11,19 +11,374 @@
Subclass of MultiSub that overrides invoke to implement the Perl 6 multiple
dispatch algorithm, along with providing various other pieces.
-=head2 Methods
+Since we need to store some extra information, we cannot just actually be
+a ResizablePMCArray, but rather we need to have one.
+
+=head1 TODO
+
+This is a list of things that I need to deal with/come back and worry about
+later (it's not a complete todo list for finishing up the PMC itself, just
+of fixup tasks in what is already done).
+
+=over 4
+
+=item Use Perl 6 types when boxing native arguments in the arg list
+
+=item Fix pmc2c so we can have ATTR candidate_info **candidates_sorted. We
+will have to move them to their own .h file, but in pmc2c we need to be able
+to include that *before* this PMC's generated .h file (I couldn't work out
+how to do that) and also make it parse double indirections. Then we can toss
+any (candidate_info**) casts.
+
+=item Make sure we override everything that ResizablePMCArray and its parents
+would provide us with. Otherwise, we'll just get segfaults 'cus we don't store
+stuff the way it does.
+
+=back
+
+=head1 INTERNAL STRUCTURES
+
+We have some structures that we use to keep data around internally.
+
+=over 4
+
+=item candidate_info
+
+Represents a candidate. We extract various bits of information about it when
+we are building the sorted candidate list and store them in here for fast
+access during a dispatch.
+
+*/
+
+#include "parrot/oplib/ops.h"
+
+
+typedef struct candidate_info {
+ PMC *sub; /* The sub that is the candidate. */
+ INTVAL arity; /* The number of required arguments. */
+ PMC *type_cons; /* Any class or role type constraints. */
+ PMC *refinement_cons; /* Any refinement type constraints (C<subset>). */
+} candidate_info;
+
+/*
+
+=back
+
+=head1 FUNCTIONS
+
+These are worker functions used by the methods of the PMC, and not visible
+from the outside.
+
+=over 4
+
+=item C<static PMC* get_args()>
+
+Gets a list of the arguments that are being passed, taking them from the
+registers and the constants table and flattening any :flat arguments as
+required. Returns a ResizablePMCArray of them.
+
+=cut
+
+*/
+
+PARROT_WARN_UNUSED_RESULT
+PARROT_CANNOT_RETURN_NULL
+static PMC*
+get_args(PARROT_INTERP)
+{
+ INTVAL sig_len, i;
+ PMC *arg;
+ PMC *sig;
+
+ /* Initialize results list. */
+ PMC * const arg_list = pmc_new(interp,
enum_class_ResizablePMCArray);
+
+ /* Get constants table for current segment, so we can look up sig and any
+ * constant arguments. */
+ PackFile_Constant **constants = interp->code->const_table->constants;
+
+ /* Make sure we have a place to source the current arguments from. */
+ opcode_t *args_op = interp->current_args;
+ if (!args_op)
+ Parrot_ex_throw_from_c_args(interp, NULL, 1,
+ "No arguments found to dispatch on");
+ PARROT_ASSERT(*args_op == PARROT_OP_set_args_pc);
+
+ /* Get the (Parrot calling conventions) signature PMC. */
+ ++args_op;
+ sig = constants[*args_op]->u.key;
+ ASSERT_SIG_PMC(sig);
+ sig_len = SIG_ELEMS(sig);
+
+ /* If we have a zero-length signature, we're done. */
+ if (sig_len == 0)
+ return arg_list;
+
+ /* Otherwise, we have arguments. */
+ ++args_op;
+ for (i = 0; i < sig_len; ++i, ++args_op) {
+ INTVAL type = SIG_ITEM(sig, i);
+ const int idx = *args_op;
+
+ /* If we find a named argument, then we know there's no more positional
+ * arguments, since they come before named. And we don't dispatch on
+ * named arguments. */
+ if (type & PARROT_ARG_NAME)
+ break;
+
+ /* Put the argument in the list. For some arguments, we must box them
into
+ * a PMC to be able to have them in the list. XXX Use Perl 6 box
types. */
+ switch (type & (PARROT_ARG_TYPE_MASK | PARROT_ARG_FLATTEN)) {
+ case PARROT_ARG_INTVAL:
+ /* Integer constants always in register. */
+ arg = pmc_new(interp, enum_class_Integer);
+ VTABLE_set_integer_native(interp, arg, REG_INT(interp, idx));
+ VTABLE_push_pmc(interp, arg_list, arg);
+ break;
+ case PARROT_ARG_FLOATVAL:
+ /* May have value in an N register or constants table. */
+ arg = pmc_new(interp, enum_class_Float);
+ if ((type & PARROT_ARG_CONSTANT))
+ VTABLE_set_number_native(interp, arg,
constants[idx]->u.number);
+ else
+ VTABLE_set_number_native(interp, arg, REG_NUM(interp,
idx));
+ VTABLE_push_pmc(interp, arg_list, arg);
+ break;
+ case PARROT_ARG_STRING:
+ /* May have value in an S register or constnats table. */
+ arg = pmc_new(interp, enum_class_String);
+ if ((type & PARROT_ARG_CONSTANT))
+ VTABLE_set_string_native(interp, arg,
constants[idx]->u.string);
+ else
+ VTABLE_set_string_native(interp, arg, REG_STR(interp,
idx));
+ VTABLE_push_pmc(interp, arg_list, arg);
+ break;
+ case PARROT_ARG_PMC:
+ /* May have value in a P register or constants table. */
+ if ((type & PARROT_ARG_CONSTANT))
+ arg = constants[idx]->u.key;
+ else
+ arg = REG_PMC(interp, idx);
+ VTABLE_push_pmc(interp, arg_list, arg);
+ break;
+ case PARROT_ARG_FLATTEN | PARROT_ARG_PMC: {
+ /* Expand flattening arguments; just loop over the array that
+ * is being flattened and get all of the entries within it. */
+ int j, n;
+ const int idx = *args_op;
+ arg = REG_PMC(interp, idx);
+ n = VTABLE_elements(interp, arg);
+ for (j = 0; j < n; ++j)
+ VTABLE_push_pmc(interp, arg_list,
+ VTABLE_get_pmc_keyed_int(interp, arg, j));
+ break;
+ }
+ default:
+ Parrot_ex_throw_from_c_args(interp, NULL, 1,
+ "Unknown signature type %d in
Parrot_Perl6MultiSub_get_args", type);
+ break;
+ }
+ }
+
+ return arg_list;
+}
+
+/*
+
+=item C<static candidate_info** sort_candidiates(PMC *candidates)>
+
+Takes a ResizablePMCArray of the candidates, collects information about them
+and then does a topological sort of them.
+
+*/
+static candidate_info** sort_candidiates(PARROT_INTERP, PMC *candidates) {
+ candidate_info** result = mem_sys_allocate_zeroed(2 * sizeof
(candidate_info*));
+ return result;
+}
+
+/*
+
+=item C<static PMC* do_dispatch(candidate_info** candidates, int many)>
+
+Runs the Perl 6 MMD algorithm. If many is set to a true value, returns a
+ResizablePMCArray of all possible candidates, which may be empty. If many
+is set to a false value, then returns either the one winning unambiguous
+candidate or throws an error saying that the dispatch failed if there were
+no candidates or that it was ambiguous if there were tied candidates.
+
+*/
+
+static PMC* do_dispatch(PARROT_INTERP, candidate_info** candidates, int many) {
+ Parrot_ex_throw_from_c_args(interp, NULL, 1, "Unimplemented.");
+ return PMCNULL;
+}
+
+/*
+
+=item C<static int assert_invokable(PARROT_INTERP, PMC *value)>
+
+Checks if a PMC is invokable; returns a true value if so and a false value if
+not.
+
+*/
+static int check_invokable(PARROT_INTERP, PMC *value) {
+ STRING * const _sub = CONST_STRING(interp, "Sub");
+ STRING * const _nci = CONST_STRING(interp, "NCI");
+ return VTABLE_isa(interp, value, _sub) || VTABLE_isa(interp, value, _nci);
+}
+
+/*
+
+=back
+
+=head1 ATTRIBUTES
+
+=over 4
+
+=item candidates
+
+Unsorted list of all candidates.
+
+=item candidates_sorted
+
+C array of canididate_info structures. It stores a sequence of candidates
+length one or greater that are tied, followed by a NULL, followed by the next
+bunch that are less narrow but tied and so forth. It is terminated by a double
+NULL.
+
+=back
+
+=head1 METHODS
+
+=over 4
=cut
*/
-#include "parrot/parrot.h"
pmclass Perl6MultiSub extends MultiSub need_ext dynpmc group perl6_group {
+ ATTR PMC *candidates;
+ ATTR void *candidates_sorted;
+
+/*
+
+=item VTABLE void init()
+
+Allocates the PMC's underlying storage.
+
+=cut
+*/
+ VTABLE void init() {
+ /* Allocate the underlying struct and make candidate list an empty
+ * ResizablePMCArray. */
+ PMC *candidates = pmc_new(interp, enum_class_ResizablePMCArray);
+ PMC_data(SELF) = mem_allocate_zeroed_typed(Parrot_Perl6MultiSub);
+ SETATTR_Perl6MultiSub_candidates(interp, SELF, candidates)
+
+ /* Need custom mark and destroy. */
+ PObj_custom_mark_SET(SELF);
+ PObj_active_destroy_SET(SELF);
+ }
+
+/*
+
+=item VTABLE void destroy()
+
+Frees the memory associated with this PMC's underlying storage.
+
+=cut
+
+*/
+ VTABLE void destroy() {
+ mem_sys_free(PMC_data(SELF));
+ PMC_data(SELF) = NULL;
+ }
+
+/*
+
+=item VTABLE opcode_t invoke()
+
+Does a dispatch to the best candidate with the current arguments, according to
+the Perl 6 MMD algorithm.
+
+=cut
+
+*/
+ VTABLE opcode_t* invoke(void* next) {
+ PMC *found;
+
+ /* Make sure that we have a candidate list built. */
+ candidate_info **candidates = NULL;
+ GETATTR_Perl6MultiSub_candidates_sorted(interp, SELF, candidates);
+ if (!candidates) {
+ PMC *unsorted;
+ GETATTR_Perl6MultiSub_candidates(interp, SELF, unsorted);
+ candidates = sort_candidiates(interp, unsorted);
+ SETATTR_Perl6MultiSub_candidates_sorted(interp, SELF, candidates);
+ }
+ if (!candidates)
+ Parrot_ex_throw_from_c_args(interp, next, 1, "Failed to build
candidate list");
+
+ /* Now do the dispatch - if it can't find anything, it will throw the
required
+ * exceptions. */
+ found = do_dispatch(interp, candidates, 0);
+
+ /* Invoke what was found. */
+ return VTABLE_invoke(interp, found, next);
+ }
+
+/*
+
+=item VTABLE void push_pmc(PMC *sub)
+
+Adds a new candidate to the candidate list.
+
+=cut
+
+*/
+ VTABLE void push_pmc(PMC *sub) {
+ PMC *candidates;
+
+ /* Make sure it's invokable. */
+ if (!check_invokable(interp, sub))
+ Parrot_ex_throw_from_c_args(interp, NULL,
EXCEPTION_INVALID_OPERATION,
+ "Cannot add non-Sub PMC to a MultiSub.");
+
+ /* Add it to the candidates list. */
+ GETATTR_Perl6MultiSub_candidates(interp, SELF, candidates);
+ VTABLE_push_pmc(interp, candidates, sub);
+
+ /* Invalidate the sorted list - we'll need to re-build it. */
+ SETATTR_Perl6MultiSub_candidates_sorted(interp, SELF, NULL);
+ }
+
+/*
+
+=item VTABLE INTVAL elements()
+
+Gets the number of candidate on the candidate list.
+
+=cut
+
+*/
+ VTABLE INTVAL elements() {
+ PMC *candidates;
+ GETATTR_Perl6MultiSub_candidates(interp, SELF, candidates);
+ return VTABLE_elements(interp, candidates);
+ }
}
/*
+
+=back
+
+=cut
+
+*/
+
+/*
* Local variables:
* c-file-style: "parrot"
* End:
Modified: branches/pdd13pbc/languages/perl6/t/pmc/perl6multisub-basic.t
==============================================================================
--- branches/pdd13pbc/languages/perl6/t/pmc/perl6multisub-basic.t
(original)
+++ branches/pdd13pbc/languages/perl6/t/pmc/perl6multisub-basic.t Wed Aug
6 21:12:12 2008
@@ -22,9 +22,10 @@
.include 'include/test_more.pir'
load_bytecode "perl6.pbc"
- plan(1)
+ plan(4)
'instantiate'()
+ 'push_and_elements'()
.end
@@ -36,6 +37,37 @@
.end
+.sub 'push_and_elements'
+ # Make sure we can push subs onto the multi-sub.
+ $P0 = new "Perl6MultiSub"
+ $P1 = find_name 'push_test1'
+ push $P0, $P1
+ $I0 = elements $P0
+ is($I0, 1, "added one sub")
+ $P1 = find_name 'push_test2'
+ push $P0, $P1
+ $I0 = elements $P0
+ is($I0, 2, "added two subs")
+
+ # Make sure pushing a non-invokable dies.
+ $P1 = new 'Integer'
+ $I0 = 0
+ push_eh fails_ok
+ push $P0, $P1
+ goto done
+ fails_ok:
+ $I0 = 1
+ done:
+ is($I0, 1, "cannot push a non-invokable")
+.end
+.sub push_test1
+ .return (1)
+.end
+.sub push_test2
+ .param pmc x
+ .return (2)
+.end
+
# Local Variables:
# mode: pir
# fill-column: 100
Modified: branches/pdd13pbc/src/pmc.c
==============================================================================
--- branches/pdd13pbc/src/pmc.c (original)
+++ branches/pdd13pbc/src/pmc.c Wed Aug 6 21:12:12 2008
@@ -608,7 +608,7 @@
=item C<void dod_register_pmc>
-Registers the PMC with the interpreter's DOD registery.
+Registers the PMC with the interpreter's DOD registry.
=cut
Modified: branches/pdd13pbc/src/stm/backend.c
==============================================================================
--- branches/pdd13pbc/src/stm/backend.c (original)
+++ branches/pdd13pbc/src/stm/backend.c Wed Aug 6 21:12:12 2008
@@ -193,7 +193,7 @@
=item C<void Parrot_STM_destroy>
-Free all resources associated with STM in the interpreter C<interp>.
+Frees all resources associated with STM in the interpreter C<interp>.
=cut
@@ -220,7 +220,7 @@
=item C<Parrot_STM_PMC_handle Parrot_STM_alloc>
-Create a new handle that will wrap a STM-managed PMC. The initial value
+Creates a new handle that will wrap an STM-managed PMC. The initial value
of the PMC will be a copy of C<pmc>.
=cut
@@ -264,7 +264,7 @@
=item C<void Parrot_freeze_STM_PMC_handle>
-RT#48260: Not yet documented!!!
+Freezes an STM PMC by calling the "push_pmc" vtable method.
=cut
@@ -281,7 +281,7 @@
=item C<Parrot_STM_PMC_handle Parrot_thaw_STM_PMC_handle>
-RT#48260: Not yet documented!!!
+Thaws an STM PMC by calling the "shift_pmc" vtable method.
=cut
@@ -299,7 +299,7 @@
=item C<static STM_write_record * get_write>
-RT#48260: Not yet documented!!!
+Retrieves the C<i>th write from C<log>.
=cut
@@ -319,7 +319,7 @@
=item C<static STM_read_record * get_read>
-RT#48260: Not yet documented!!!
+Retreives the C<i>th read from C<log>.
=cut
@@ -345,7 +345,7 @@
=item C<static STM_write_record * alloc_write>
-RT#48260: Not yet documented!!!
+Allocates a new STM write in C<log>.
=cut
@@ -375,7 +375,7 @@
=item C<static STM_read_record * alloc_read>
-RT#48260: Not yet documented!!!
+Allocates a new STM read in C<log>.
=cut
@@ -443,7 +443,7 @@
=item C<static STM_tx_log_sub * get_sublog>
-RT#48260: Not yet documented!!!
+Retrives the C<i>th sublog from C<log>.
=cut
@@ -463,7 +463,9 @@
=item C<static int is_aborted>
-RT#48260: Not yet documented!!!
+Determines whether any of the sublogs in C<log> are aborted. Checks the
+status of each sublog to determine if any have a status of
+C<STM_STATUS_ABORTED>.
=cut
@@ -624,7 +626,8 @@
=item C<static PMC * force_sharing>
-RT#48260: Not yet documented!!!
+Creates a read-only shared PMC from C<pmc> by calling the C<share_ro>
+vtable method. If C<pmc> is null, returns C<PMCNULL>.
=cut
@@ -1215,7 +1218,7 @@
STM_TRACE_SAFE("mark handle %p", handle);
- /* XXX FIXME is this enough? What about shared status? */
+ /* RT#57676: XXX FIXME is this enough? What about shared status? */
pobject_lives(interp, (PObj*) handle);
value = handle->value;
@@ -1293,6 +1296,7 @@
* this means that if wait_len > num_threads, we have a deadlock
*
* This algorithm is borrowed from Ennals' implementation.
+ * RT#57678
* FIXME XXX look for better alternative (esp. one that'll let
* us do non-spinlocking?)
* FIXME XXX race in accessing n_interpreters?
@@ -1344,7 +1348,8 @@
}
/* simple heuristic, try to avoid waiting more then ten milliseconds */
- /* TODO implement a real contention-manager interface for this instead
*/
+ /* RT#57678 TODO implement a real contention-manager interface
+ for this instead */
if (wait_count > 2000 || Parrot_floatval_time() > start_wait + 0.01) {
STM_TRACE("waited too long, aborting...\n");
PARROT_ATOMIC_INT_SET(curlog->status, STM_STATUS_ABORTED);
@@ -1362,7 +1367,7 @@
* while. */
YIELD;
}
- /* XXX better spinning */
+ /* RT#57678 XXX better spinning */
}
PROFILE_WAIT(log, Parrot_floatval_time() - start_wait, wait_count);
@@ -1458,7 +1463,8 @@
=item C<static int safe_to_clone>
-RT#48260: Not yet documented!!!
+Determines whether it is safe to clone the PMC C<original>. Returns C<1> if
+it is safe to clone it, returns C<0> otherwise.
=cut
@@ -1481,7 +1487,9 @@
=item C<static PMC * local_pmc_copy>
-RT#48260: Not yet documented!!!
+Creates a local copy of the PMC C<original>. If C<original> is C<PMCNULL>
+this function returns C<PMCNULL>. If the PMC is of type C<Undef>, it creates
+a new Undef PMC. Otherwise, it clones the PMC.
=cut
@@ -1523,7 +1531,7 @@
static STM_write_record *
find_write_record(PARROT_INTERP, Parrot_STM_PMC_handle handle, int overwrite_p)
{
- /* FIXME check for read log or previous tx's write log */
+ /* RT#57680 FIXME check for read log or previous tx's write log */
STM_tx_log_sub *cursub;
int have_old_value = 0;
PMC *old_value = NULL;
@@ -1535,7 +1543,7 @@
STM_TRACE("finding write record for %p", handle);
- /* XXX Looks like the log argument is useless */
+ /* RT#57680 XXX Looks like the log argument is useless */
log = Parrot_STM_tx_log_get(interp);
PARROT_ASSERT(log->depth > 0);
@@ -1628,8 +1636,8 @@
else {
STM_TRACE("don't have old value");
/* avoiding creating write records when we are actually aborted
- * XXX in the future we will do this by throwing an exception to
- * abort the transaction
+ * RT#57680 XXX in the future we will do this by throwing an
+ * exception to abort the transaction
*/
if (!is_aborted(log)) {
do {
@@ -1906,7 +1914,8 @@
=item C<void Parrot_STM_merge_profile>
-RT#48260: Not yet documented!!!
+Merges the STM profile of interpreter C<s> into the STM profile of
+interpreter C<d>.
=cut
Modified: branches/pdd13pbc/src/string.c
==============================================================================
--- branches/pdd13pbc/src/string.c (original)
+++ branches/pdd13pbc/src/string.c Wed Aug 6 21:12:12 2008
@@ -1937,45 +1937,49 @@
PARROT_API
PARROT_WARN_UNUSED_RESULT
INTVAL
-string_to_int(SHIM_INTERP, ARGIN(const STRING *s))
+string_to_int(SHIM_INTERP, ARGIN_NULLOK(const STRING *s))
{
- const char *start = s->strstart;
- const char * const end = start + s->bufused;
- int sign = 1;
- INTVAL in_number = 0;
- INTVAL i = 0;
+ if (s == NULL)
+ return 0;
+ {
+ const char *start = s->strstart;
+ const char * const end = start + s->bufused;
+ int sign = 1;
+ INTVAL in_number = 0;
+ INTVAL i = 0;
- PARROT_ASSERT(s);
+ PARROT_ASSERT(s);
- while (start < end) {
- const unsigned char c = *start;
+ while (start < end) {
+ const unsigned char c = *start;
- if (isdigit((unsigned char)c)) {
- in_number = 1;
- i = i * 10 + (c - '0');
- }
- else if (!in_number) {
- /* we've not yet seen any digits */
- if (c == '-') {
- sign = -1;
+ if (isdigit((unsigned char)c)) {
in_number = 1;
+ i = i * 10 + (c - '0');
}
- else if (c == '+')
- in_number = 1;
- else if (isspace((unsigned char)c))
- ;
- else
+ else if (!in_number) {
+ /* we've not yet seen any digits */
+ if (c == '-') {
+ sign = -1;
+ in_number = 1;
+ }
+ else if (c == '+')
+ in_number = 1;
+ else if (isspace((unsigned char)c))
+ ;
+ else
+ break;
+ }
+ else {
break;
+ }
+ ++start;
}
- else {
- break;
- }
- ++start;
- }
- i *= sign;
+ i *= sign;
- return i;
+ return i;
+ }
}
Modified: branches/pdd13pbc/t/codingstd/filenames.t
==============================================================================
--- branches/pdd13pbc/t/codingstd/filenames.t (original)
+++ branches/pdd13pbc/t/codingstd/filenames.t Wed Aug 6 21:12:12 2008
@@ -60,7 +60,13 @@
my $DIST = Parrot::Distribution->new;
my $manifest = maniread('MANIFEST');
-my @files = @ARGV ? @ARGV : sort keys %$manifest;
+my @files;
+if (@ARGV){
+ @files = @ARGV;
+} else {
+ # Give ports a little more leeway
+ @files = grep {! /^ports/} sort keys %$manifest;
+}
my ( @multi_dots, @strange_chars, @too_long );
foreach my $file ( @files ) {
