[svn:parrot] r41972 - in trunk: . compilers/imcc config/auto config/gen config/gen/makefiles include/parrot lib/Parrot/Pmc2c lib/Parrot/Pmc2c/PMC runtime/parrot/include runtime/parrot/library/Test src src/call src/interp src/ops src/pmc t/codingstd t/oo t/op t/pmc t/src tools/build
allison at svn.parrot.org
allison at svn.parrot.org
Wed Oct 21 16:54:22 UTC 2009
Author: allison
Date: Wed Oct 21 16:54:18 2009
New Revision: 41972
URL: https://trac.parrot.org/parrot/changeset/41972
Log:
[pcc] Merging the pcc_reapply branch into trunk. Reworks the internals of the
calling conventions so all call paths use a CallSignature object for passing
arguments and return values.
Modified:
trunk/MANIFEST
trunk/compilers/imcc/pbc.c
trunk/config/auto/frames.pm
trunk/config/gen/makefiles/root.in
trunk/config/gen/opengl.pm
trunk/include/parrot/call.h
trunk/include/parrot/context.h
trunk/include/parrot/extend.h
trunk/include/parrot/interpreter.h
trunk/include/parrot/multidispatch.h
trunk/lib/Parrot/Pmc2c/Method.pm
trunk/lib/Parrot/Pmc2c/PCCMETHOD.pm
trunk/lib/Parrot/Pmc2c/PMC/Object.pm
trunk/runtime/parrot/include/test_more.pir
trunk/runtime/parrot/library/Test/More.pir
trunk/src/call/context.c
trunk/src/call/ops.c
trunk/src/call/pcc.c
trunk/src/debug.c
trunk/src/embed.c
trunk/src/events.c
trunk/src/exceptions.c
trunk/src/extend.c
trunk/src/frame_builder.c
trunk/src/frame_builder.h
trunk/src/hash.c
trunk/src/interp/inter_cb.c
trunk/src/library.c
trunk/src/multidispatch.c
trunk/src/nci_test.c
trunk/src/ops/core.ops
trunk/src/ops/object.ops
trunk/src/packfile.c
trunk/src/pmc/callsignature.pmc
trunk/src/pmc/capture.pmc
trunk/src/pmc/class.pmc
trunk/src/pmc/context.pmc
trunk/src/pmc/continuation.pmc
trunk/src/pmc/cpointer.pmc
trunk/src/pmc/exception.pmc
trunk/src/pmc/multisub.pmc
trunk/src/pmc/nci.pmc
trunk/src/pmc/object.pmc
trunk/src/pmc/parrotinterpreter.pmc
trunk/src/pmc/retcontinuation.pmc
trunk/src/pmc/role.pmc
trunk/src/pmc/sub.pmc
trunk/src/scheduler.c
trunk/src/sub.c
trunk/src/thread.c
trunk/src/utils.c
trunk/t/codingstd/c_function_docs.t
trunk/t/codingstd/c_parens.t
trunk/t/oo/metamodel.t
trunk/t/op/annotate.t
trunk/t/op/calling.t
trunk/t/op/cc_params.t
trunk/t/op/cc_state.t
trunk/t/op/gc.t
trunk/t/pmc/callsignature.t
trunk/t/pmc/capture.t
trunk/t/pmc/fixedbooleanarray.t
trunk/t/pmc/fixedpmcarray.t
trunk/t/pmc/fixedstringarray.t
trunk/t/pmc/float.t
trunk/t/pmc/integer.t
trunk/t/pmc/multidispatch.t
trunk/t/pmc/namespace.t
trunk/t/pmc/parrotobject.t
trunk/t/pmc/resizablefloatarray.t
trunk/t/pmc/resizablestringarray.t
trunk/t/pmc/sub.t
trunk/t/pmc/threads.t
trunk/t/src/extend.t
trunk/tools/build/nativecall.pl
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/MANIFEST Wed Oct 21 16:54:18 2009 (r41972)
@@ -1243,6 +1243,7 @@
src/atomic/gcc_x86.c []
src/atomic/sparc_v9.s []
src/byteorder.c []
+src/call/args.c []
src/call/context.c []
src/call/ops.c []
src/call/pcc.c []
Modified: trunk/compilers/imcc/pbc.c
==============================================================================
--- trunk/compilers/imcc/pbc.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/compilers/imcc/pbc.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -1125,9 +1125,8 @@
"add lexical '%s' to sub name '%Ss'\n",
n->name, sub->name);
- Parrot_PCCINVOKE(interp, lex_info,
- string_from_literal(interp, "declare_lex_preg"),
- "SI->", lex_name, r->color);
+ VTABLE_set_integer_keyed_str(interp, lex_info,
+ lex_name, r->color);
/* next possible name */
n = n->reg;
Modified: trunk/config/auto/frames.pm
==============================================================================
--- trunk/config/auto/frames.pm Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/config/auto/frames.pm Wed Oct 21 16:54:18 2009 (r41972)
@@ -40,6 +40,7 @@
sub _call_frames_buildable {
my $conf = shift;
+
my $osname = $conf->data->get('osname');
my $cpuarch = $conf->data->get('cpuarch');
my $nvsize = $conf->data->get('nvsize');
@@ -49,8 +50,10 @@
$can_build_call_frames = $conf->options->get('buildframes');
}
else {
- $can_build_call_frames = ($nvsize == 8 && $cpuarch eq 'i386'
- && $osname ne 'darwin');
+ # Temporary disable build frames automatically.
+ #$can_build_call_frames = ($nvsize == 8 && $cpuarch eq 'i386'
+ # && $osname ne 'darwin');
+ $can_build_call_frames = 0;
}
return $can_build_call_frames;
}
Modified: trunk/config/gen/makefiles/root.in
==============================================================================
--- trunk/config/gen/makefiles/root.in Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/config/gen/makefiles/root.in Wed Oct 21 16:54:18 2009 (r41972)
@@ -428,6 +428,7 @@
$(SRC_DIR)/hash$(O) \
$(SRC_DIR)/hll$(O) \
$(SRC_DIR)/call/pcc$(O) \
+ $(SRC_DIR)/call/args$(O) \
$(SRC_DIR)/interp/inter_cb$(O) \
$(SRC_DIR)/interp/inter_create$(O) \
$(SRC_DIR)/interp/inter_misc$(O) \
@@ -614,6 +615,7 @@
$(SRC_DIR)/global_setup.str \
$(SRC_DIR)/hll.str \
$(SRC_DIR)/call/pcc.str \
+ $(SRC_DIR)/call/args.str \
$(SRC_DIR)/interp/inter_cb.str \
$(SRC_DIR)/interp/inter_create.str \
$(SRC_DIR)/interp/inter_misc.str \
@@ -1130,6 +1132,9 @@
$(SRC_DIR)/runcore/profiling$(O) : $(SRC_DIR)/runcore/profiling.str $(GENERAL_H_FILES) \
$(SRC_DIR)/pmc/pmc_sub.h
+$(SRC_DIR)/call/args$(O) : $(SRC_DIR)/call/args.c $(GENERAL_H_FILES) \
+ $(SRC_DIR)/call/args.str
+
$(SRC_DIR)/call/pcc$(O) : $(SRC_DIR)/call/pcc.c $(GENERAL_H_FILES) \
$(SRC_DIR)/call/pcc.str $(SRC_DIR)/pmc/pmc_fixedintegerarray.h \
$(SRC_DIR)/pmc/pmc_key.h $(SRC_DIR)/pmc/pmc_continuation.h
@@ -1470,7 +1475,7 @@
smolder_test : test_prep
$(PERL) t/harness $(EXTRA_TEST_ARGS) --archive --send-to-smolder
-smolder_coretest : test_prep
+smolder_coretest : corevm
$(PERL) t/harness $(EXTRA_TEST_ARGS) --core-tests --archive --send-to-smolder
smoke : smolder_test
@@ -2203,7 +2208,7 @@
# for use by t/pmc/nci.t
$(LIBNCI_TEST_SO): $(SRC_DIR)/nci_test$(O)
$(LD) $(LD_LOAD_FLAGS) @ncilib_link_extra@ $(LDFLAGS) \
- @ld_out@$@ $(SRC_DIR)/nci_test$(O) $(C_LIBS)
+ @ld_out@$@ $(SRC_DIR)/nci_test$(O) $(ALL_PARROT_LIBS) $(C_LIBS)
# for use by runtime/parrot/library/OpenGL.pir
$(LIBGLUTCB_SO): $(LIBPARROT) $(SRC_DIR)/glut_callbacks$(O)
Modified: trunk/config/gen/opengl.pm
==============================================================================
--- trunk/config/gen/opengl.pm Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/config/gen/opengl.pm Wed Oct 21 16:54:18 2009 (r41972)
@@ -1064,7 +1064,7 @@
PMC *sub = callback_data[GLUT_CB_TIMER].sub;
if (is_safe(interp, sub))
- Parrot_runops_fromc_args_event(interp, sub, "vi", data);
+ Parrot_pcc_invoke_sub_from_c_args(interp, sub, "vi", data);
}
PARROT_DYNEXT_EXPORT
@@ -1099,7 +1099,7 @@
PMC *sub = callback_data[GLUT_CB_JOYSTICK].sub;
if (is_safe(interp, sub))
- Parrot_runops_fromc_args_event(interp, sub, "viiii", buttons, xaxis, yaxis, zaxis);
+ Parrot_pcc_invoke_sub_from_c_args(interp, sub, "viiii", buttons, xaxis, yaxis, zaxis);
}
PARROT_DYNEXT_EXPORT
@@ -1139,7 +1139,7 @@
PMC *sub = callback_data[$_->{enum}].sub;
if (is_safe(interp, sub))
- Parrot_runops_fromc_args_event(interp, sub, "$_->{sig}"$_->{args});
+ Parrot_pcc_invoke_sub_from_c_args(interp, sub, "$_->{sig}"$_->{args});
}
PARROT_DYNEXT_EXPORT
Modified: trunk/include/parrot/call.h
==============================================================================
--- trunk/include/parrot/call.h Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/include/parrot/call.h Wed Oct 21 16:54:18 2009 (r41972)
@@ -35,198 +35,27 @@
typedef parrot_runloop_t Parrot_runloop;
-typedef enum call_state_mode {
- /* argument fetching/putting modes */
- CALL_STATE_SIG = 0x100, /* runops, nci. In case we're interfacing with
- C and va_lists. */
- CALL_STATE_OP = 0x200, /* get_, set_ ops. In case we're interfacing
- with Parrot code and get the signature from
- call_state_item.u.op. */
- CALL_S_D_MASK = 0x300, /* src/dest mask */
-
- CALL_STATE_FLATTEN = 0x400 /* whether we are busy in a :flat argument */
-} call_state_mode;
-
-typedef struct call_state_item {
- /* We have one call_state_item for both the caller (source,
- arguments/returns) and the callee (destination, parameters/results). */
- int mode; /* this specifies:
- - where we get our arguments from / where we put
- our parameters (from C code or from set_*,get_*)
- - if we're in the middle of a :flat */
-
- union {
- struct { /* In case the caller (or callee? FIXME) is C */
- void *ap; /* a ptr to va_list */
- const char *sig; /* C string describing the type of each argument */
- } sig;
-
- struct { /* In case the caller/callee was Parrot code: */
- opcode_t *pc; /* array of 'indexes' for each argument:
- - if it's a constant, the constant number
- - if it's a register, the register number */
- PMC *signature; /* a PMC array holding a Call_bits_enum_t
- signature for each argument */
- } op;
- } u;
-
- PMC *ctx; /* the source or destination context */
- INTVAL used; /* src: whether this argument has been consumed
- * (or: whether the previous arg has?) */
- INTVAL i; /* number of args/params already processed */
- INTVAL n; /* number of args/params to match.
- * may include :slurpys and :flats */
- INTVAL sig; /* type of current arg/param
- * (counting from 1, the i'th) */
-
- /* We might encounter a :flat. */
- /* FIXME bgeron: is this used for :slurpys?
- * I can't find a reference in slurpy-filling code. */
-
- PMC *slurp; /* PMC in which to put the args we slurp up
- * or source from where to flatten */
- INTVAL slurp_i; /* index of :flat/:slurpy arg/param to match */
- INTVAL slurp_n; /* number of :flat/:slurpy args/params to match */
-} call_state_item;
-
-typedef union UnionCallStateVal {
- struct _ptrs { /* or two pointers, both are defines */
- DPOINTER * _struct_val;
- PMC * _pmc_val;
- } _ptrs;
- struct _i {
- INTVAL _int_val; /* or 2 intvals */
- INTVAL _int_val2;
- } _i;
- FLOATVAL _num_val; /* or one float */
- struct parrot_string_t * _string_val; /* or a pointer to a string */
-} UnionCallStateVal;
-
-#define UVal_ptr(u) (u)._ptrs._struct_val
-#define UVal_pmc(u) (u)._ptrs._pmc_val
-#define UVal_int(u) (u)._i._int_val
-#define UVal_int2(u) (u)._i._int_val2
-#define UVal_num(u) (u)._num_val
-#define UVal_str(u) (u)._string_val
-
-typedef struct call_state {
- call_state_item src;
- call_state_item dest;
- UnionCallStateVal val;
- int n_actual_args; /* arguments incl. flatten */
- int optionals; /* sum of optionals */
- int params; /* sum of params */
- int first_named; /* param idx of 1st named */
- UINTVAL named_done; /* bit mask, 1 if named was assigned */
- STRING *name; /* name of argument if any */
- PMC *key; /* to iterate a flattening hash */
-} call_state;
-
-typedef enum arg_pass_t {
- PARROT_PASS_PARAMS = 0x00,
- PARROT_PASS_RESULTS = 0x01
-} arg_pass_t;
+typedef enum {
+ CALLSIGNATURE_is_exception_FLAG = PObj_private0_FLAG,
+} callsignature_flags_enum;
+
+#define CALLSIGNATURE_get_FLAGS(o) (PObj_get_FLAGS(o))
+#define CALLSIGNATURE_flag_TEST(flag, o) (CALLSIGNATURE_get_FLAGS(o) & CALLSIGNATURE_ ## flag ## _FLAG)
+#define CALLSIGNATURE_flag_SET(flag, o) (CALLSIGNATURE_get_FLAGS(o) |= CALLSIGNATURE_ ## flag ## _FLAG)
+#define CALLSIGNATURE_flag_CLEAR(flag, o) (CALLSIGNATURE_get_FLAGS(o) &= ~(UINTVAL)(CALLSIGNATURE_ ## flag ## _FLAG))
+
+/* Mark if the CallSignature is for an exception handler */
+#define CALLSIGNATURE_is_exception_TEST(o) CALLSIGNATURE_flag_TEST(is_exception, (o))
+#define CALLSIGNATURE_is_exception_SET(o) CALLSIGNATURE_flag_SET(is_exception, (o))
+#define CALLSIGNATURE_is_exception_CLEAR(o) CALLSIGNATURE_flag_CLEAR(is_exception, (o))
/* HEADERIZER BEGIN: src/call/pcc.c */
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
PARROT_EXPORT
-void Parrot_convert_arg(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-PARROT_EXPORT
-int Parrot_fetch_arg(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-PARROT_EXPORT
-int Parrot_fetch_arg_nci(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-PARROT_EXPORT
-int Parrot_init_arg_indexes_and_sig_pmc(PARROT_INTERP,
- ARGIN(PMC *ctx),
- ARGIN_NULLOK(opcode_t *indexes),
- ARGIN_NULLOK(PMC *sig_pmc),
- ARGMOD(call_state_item *sti))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(5)
- FUNC_MODIFIES(*sti);
-
-PARROT_EXPORT
-void Parrot_init_arg_nci(PARROT_INTERP,
- ARGOUT(call_state *st),
- ARGIN(const char *sig))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- FUNC_MODIFIES(*st);
-
-PARROT_EXPORT
-int Parrot_init_arg_op(PARROT_INTERP,
- ARGIN(PMC *ctx),
- ARGIN_NULLOK(opcode_t *pc),
- ARGIN(call_state_item *sti))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(4);
-
-PARROT_EXPORT
-int Parrot_init_arg_sig(PARROT_INTERP,
- ARGIN(PMC *ctx),
- ARGIN(const char *sig),
- ARGIN_NULLOK(void *ap),
- ARGMOD(call_state_item *sti))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- __attribute__nonnull__(5)
- FUNC_MODIFIES(*sti);
-
-PARROT_EXPORT
-void Parrot_init_ret_nci(PARROT_INTERP,
- ARGOUT(call_state *st),
- ARGIN(const char *sig))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- FUNC_MODIFIES(*st);
-
-PARROT_EXPORT
-void parrot_pass_args(PARROT_INTERP,
- ARGMOD(PMC *src_ctx),
- ARGMOD(PMC *dest_ctx),
- ARGMOD_NULLOK(opcode_t *src_indexes),
- ARGMOD_NULLOK(opcode_t *dest_indexes),
- arg_pass_t param_or_result)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- FUNC_MODIFIES(*src_ctx)
- FUNC_MODIFIES(*dest_ctx)
- FUNC_MODIFIES(*src_indexes)
- FUNC_MODIFIES(*dest_indexes);
-
-PARROT_EXPORT
-PARROT_WARN_UNUSED_RESULT
-PARROT_CANNOT_RETURN_NULL
-PMC* Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP,
- ARGIN_NULLOK(PMC *obj),
- ARGIN(const char *sig),
- va_list args)
- __attribute__nonnull__(1)
- __attribute__nonnull__(3);
-
-PARROT_EXPORT
void Parrot_pcc_invoke_from_sig_object(PARROT_INTERP,
ARGIN(PMC *sub_obj),
- ARGIN(PMC *sig_obj))
+ ARGIN(PMC *call_object))
__attribute__nonnull__(1)
__attribute__nonnull__(2)
__attribute__nonnull__(3);
@@ -264,102 +93,11 @@
__attribute__nonnull__(4)
FUNC_MODIFIES(*method_name);
-PARROT_EXPORT
-void Parrot_process_args(PARROT_INTERP,
- ARGMOD(call_state *st),
- arg_pass_t param_or_result)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-PARROT_EXPORT
-int Parrot_store_arg(PARROT_INTERP, ARGIN(const call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2);
-
-PARROT_CANNOT_RETURN_NULL
-PARROT_WARN_UNUSED_RESULT
-opcode_t * parrot_pass_args_fromc(PARROT_INTERP,
- ARGIN(const char *sig),
- ARGMOD(opcode_t *dest),
- ARGIN(PMC *old_ctxp),
- va_list ap)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- __attribute__nonnull__(4)
- FUNC_MODIFIES(*dest);
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CAN_RETURN_NULL
-void * set_retval(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx))
- __attribute__nonnull__(1)
- __attribute__nonnull__(3);
-
-FLOATVAL set_retval_f(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx))
- __attribute__nonnull__(1)
- __attribute__nonnull__(3);
-
-INTVAL set_retval_i(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx))
- __attribute__nonnull__(1)
- __attribute__nonnull__(3);
-
-PARROT_CAN_RETURN_NULL
-PARROT_WARN_UNUSED_RESULT
-PMC* set_retval_p(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx))
- __attribute__nonnull__(1)
- __attribute__nonnull__(3);
-
-PARROT_CAN_RETURN_NULL
-PARROT_WARN_UNUSED_RESULT
-STRING* set_retval_s(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx))
- __attribute__nonnull__(1)
- __attribute__nonnull__(3);
-
-#define ASSERT_ARGS_Parrot_convert_arg __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_Parrot_fetch_arg __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_Parrot_fetch_arg_nci __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_Parrot_init_arg_indexes_and_sig_pmc \
- __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(ctx) \
- , PARROT_ASSERT_ARG(sti))
-#define ASSERT_ARGS_Parrot_init_arg_nci __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_init_arg_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(ctx) \
- , PARROT_ASSERT_ARG(sti))
-#define ASSERT_ARGS_Parrot_init_arg_sig __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(ctx) \
- , PARROT_ASSERT_ARG(sig) \
- , PARROT_ASSERT_ARG(sti))
-#define ASSERT_ARGS_Parrot_init_ret_nci __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_parrot_pass_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(src_ctx) \
- , PARROT_ASSERT_ARG(dest_ctx))
-#define ASSERT_ARGS_Parrot_pcc_build_sig_object_from_varargs \
- __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sig))
#define ASSERT_ARGS_Parrot_pcc_invoke_from_sig_object \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(sub_obj) \
- , PARROT_ASSERT_ARG(sig_obj))
+ , PARROT_ASSERT_ARG(call_object))
#define ASSERT_ARGS_Parrot_pcc_invoke_method_from_c_args \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
@@ -376,32 +114,6 @@
, PARROT_ASSERT_ARG(pmc) \
, PARROT_ASSERT_ARG(method_name) \
, PARROT_ASSERT_ARG(signature))
-#define ASSERT_ARGS_Parrot_process_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_Parrot_store_arg __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_parrot_pass_args_fromc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sig) \
- , PARROT_ASSERT_ARG(dest) \
- , PARROT_ASSERT_ARG(old_ctxp))
-#define ASSERT_ARGS_set_retval __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(ctx))
-#define ASSERT_ARGS_set_retval_f __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(ctx))
-#define ASSERT_ARGS_set_retval_i __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(ctx))
-#define ASSERT_ARGS_set_retval_p __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(ctx))
-#define ASSERT_ARGS_set_retval_s __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(ctx))
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: src/call/pcc.c */
@@ -416,277 +128,184 @@
void new_runloop_jump_point(PARROT_INTERP)
__attribute__nonnull__(1);
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-void * Parrot_run_meth_fromc(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN_NULLOK(PMC *obj),
- SHIM(STRING *meth))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2);
+void destroy_runloop_jump_points(PARROT_INTERP)
+ __attribute__nonnull__(1);
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-void* Parrot_run_meth_fromc_arglist(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth),
- ARGIN(const char *sig),
- va_list args)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(4)
- __attribute__nonnull__(5);
+void really_destroy_runloop_jump_points(
+ ARGIN_NULLOK(Parrot_runloop *jump_point));
+
+void runops(PARROT_INTERP, size_t offs)
+ __attribute__nonnull__(1);
+
+#define ASSERT_ARGS_free_runloop_jump_point __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp))
+#define ASSERT_ARGS_new_runloop_jump_point __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp))
+#define ASSERT_ARGS_destroy_runloop_jump_points __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp))
+#define ASSERT_ARGS_really_destroy_runloop_jump_points \
+ __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
+#define ASSERT_ARGS_runops __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp))
+/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
+/* HEADERIZER END: src/call/ops.c */
+
+/* HEADERIZER BEGIN: src/call/args.c */
+/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-FLOATVAL /*@alt void@*/
-Parrot_run_meth_fromc_arglist_retf(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth),
- ARGIN(const char *sig),
- va_list args)
+PARROT_WARN_UNUSED_RESULT
+PARROT_CANNOT_RETURN_NULL
+PMC* Parrot_pcc_build_sig_object_from_op(PARROT_INTERP,
+ ARGIN_NULLOK(PMC *signature),
+ ARGIN(PMC * const raw_sig),
+ ARGIN(opcode_t * const raw_args))
__attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(4)
- __attribute__nonnull__(5);
+ __attribute__nonnull__(3)
+ __attribute__nonnull__(4);
PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-INTVAL /*@alt void@*/
-Parrot_run_meth_fromc_arglist_reti(PARROT_INTERP,
- ARGIN(PMC *sub),
+PARROT_WARN_UNUSED_RESULT
+PARROT_CANNOT_RETURN_NULL
+PMC* Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP,
ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth),
ARGIN(const char *sig),
va_list args)
__attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(4)
- __attribute__nonnull__(5);
+ __attribute__nonnull__(3);
PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
+PARROT_WARN_UNUSED_RESULT
PARROT_CAN_RETURN_NULL
-void* Parrot_run_meth_fromc_args(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth),
- ARGIN(const char *sig),
- ...)
+PMC* Parrot_pcc_build_sig_object_returns_from_op(PARROT_INTERP,
+ ARGIN_NULLOK(PMC *signature),
+ ARGIN(PMC *raw_sig),
+ ARGIN(opcode_t *raw_args))
__attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(4)
- __attribute__nonnull__(5);
+ __attribute__nonnull__(3)
+ __attribute__nonnull__(4);
PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-FLOATVAL /*@alt void@*/
-Parrot_run_meth_fromc_args_retf(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth),
- ARGIN(const char *sig),
+void Parrot_pcc_fill_params_from_c_args(PARROT_INTERP,
+ ARGMOD(PMC *call_object),
+ ARGIN(const char *signature),
...)
__attribute__nonnull__(1)
__attribute__nonnull__(2)
- __attribute__nonnull__(4)
- __attribute__nonnull__(5);
+ __attribute__nonnull__(3)
+ FUNC_MODIFIES(*call_object);
PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-INTVAL /*@alt void@*/
-Parrot_run_meth_fromc_args_reti(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth),
- ARGIN(const char *sig),
- ...)
+void Parrot_pcc_fill_params_from_op(PARROT_INTERP,
+ ARGMOD_NULLOK(PMC *call_object),
+ ARGIN(PMC *raw_sig),
+ ARGIN(opcode_t *raw_params))
__attribute__nonnull__(1)
- __attribute__nonnull__(2)
+ __attribute__nonnull__(3)
__attribute__nonnull__(4)
- __attribute__nonnull__(5);
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CANNOT_RETURN_NULL
-PMC * Parrot_runops_fromc(PARROT_INTERP, ARGIN(PMC *sub))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2);
+ FUNC_MODIFIES(*call_object);
PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-void * Parrot_runops_fromc_arglist(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN(const char *sig),
- va_list args)
+void Parrot_pcc_fill_returns_from_c_args(PARROT_INTERP,
+ ARGMOD_NULLOK(PMC *call_object),
+ ARGIN(const char *signature),
+ ...)
__attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3);
+ __attribute__nonnull__(3)
+ FUNC_MODIFIES(*call_object);
PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-FLOATVAL /*@alt void@*/
-Parrot_runops_fromc_arglist_retf(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN(const char *sig),
- va_list args)
+void Parrot_pcc_fill_returns_from_continuation(PARROT_INTERP,
+ ARGMOD_NULLOK(PMC *call_object),
+ ARGIN(PMC *raw_sig),
+ ARGIN(PMC *from_call_obj))
__attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3);
+ __attribute__nonnull__(3)
+ __attribute__nonnull__(4)
+ FUNC_MODIFIES(*call_object);
PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-INTVAL /*@alt void@*/
-Parrot_runops_fromc_arglist_reti(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN(const char *sig),
- va_list args)
+void Parrot_pcc_fill_returns_from_op(PARROT_INTERP,
+ ARGMOD_NULLOK(PMC *call_object),
+ ARGIN(PMC *raw_sig),
+ ARGIN(opcode_t *raw_returns))
__attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3);
+ __attribute__nonnull__(3)
+ __attribute__nonnull__(4)
+ FUNC_MODIFIES(*call_object);
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-PMC * Parrot_runops_fromc_args(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN(const char *sig),
- ...)
+void Parrot_pcc_merge_signature_for_tailcall(PARROT_INTERP,
+ ARGMOD(PMC * parent),
+ ARGMOD(PMC * tailcall))
__attribute__nonnull__(1)
__attribute__nonnull__(2)
- __attribute__nonnull__(3);
+ __attribute__nonnull__(3)
+ FUNC_MODIFIES(* parent)
+ FUNC_MODIFIES(* tailcall);
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
PARROT_CAN_RETURN_NULL
-void * Parrot_runops_fromc_args_event(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN(const char *sig),
- ...)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3);
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-FLOATVAL /*@alt void@*/
-Parrot_runops_fromc_args_retf(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN(const char *sig),
- ...)
+void Parrot_pcc_parse_signature_string(PARROT_INTERP,
+ ARGIN(STRING *signature),
+ ARGMOD(PMC **arg_flags),
+ ARGMOD(PMC **return_flags))
__attribute__nonnull__(1)
__attribute__nonnull__(2)
- __attribute__nonnull__(3);
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-INTVAL /*@alt void@*/
-Parrot_runops_fromc_args_reti(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN(const char *sig),
- ...)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3);
-
-void destroy_runloop_jump_points(PARROT_INTERP)
- __attribute__nonnull__(1);
-
-void really_destroy_runloop_jump_points(
- ARGIN_NULLOK(Parrot_runloop *jump_point));
-
-void runops(PARROT_INTERP, size_t offs)
- __attribute__nonnull__(1);
+ __attribute__nonnull__(3)
+ __attribute__nonnull__(4)
+ FUNC_MODIFIES(*arg_flags)
+ FUNC_MODIFIES(*return_flags);
-#define ASSERT_ARGS_free_runloop_jump_point __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp))
-#define ASSERT_ARGS_new_runloop_jump_point __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp))
-#define ASSERT_ARGS_Parrot_run_meth_fromc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub))
-#define ASSERT_ARGS_Parrot_run_meth_fromc_arglist __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(meth) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_run_meth_fromc_arglist_retf \
+#define ASSERT_ARGS_Parrot_pcc_build_sig_object_from_op \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(meth) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_run_meth_fromc_arglist_reti \
+ , PARROT_ASSERT_ARG(raw_sig) \
+ , PARROT_ASSERT_ARG(raw_args))
+#define ASSERT_ARGS_Parrot_pcc_build_sig_object_from_varargs \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(meth) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_run_meth_fromc_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(meth) \
, PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_run_meth_fromc_args_retf \
+#define ASSERT_ARGS_Parrot_pcc_build_sig_object_returns_from_op \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(meth) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_run_meth_fromc_args_reti \
+ , PARROT_ASSERT_ARG(raw_sig) \
+ , PARROT_ASSERT_ARG(raw_args))
+#define ASSERT_ARGS_Parrot_pcc_fill_params_from_c_args \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(meth) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_runops_fromc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub))
-#define ASSERT_ARGS_Parrot_runops_fromc_arglist __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_runops_fromc_arglist_retf \
+ , PARROT_ASSERT_ARG(call_object) \
+ , PARROT_ASSERT_ARG(signature))
+#define ASSERT_ARGS_Parrot_pcc_fill_params_from_op \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_runops_fromc_arglist_reti \
+ , PARROT_ASSERT_ARG(raw_sig) \
+ , PARROT_ASSERT_ARG(raw_params))
+#define ASSERT_ARGS_Parrot_pcc_fill_returns_from_c_args \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_runops_fromc_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ , PARROT_ASSERT_ARG(signature))
+#define ASSERT_ARGS_Parrot_pcc_fill_returns_from_continuation \
+ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_runops_fromc_args_event \
+ , PARROT_ASSERT_ARG(raw_sig) \
+ , PARROT_ASSERT_ARG(from_call_obj))
+#define ASSERT_ARGS_Parrot_pcc_fill_returns_from_op \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_runops_fromc_args_retf __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ , PARROT_ASSERT_ARG(raw_sig) \
+ , PARROT_ASSERT_ARG(raw_returns))
+#define ASSERT_ARGS_Parrot_pcc_merge_signature_for_tailcall \
+ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_runops_fromc_args_reti __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ , PARROT_ASSERT_ARG(parent) \
+ , PARROT_ASSERT_ARG(tailcall))
+#define ASSERT_ARGS_Parrot_pcc_parse_signature_string \
+ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_destroy_runloop_jump_points __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp))
-#define ASSERT_ARGS_really_destroy_runloop_jump_points \
- __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
-#define ASSERT_ARGS_runops __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp))
+ , PARROT_ASSERT_ARG(signature) \
+ , PARROT_ASSERT_ARG(arg_flags) \
+ , PARROT_ASSERT_ARG(return_flags))
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
-/* HEADERIZER END: src/call/ops.c */
+/* HEADERIZER END: src/call/args.c */
#define ASSERT_SIG_PMC(sig) do {\
PARROT_ASSERT(!PMC_IS_NULL(sig)); \
@@ -899,6 +518,12 @@
PARROT_EXPORT
PARROT_CAN_RETURN_NULL
+PMC* Parrot_pcc_get_signature(PARROT_INTERP, ARGIN(PMC *ctx))
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+
+PARROT_EXPORT
+PARROT_CAN_RETURN_NULL
STRING* Parrot_pcc_get_string_constant(PARROT_INTERP,
ARGIN(PMC *ctx),
INTVAL idx)
@@ -1045,6 +670,13 @@
__attribute__nonnull__(2);
PARROT_EXPORT
+void Parrot_pcc_set_signature(PARROT_INTERP,
+ ARGIN(PMC *ctx),
+ ARGIN_NULLOK(PMC *sig_object))
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+
+PARROT_EXPORT
void Parrot_pcc_set_sub(PARROT_INTERP,
ARGIN(PMC *ctx),
ARGIN_NULLOK(PMC *sub))
@@ -1218,6 +850,9 @@
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(ctx))
+#define ASSERT_ARGS_Parrot_pcc_get_signature __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp) \
+ , PARROT_ASSERT_ARG(ctx))
#define ASSERT_ARGS_Parrot_pcc_get_string_constant \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
@@ -1287,6 +922,9 @@
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(ctx))
+#define ASSERT_ARGS_Parrot_pcc_set_signature __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp) \
+ , PARROT_ASSERT_ARG(ctx))
#define ASSERT_ARGS_Parrot_pcc_set_sub __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(ctx))
Modified: trunk/include/parrot/context.h
==============================================================================
--- trunk/include/parrot/context.h Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/include/parrot/context.h Wed Oct 21 16:54:18 2009 (r41972)
@@ -111,6 +111,7 @@
INTVAL current_HLL; /* see also src/hll.c */
+ PMC *current_sig; /* temporary CallSignature PMC for active call */
UINTVAL warns; /* Keeps track of what warnings
* have been activated */
UINTVAL errors; /* fatals that can be turned off */
Modified: trunk/include/parrot/extend.h
==============================================================================
--- trunk/include/parrot/extend.h Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/include/parrot/extend.h Wed Oct 21 16:54:18 2009 (r41972)
@@ -65,7 +65,7 @@
PARROT_WARN_UNUSED_RESULT
PARROT_CAN_RETURN_NULL
void * Parrot_call_method(PARROT_INTERP,
- Parrot_PMC sub,
+ Parrot_PMC sub_pmc,
Parrot_PMC obj,
Parrot_String method,
ARGIN(const char *signature),
@@ -75,7 +75,7 @@
PARROT_EXPORT
Parrot_Float Parrot_call_method_ret_float(PARROT_INTERP,
- Parrot_PMC sub,
+ Parrot_PMC sub_pmc,
Parrot_PMC obj,
Parrot_String method,
ARGIN(const char *signature),
@@ -85,7 +85,7 @@
PARROT_EXPORT
Parrot_Int Parrot_call_method_ret_int(PARROT_INTERP,
- Parrot_PMC sub,
+ Parrot_PMC sub_pmc,
Parrot_PMC obj,
Parrot_String method,
ARGIN(const char *signature),
@@ -443,6 +443,15 @@
__attribute__nonnull__(2)
__attribute__nonnull__(3);
+void append_result(PARROT_INTERP,
+ ARGIN(PMC *sig_object),
+ ARGIN(Parrot_String type),
+ ARGIN(void *result))
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2)
+ __attribute__nonnull__(3)
+ __attribute__nonnull__(4);
+
#define ASSERT_ARGS_Parrot_call_method __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(signature))
@@ -582,6 +591,11 @@
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(pio) \
, PARROT_ASSERT_ARG(s))
+#define ASSERT_ARGS_append_result __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp) \
+ , PARROT_ASSERT_ARG(sig_object) \
+ , PARROT_ASSERT_ARG(type) \
+ , PARROT_ASSERT_ARG(result))
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: src/extend.c */
Modified: trunk/include/parrot/interpreter.h
==============================================================================
--- trunk/include/parrot/interpreter.h Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/include/parrot/interpreter.h Wed Oct 21 16:54:18 2009 (r41972)
@@ -295,14 +295,6 @@
UINTVAL recursion_limit; /* Sub call resursion limit */
-
- opcode_t *current_args; /* ptr into code w/ set_args op */
- opcode_t *current_params; /* ... w/ get_params op */
- opcode_t *current_returns; /* ... w/ get_returns op */
- PMC *args_signature; /* non-const args signature PMC */
- PMC *params_signature; /* non-const params sig PMC */
- PMC *returns_signature; /* non-const returns sig PMC */
-
/* during a call sequencer the caller fills these objects
* inside the invoke these get moved to the context structure */
PMC *current_cont; /* the return continuation PMC */
Modified: trunk/include/parrot/multidispatch.h
==============================================================================
--- trunk/include/parrot/multidispatch.h Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/include/parrot/multidispatch.h Wed Oct 21 16:54:18 2009 (r41972)
@@ -199,13 +199,6 @@
PARROT_EXPORT
PARROT_CAN_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
-PMC * Parrot_mmd_sort_manhattan(PARROT_INTERP, ARGIN(PMC *candidates))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2);
-
-PARROT_EXPORT
-PARROT_CAN_RETURN_NULL
-PARROT_WARN_UNUSED_RESULT
PMC * Parrot_mmd_sort_manhattan_by_sig_pmc(PARROT_INTERP,
ARGIN(PMC *candidates),
ARGIN(PMC *invoke_sig))
@@ -283,9 +276,6 @@
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(name) \
, PARROT_ASSERT_ARG(sig))
-#define ASSERT_ARGS_Parrot_mmd_sort_manhattan __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(candidates))
#define ASSERT_ARGS_Parrot_mmd_sort_manhattan_by_sig_pmc \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
Modified: trunk/lib/Parrot/Pmc2c/Method.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/Method.pm Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/lib/Parrot/Pmc2c/Method.pm Wed Oct 21 16:54:18 2009 (r41972)
@@ -149,6 +149,41 @@
return ( $return_prefix, $method_suffix, $args, $sig, $return_type_char, $null_return );
}
+=head1 C<pcc_signature()>
+
+Returns a PCC-style method signature for the method's parameters, as well as
+some additional information useful in building a call to that method.
+
+=cut
+
+sub pcc_signature {
+ my ($self) = @_;
+
+ my $args = passable_args_from_parameter_list( $self->parameters );
+ my ($types, $vars) = args_from_parameter_list( $self->parameters );
+ my $return_type = $self->return_type;
+ my $return_type_char = $self->trans($return_type);
+ my $sig = join ('', map { $self->trans($_) } @{$types}) .
+ '->';
+
+ my $result_decl = '';
+ my $return_stmt = '';
+
+ if ( $return_type eq 'void' ) {
+ $return_stmt = "return ($return_type) NULL;" if $return_type_char =~ /P|I|S|V/;
+ $return_stmt = 'return (FLOATVAL) 0;' if $return_type_char =~ /N/;
+ $return_stmt = 'return;' if $return_type_char =~ /v/;
+ }
+ else {
+ $result_decl = "$return_type result;";
+ $args .= ', &result';
+ $sig .= $return_type_char;
+ $return_stmt = "return ($return_type) result;";
+ }
+
+ return ( $sig, $args, $result_decl, $return_stmt );
+}
+
1;
# Local Variables:
Modified: trunk/lib/Parrot/Pmc2c/PCCMETHOD.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/PCCMETHOD.pm Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/lib/Parrot/Pmc2c/PCCMETHOD.pm Wed Oct 21 16:54:18 2009 (r41972)
@@ -79,10 +79,22 @@
our $reg_type_info = {
# s is string, ss is short string, at is arg type
- +(REGNO_INT) => { s => "INTVAL", ss => "INT", at => PARROT_ARG_INTVAL, },
- +(REGNO_NUM) => { s => "FLOATVAL", ss => "NUM", at => PARROT_ARG_FLOATVAL, },
- +(REGNO_STR) => { s => "STRING*", ss => "STR", at => PARROT_ARG_STRING, },
- +(REGNO_PMC) => { s => "PMC*", ss => "PMC", at => PARROT_ARG_PMC, },
+ +(REGNO_INT) => { s => "INTVAL",
+ ss => "INT",
+ pcc => 'I',
+ at => PARROT_ARG_INTVAL},
+ +(REGNO_NUM) => { s => "FLOATVAL",
+ ss => "NUM",
+ pcc => "N",
+ at => PARROT_ARG_FLOATVAL, },
+ +(REGNO_STR) => { s => "STRING*",
+ ss => "STR",
+ pcc => "S",
+ at => PARROT_ARG_STRING, },
+ +(REGNO_PMC) => { s => "PMC*",
+ ss => "PMC",
+ pcc => "P",
+ at => PARROT_ARG_PMC, },
};
# Perl trim function to remove whitespace from the start and end of the string
@@ -110,10 +122,10 @@
=head3 C<parse_adverb_attributes>
builds and returs an adverb hash from an adverb string such as
- ":optional :optflag :slurpy"
+ ":optional :opt_flag :slurpy"
{
optional =>1,
- optflag =>1,
+ opt_flag =>1,
slurpy =>1,
}
@@ -137,6 +149,26 @@
croak "$_ not recognized as INTVAL, FLOATVAL, STRING, or PMC";
}
+sub gen_arg_pcc_sig {
+ my ($param) = @_;
+
+ return 'Ip'
+ if exists $param->{attrs}{opt_flag};
+
+ my $sig = $reg_type_info->{ $param->{type} }->{pcc};
+ $sig .= 'c' if exists $param->{attrs}{constant};
+ $sig .= 'f' if exists $param->{attrs}{flatten};
+ $sig .= 'i' if exists $param->{attrs}{invocant};
+ $sig .= 'l' if exists $param->{attrs}{lookahead};
+ $sig .= 'n' if (exists $param->{attrs}{name} ||
+ exists $param->{attrs}{named});
+ $sig .= 'o' if exists $param->{attrs}{optional};
+ $sig .= 'p' if exists $param->{attrs}{opt_flag};
+ $sig .= 's' if exists $param->{attrs}{slurpy};
+
+ return $sig;
+}
+
sub gen_arg_flags {
my ($param) = @_;
@@ -162,14 +194,11 @@
my $tiss = $reg_type_info->{$reg_type}{ss}; #reg_type_info short string
if ( 'arg' eq $arg_type ) {
- return " $tis $name = CTX_REG_$tiss(_ctx, $index);\n";
+ return "$tis $name = CTX_REG_$tiss(_ctx, $index);\n";
}
elsif ( 'result' eq $arg_type ) {
return " $name = CTX_REG_$tiss(_ctx, $index);\n";
}
- elsif ( 'name' eq $arg_type ) {
- return " CTX_REG_$tiss(_ctx, $index) = CONST_STRING_GEN(interp, $name);\n";
- }
else { #$arg_type eq 'param' or $arg_type eq 'return'
return " CTX_REG_$tiss(_ctx, $index) = $name;\n";
}
@@ -185,8 +214,6 @@
my ( $self, $pmc ) = @_;
my $method_name = $self->name;
my $body = $self->body;
- my $regs_used = [];
- my $qty_returns = 0;
my $signature_re = qr/
(RETURN #method name
@@ -206,7 +233,6 @@
last unless $matched;
}
- $qty_returns++;
$matched =~ /$signature_re/;
my ( $match, $returns ) = ( $1, $2 );
@@ -215,7 +241,7 @@
if ($returns eq 'void') {
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
/*BEGIN RETURN $returns */
- goto no_return;
+ return;
/*END RETURN $returns */
END
$matched->replace( $match, $e );
@@ -223,40 +249,33 @@
}
my $goto_string = "goto ${method_name}_returns;";
- my ( $returns_n_regs_used, $returns_indexes, $returns_flags, $returns_accessors ) =
+ my ( $returns_signature, $returns_varargs ) =
process_pccmethod_args( parse_p_args_string($returns), 'return' );
- $returns_indexes = "0" unless $returns_indexes;
-
- push @$regs_used, $returns_n_regs_used;
+ if ($returns_signature) {
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
{
/*BEGIN RETURN $returns */
- /*BEGIN GENERATED ACCESSORS */
-END
- $e->emit(<<"END");
-$returns_accessors
END
-
- my $returns_sig = make_arg_pmc($returns_flags, '_return_sig');
-
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
- /*END GENERATED ACCESSORS */
- {
- opcode_t _temp_return_indexes[] = { $returns_indexes };
- _return_indexes = _temp_return_indexes;
- }
-
- _return_sig = pmc_new(interp, enum_class_FixedIntegerArray);
-$returns_sig
- $goto_string
+ Parrot_pcc_fill_returns_from_c_args(interp, _call_object, "$returns_signature",
+ $returns_varargs);
+ return;
/*END RETURN $returns */
}
END
+ }
+ else { # if ($returns_signature)
+ $e->emit( <<"END", __FILE__, __LINE__ + 1 );
+ /*BEGIN RETURN $returns */
+ return;
+ /*END RETURN $returns */
+END
+ }
+
$matched->replace( $match, $e );
}
- return $regs_used, $qty_returns;
}
sub parse_p_args_string {
@@ -305,16 +324,20 @@
sub process_pccmethod_args {
my ( $linear_args, $arg_type ) = @_;
- my $n_regs_used_a = [ 0, 0, 0, 0 ]; # INT, FLOAT, STRING, PMC counts
my $args = [ [], [], [], [] ]; # actual INT, FLOAT, STRING, PMC
- my $args_indexes_a = []; # arg index into interp context
- my $args_flags_a = []; # arg flags
- my $args_accessors = "";
- my $named_names = "";
+ my $signature = "";
+ my @vararg_list = ();
+ my $varargs = "";
+ my $declarations = "";
for my $arg (@$linear_args) {
my ( $named, $named_name ) = is_named($arg);
+ my $type = $arg->{type};
+ my $name = $arg->{name};
if ($named) {
+ my $tis = $reg_type_info->{+(REGNO_STR)}{s}; #reg_type_info string
+ my $dummy_name = "_param_name_str_". $named_name;
+ $dummy_name =~ s/"//g;
my $argn = {
type => +(REGNO_STR),
name => $named_name,
@@ -323,22 +346,26 @@
$arg->{named_name} = $named_name;
push @{ $args->[ +(REGNO_STR) ] }, $argn;
- $argn->{index} = $n_regs_used_a->[ +(REGNO_STR) ]++;
- push @$args_indexes_a, $argn->{index};
- push @$args_flags_a, PARROT_ARG_STRING | PARROT_ARG_NAME;
- $named_names .= gen_arg_accessor( $argn, 'name' );
- }
-
- push @{ $args->[ $arg->{type} ] }, $arg;
- $arg->{index} = $n_regs_used_a->[ $arg->{type} ]++;
- push @$args_indexes_a, $arg->{index};
- push @$args_flags_a, gen_arg_flags($arg);
- $args_accessors .= gen_arg_accessor( $arg, $arg_type );
- }
-
- my $n_regs_used = join( ", ", @$n_regs_used_a );
- my $args_indexes = join( ", ", @$args_indexes_a );
- return ( $n_regs_used_a, $args_indexes, $args_flags_a, $args_accessors, $named_names );
+ $signature .= 'Sn';
+ $declarations .= "$tis $dummy_name = CONST_STRING_GEN(interp, $named_name);\n";
+ push @vararg_list, "&$dummy_name";
+ }
+
+ push @{ $args->[ $type ] }, $arg;
+ $signature .= gen_arg_pcc_sig($arg);
+ if ( $arg_type eq 'arg' ) {
+ my $tis = $reg_type_info->{$type}{"s"}; #reg_type_info string
+ $declarations .= "$tis $name;\n";
+ push @vararg_list, "&$name"
+ }
+ elsif ( $arg_type eq 'return' ) {
+ my $typenamestr = $reg_type_info->{$type}{s};
+ push @vararg_list, "($typenamestr)$name";
+ }
+ }
+
+ $varargs = join ", ", @vararg_list;
+ return ( $signature, $varargs, $declarations );
}
sub find_max_regs {
@@ -367,115 +394,55 @@
my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename );
my $e_post = Parrot::Pmc2c::Emitter->new( $pmc->filename );
- # parse pccmethod parameters, then unshift the a PMC arg for the invocant
+ # parse pccmethod parameters, then unshift the PMC arg for the invocant
my $linear_args = parse_p_args_string( $self->parameters );
unshift @$linear_args,
{
type => convert_type_string_to_reg_type('PMC'),
name => 'pmc',
- attrs => parse_adverb_attributes(':object')
+ attrs => parse_adverb_attributes(':invocant')
};
- my ( $params_n_regs_used, $params_indexes, $params_flags, $params_accessors, $named_names ) =
+ # The invocant is already passed in the C signature, why pass it again?
+
+ my ( $params_signature, $params_varargs, $params_declarations ) =
process_pccmethod_args( $linear_args, 'arg' );
- my ( $n_regs, $qty_returns ) = rewrite_RETURNs( $self, $pmc );
+ rewrite_RETURNs( $self, $pmc );
rewrite_pccinvoke( $self, $pmc );
- unshift @$n_regs, $params_n_regs_used;
- my $n_regs_used = find_max_regs($n_regs);
-
- my $set_params = make_arg_pmc($params_flags, '_param_sig');
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
- const INTVAL _n_regs_used[] = { $n_regs_used };
- opcode_t _param_indexes[] = { $params_indexes };
- opcode_t *_return_indexes;
- opcode_t *_current_args;
- PMC * const _param_sig = pmc_new(interp, enum_class_FixedIntegerArray);
- PMC *_return_sig = PMCNULL;
-
- PMC *_caller_ctx = interp->ctx;
- PMC * const _ret_cont = new_ret_continuation_pmc(interp, NULL);
- PMC *_ctx = Parrot_push_context(interp, _n_regs_used);
- PMC *_ccont = PMCNULL;
-
-$set_params
- UNUSED(_return_indexes);
-
- if (_caller_ctx) {
- _ccont = Parrot_pcc_get_continuation(interp, _caller_ctx);
- }
- else {
- /* there is no point calling Parrot_ex_throw_from_c_args here, because
- PDB_backtrace can't deal with a missing to_ctx either. */
- exit_fatal(1, "No caller_ctx for continuation \%p.", _ccont);
- }
+ PMC *_caller_ctx, *_ctx;
+ PMC *_ccont, *_call_object;
- Parrot_pcc_set_continuation(interp, _ctx, _ret_cont);
- PARROT_CONTINUATION(_ret_cont)->from_ctx = _ctx;
+ _ctx = CURRENT_CONTEXT(interp);
+ _ccont = Parrot_pcc_get_continuation(interp, _ctx);
- _current_args = interp->current_args;
- interp->current_args = NULL;
+ _caller_ctx = Parrot_pcc_get_caller_ctx(interp, _ctx);
+ _call_object = Parrot_pcc_get_signature(interp, _ctx);
+ Parrot_pcc_set_signature(interp, _ctx, NULL);
+ { /* BEGIN PARMS SCOPE */
END
$e->emit(<<"END");
-$named_names
+$params_declarations
END
- $e->emit( <<"END", __FILE__, __LINE__ + 1 );
-
- interp->params_signature = _param_sig;
- parrot_pass_args(interp, _caller_ctx, _ctx, _current_args, _param_indexes,
- PARROT_PASS_PARAMS);
-
- if (PObj_get_FLAGS(_ccont) & SUB_FLAG_TAILCALL) {
- PObj_get_FLAGS(_ccont) &= ~SUB_FLAG_TAILCALL;
- Parrot_pcc_dec_recursion_depth(interp, _ctx);
- Parrot_pcc_set_caller_ctx(interp, _ctx, Parrot_pcc_get_caller_ctx(interp, _caller_ctx));
- interp->current_args = NULL;
- }
- /* BEGIN PARMS SCOPE */
- {
-END
- $e->emit(<<"END");
-$params_accessors
-END
- $e->emit( <<"END", __FILE__, __LINE__ + 1 );
-
- /* BEGIN PMETHOD BODY */
- {
+ if ($params_signature) {
+ $e->emit( <<"END", __FILE__, __LINE__ + 1 );
+ Parrot_pcc_fill_params_from_c_args(interp, _call_object, "$params_signature",
+ $params_varargs);
END
-
- my $method_returns = $self->name . "_returns:";
- $e_post->emit( <<"END", __FILE__, __LINE__ + 1 );
-
}
- goto no_return;
- /* END PMETHOD BODY */
-
+ $e->emit( <<"END", __FILE__, __LINE__ + 1 );
+ { /* BEGIN PMETHOD BODY */
END
- if ($qty_returns) {
- $e_post->emit( <<"END", __FILE__, __LINE__ + 1 );
-$method_returns
-
- if (! _caller_ctx) {
- /* there is no point calling Parrot_ex_throw_from_c_args here, because
- PDB_backtrace can't deal with a missing to_ctx either. */
- exit_fatal(1, "No caller_ctx for continuation \%p.", _ccont);
- }
- interp->returns_signature = _return_sig;
- parrot_pass_args(interp, _ctx, _caller_ctx, _return_indexes,
- Parrot_pcc_get_results(interp, _caller_ctx), PARROT_PASS_RESULTS);
-END
- }
$e_post->emit( <<"END", __FILE__, __LINE__ + 1 );
- /* END PARAMS SCOPE */
- }
+ } /* END PMETHOD BODY */
+ } /* END PARAMS SCOPE */
no_return:
- PObj_live_CLEAR(_param_sig);
- PObj_live_CLEAR(_return_sig);
- Parrot_pop_context(interp);
+ return;
END
$self->return_type('void');
$self->parameters('');
@@ -541,7 +508,7 @@
$vars .= $out_vars;
my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename );
- $e->emit(qq|Parrot_PCCINVOKE($fixed_params, "$signature", $vars);\n|);
+ $e->emit(qq|Parrot_pcc_invoke_method_from_c_args($fixed_params, "$signature", $vars);\n|);
$matched->replace( $match, $e );
}
@@ -625,7 +592,7 @@
flatten => 'f',
slurpy => 's',
optional => 'o',
- positional => 'p',
+ opt_flag => 'p',
);
my @arg_names = ($name);
Modified: trunk/lib/Parrot/Pmc2c/PMC/Object.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/PMC/Object.pm Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/lib/Parrot/Pmc2c/PMC/Object.pm Wed Oct 21 16:54:18 2009 (r41972)
@@ -34,6 +34,8 @@
my ( $return_prefix, $ret_suffix, $args, $sig, $return_type_char, $null_return ) =
$new_default_method->signature;
+ my ( $pcc_sig, $pcc_args, $pcc_result_decl, $pcc_return_stmt ) =
+ $new_default_method->pcc_signature;
my $void_return = $return_type_char eq 'v' ? 'return;' : '';
my $return = $return_type_char eq 'v' ? '' : $return_prefix;
my $superargs = $args;
@@ -53,8 +55,9 @@
PMC * const meth = Parrot_oo_find_vtable_override_for_class(interp, cur_class, meth_name);
if (!PMC_IS_NULL(meth)) {
- ${return}Parrot_run_meth_fromc_args$ret_suffix(interp, meth, pmc, meth_name, "$sig"$args);
- $void_return
+ $pcc_result_decl
+ Parrot_pcc_invoke_sub_from_c_args(interp, meth, "Pi$pcc_sig", pmc$pcc_args);
+ $pcc_return_stmt
}
/* method name is $vt_method_name */
EOC
Modified: trunk/runtime/parrot/include/test_more.pir
==============================================================================
--- trunk/runtime/parrot/include/test_more.pir Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/runtime/parrot/include/test_more.pir Wed Oct 21 16:54:18 2009 (r41972)
@@ -20,7 +20,7 @@
.local pmc exports, curr_namespace, test_namespace
curr_namespace = get_namespace
test_namespace = get_root_namespace [ 'parrot'; 'Test'; 'More' ]
- exports = split ' ', 'plan diag ok nok is is_deeply like isa_ok skip isnt todo throws_like'
+ exports = split ' ', 'plan diag ok nok is is_deeply like substring isa_ok skip isnt todo throws_like throws_substring'
test_namespace.'export_to'(curr_namespace, exports)
Modified: trunk/runtime/parrot/library/Test/More.pir
==============================================================================
--- trunk/runtime/parrot/library/Test/More.pir Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/runtime/parrot/library/Test/More.pir Wed Oct 21 16:54:18 2009 (r41972)
@@ -886,6 +886,85 @@
done:
.end
+=item C<throws_substring( codestring, text, description )>
+
+Takes PIR code in C<codestring> and a string to match in C<text>, as
+well as an optional message in C<description>. Passes a test if the PIR throws
+an exception that matches the pattern, fails the test otherwise.
+
+=cut
+
+.sub throws_substring
+ .param string target
+ .param string text
+ .param string description :optional
+
+ .local pmc test
+ get_hll_global test, [ 'Test'; 'More' ], '_test'
+
+ .local pmc comp
+ .local pmc compfun
+ .local pmc compiler
+ compiler = compreg 'PIR'
+
+ .local pmc eh
+ eh = new 'ExceptionHandler'
+ set_addr eh, handler # set handler label for exceptions
+ push_eh eh
+
+ compfun = compiler(target)
+ compfun() # eval the target code
+
+ pop_eh
+
+ # if it doesn't throw an exception, fail
+ test.'ok'( 0, description )
+ test.'diag'( 'no error thrown' )
+
+ goto done
+
+ handler:
+ .local pmc ex
+ .local string error_msg
+ .get_results (ex)
+ pop_eh
+ error_msg = ex
+ substring(error_msg, text, description)
+
+ done:
+.end
+
+=item C<substring( target, text, description )>
+
+Similar to is, but using the index opcode to compare the string passed as
+C<text> to the string passed as C<target>. It passes if C<text> is a substring
+of C<target> and fails otherwise. This will report the results with the
+optional test description in C<description>.
+
+=cut
+
+.sub substring
+ .param string target
+ .param string text
+ .param string description :optional
+
+ .local pmc test
+ .local string diagnostic
+ get_hll_global test, [ 'Test'; 'More' ], '_test'
+ $I0 = index target, text
+ $I0 = isne $I0, -1
+ test.'ok'( $I0, description )
+ if $I0 goto done
+ diagnostic = "substring failed: '"
+ diagnostic .= target
+ diagnostic .= "' does not contain '"
+ diagnostic .= text
+ diagnostic .= "'"
+ test.'diag'(diagnostic)
+ done:
+.end
+
+
=item C<like( target, pattern, description )>
Similar to is, but using the Parrot Grammar Engine to compare the string
Modified: trunk/src/call/context.c
==============================================================================
--- trunk/src/call/context.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/call/context.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -592,6 +592,45 @@
/*
+=item C<PMC* Parrot_pcc_get_signature(PARROT_INTERP, PMC *ctx)>
+
+Get call signature object of Context (in sub/method call).
+
+=cut
+
+*/
+
+PARROT_EXPORT
+PARROT_CAN_RETURN_NULL
+PMC*
+Parrot_pcc_get_signature(PARROT_INTERP, ARGIN(PMC *ctx))
+{
+ ASSERT_ARGS(Parrot_pcc_get_signature)
+ Parrot_Context const *c = get_context_struct_fast(interp, ctx);
+ return c->current_sig;
+}
+
+/*
+
+=item C<void Parrot_pcc_set_signature(PARROT_INTERP, PMC *ctx, PMC *sig_object)>
+
+Set signature of Context (in sub/method call).
+
+=cut
+
+*/
+
+PARROT_EXPORT
+void
+Parrot_pcc_set_signature(PARROT_INTERP, ARGIN(PMC *ctx), ARGIN_NULLOK(PMC *sig_object))
+{
+ ASSERT_ARGS(Parrot_pcc_set_signature)
+ Parrot_Context *c = get_context_struct_fast(interp, ctx);
+ c->current_sig = sig_object;
+}
+
+/*
+
=item C<PMC* Parrot_pcc_get_object(PARROT_INTERP, PMC *ctx)>
Get object of Context (in method call).
@@ -1158,6 +1197,7 @@
ctx->handlers = PMCNULL;
ctx->caller_ctx = NULL;
ctx->pred_offset = 0;
+ ctx->current_sig = PMCNULL;
ctx->current_sub = PMCNULL;
if (old) {
Modified: trunk/src/call/ops.c
==============================================================================
--- trunk/src/call/ops.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/call/ops.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -23,28 +23,6 @@
/* HEADERIZER HFILE: include/parrot/call.h */
-/* HEADERIZER BEGIN: static */
-/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CANNOT_RETURN_NULL
-static PMC * runops_args(PARROT_INTERP,
- ARGIN(PMC *sub),
- ARGIN_NULLOK(PMC *obj),
- SHIM(STRING *meth),
- ARGIN(const char *sig),
- va_list ap)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(5);
-
-#define ASSERT_ARGS_runops_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sub) \
- , PARROT_ASSERT_ARG(sig))
-/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
-/* HEADERIZER END: static */
-
#define STACKED_EXCEPTIONS 1
#define RUNLOOP_TRACE 0
@@ -132,577 +110,6 @@
interp->current_runloop_id = old_runloop_id;
}
-/*
-
-=item C<PMC * Parrot_runops_fromc(PARROT_INTERP, PMC *sub)>
-
-Runs the Parrot ops, called from C code. The function arguments are
-already setup according to Parrot calling conventions, the C<sub> argument
-is an invocable C<Sub> PMC.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CANNOT_RETURN_NULL
-PMC *
-Parrot_runops_fromc(PARROT_INTERP, ARGIN(PMC *sub))
-{
- ASSERT_ARGS(Parrot_runops_fromc)
- opcode_t offset, *dest;
- PMC *ctx;
-
- /* we need one return continuation with a NULL offset */
- PMC * const ret_c = new_ret_continuation_pmc(interp, NULL);
- interp->current_cont = ret_c;
-#if defined GC_VERBOSE && GC_VERBOSE
- PObj_report_SET(ret_c); /* s. also src/gc/api.c */
-#endif
- /* invoke the sub, which places the context of the sub in the
- * interpreter, and switches code segments if needed
- * Passing a dummy true destination copies registers
- */
- dest = VTABLE_invoke(interp, sub, (void*) 1);
- if (!dest)
- Parrot_ex_throw_from_c_args(interp, NULL, 1,
- "Subroutine returned a NULL address");
-
- ctx = CURRENT_CONTEXT(interp);
- offset = dest - interp->code->base.data;
- runops(interp, offset);
- return ctx;
-}
-
-
-/*
-
-=item C<static PMC * runops_args(PARROT_INTERP, PMC *sub, PMC *obj, STRING
-*meth, const char *sig, va_list ap)>
-
-Calls the PMC subroutine C<sub> with optional name C<meth>. If PMC object
-C<obj> is provided, the call is treated as a method call on that object.
-The function has a function signature C<sig> and a variadic argument list
-C<ap>.
-
-Signatures are similar to NCI:
-
- v ... void return
- I ... INTVAL (not Interpreter)
- N ... NUMVAL
- S ... STRING*
- P ... PMC*
-
-TODO: Update this list of possible signature elements.
-
-=cut
-
-*/
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CANNOT_RETURN_NULL
-static PMC *
-runops_args(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
- SHIM(STRING *meth), ARGIN(const char *sig), va_list ap)
-{
- ASSERT_ARGS(runops_args)
- opcode_t offset, *dest;
- PMC *ctx;
-
- char new_sig[10];
- const char *sig_p;
- PMC * const old_ctx = CURRENT_CONTEXT(interp);
-
- interp->current_cont = new_ret_continuation_pmc(interp, NULL);
- interp->current_object = obj;
- dest = VTABLE_invoke(interp, sub, NULL);
-
- if (!dest)
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_PARROT_USAGE_ERROR,
- "Subroutine returned a NULL address");
-
- /* The following code assumes that an empty signature is not valid,
- * check that condition and throws in that case.
- */
- if (sig[0] == '\0')
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_PARROT_USAGE_ERROR,
- "Invalid empty signature");
-
- if (PMC_IS_NULL(obj)) {
- /* skip over the return type */
- sig_p = sig + 1;
- }
- else if (sig[1] == 'O') {
- /* skip over the return type */
- sig_p = sig + 1;
- }
- else {
- const size_t len = strlen(sig);
- if (len > 8)
- Parrot_ex_throw_from_c_args(interp, NULL, 1,
- "too many arguments in runops_args");
-
- new_sig[0] = 'O';
- /* -1 from the end, +1 for the nul at the end */
- memcpy(new_sig+1, sig+1, len);
- sig_p = new_sig;
- }
-
- if (*sig_p && (dest[0] == PARROT_OP_get_params_pc
- || (sub->vtable->base_type == enum_class_ExceptionHandler
- && PARROT_CONTINUATION(sub)->current_results))) {
- dest = parrot_pass_args_fromc(interp, sig_p, dest, old_ctx, ap);
- }
-
- /*
- * main is now started with runops_args_fromc too
- * PASM subs usually don't have get_params
- * XXX we could check, if we are running main
- else
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "no get_params in sub");
- */
-
- ctx = CURRENT_CONTEXT(interp);
- offset = dest - interp->code->base.data;
- runops(interp, offset);
- return ctx;
-}
-
-
-/*
-
-=item C<void * Parrot_run_meth_fromc(PARROT_INTERP, PMC *sub, PMC *obj, STRING
-*meth)>
-
-Run a method sub from C. The function arguments are
-already setup according to Parrot calling conventions, the C<sub> argument
-is an invocable C<Sub> PMC.
-
-If a PMC return value is registered it is returned.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-void *
-Parrot_run_meth_fromc(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj), SHIM(STRING *meth))
-{
- ASSERT_ARGS(Parrot_run_meth_fromc)
- PMC *ctx;
- opcode_t offset, *dest;
-
- interp->current_cont = new_ret_continuation_pmc(interp, NULL);
- interp->current_object = obj;
- dest = VTABLE_invoke(interp, sub, (void *)1);
-
- if (!dest)
- Parrot_ex_throw_from_c_args(interp, NULL, 1,
- "Subroutine returned a NULL address");
-
- ctx = CURRENT_CONTEXT(interp);
- offset = dest - interp->code->base.data;
- runops(interp, offset);
- return set_retval(interp, 0, ctx);
-}
-
-/*
-
-=item C<PMC * Parrot_runops_fromc_args(PARROT_INTERP, PMC *sub, const char *sig,
-...)>
-
-Run parrot ops, called from C code, function arguments are passed as
-C<va_args> according to the signature. The C<sub> argument is an
-invocable C<Sub> PMC.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-PMC *
-Parrot_runops_fromc_args(PARROT_INTERP, ARGIN(PMC *sub), ARGIN(const char *sig), ...)
-{
- ASSERT_ARGS(Parrot_runops_fromc_args)
- va_list args;
- PMC *ctx;
- PMC *retval;
-
- va_start(args, sig);
- ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
- va_end(args);
- retval = (PMC *)set_retval(interp, *sig, ctx);
- return retval ? retval : PMCNULL;
-}
-
-/*
-
-=item C<void * Parrot_runops_fromc_args_event(PARROT_INTERP, PMC *sub, const
-char *sig, ...)>
-
-Run code from within event handlers. This variant deals with some reentrency
-issues. It also should do sanity checks, if e.g. the handler subroutine
-didn't return properly.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-void *
-Parrot_runops_fromc_args_event(PARROT_INTERP, ARGIN(PMC *sub),
- ARGIN(const char *sig), ...)
-{
- ASSERT_ARGS(Parrot_runops_fromc_args_event)
- va_list args;
- PMC *ctx;
- void *retval;
- /*
- * running code from event handlers isn't fully reentrant due to
- * these interpreter variables - mainly related to calls
- */
- opcode_t * const cargs = interp->current_args;
- opcode_t * const params = interp->current_params;
- opcode_t * const returns = interp->current_returns;
- PMC * const cont = interp->current_cont;
- /* what else ? */
-
- va_start(args, sig);
- ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
- va_end(args);
- retval = set_retval(interp, *sig, ctx);
-
- interp->current_args = cargs;
- interp->current_params = params;
- interp->current_returns = returns;
- interp->current_cont = cont;
- return retval;
-}
-
-/*
-
-=item C<INTVAL Parrot_runops_fromc_args_reti(PARROT_INTERP, PMC *sub, const char
-*sig, ...)>
-
-Called from C code, runs a Parrot subroutine C<sub>. The subroutine has
-function signature C<sig> and a C variadic argument list. Returns an
-C<INTVAL>.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-INTVAL
-Parrot_runops_fromc_args_reti(PARROT_INTERP, ARGIN(PMC *sub),
- ARGIN(const char *sig), ...)
-{
- ASSERT_ARGS(Parrot_runops_fromc_args_reti)
- va_list args;
- PMC *ctx;
- INTVAL retval;
-
- va_start(args, sig);
- ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
- va_end(args);
- retval = set_retval_i(interp, *sig, ctx);
- return retval;
-}
-
-/*
-
-=item C<FLOATVAL Parrot_runops_fromc_args_retf(PARROT_INTERP, PMC *sub, const
-char *sig, ...)>
-
-Called from C code, runs a Parrot subroutine C<sub>. The subroutine has
-function signature C<sig> and a C variadic argument list. Returns a
-C<FLOATVAL>.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-FLOATVAL
-Parrot_runops_fromc_args_retf(PARROT_INTERP, ARGIN(PMC *sub),
- ARGIN(const char *sig), ...)
-{
- ASSERT_ARGS(Parrot_runops_fromc_args_retf)
- va_list args;
- PMC *ctx;
- FLOATVAL retval;
-
- va_start(args, sig);
- ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
- va_end(args);
- retval = set_retval_f(interp, *sig, ctx);
- return retval;
-}
-
-/*
-
-=item C<void* Parrot_run_meth_fromc_args(PARROT_INTERP, PMC *sub, PMC *obj,
-STRING *meth, const char *sig, ...)>
-
-Called from C code, runs a Parrot subroutine C<sub> as a method on object
-C<obj>. The subroutine has function signature C<sig> and a C variadic argument
-list.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-void*
-Parrot_run_meth_fromc_args(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth), ARGIN(const char *sig), ...)
-{
- ASSERT_ARGS(Parrot_run_meth_fromc_args)
- va_list args;
- PMC *ctx;
- void *retval;
-
- va_start(args, sig);
- ctx = runops_args(interp, sub, obj, meth, sig, args);
- va_end(args);
- retval = set_retval(interp, *sig, ctx);
- return retval;
-}
-
-/*
-
-=item C<INTVAL Parrot_run_meth_fromc_args_reti(PARROT_INTERP, PMC *sub, PMC
-*obj, STRING *meth, const char *sig, ...)>
-
-Called from C code, runs a Parrot subroutine C<sub> as a method on object
-C<obj>. The subroutine has function signature C<sig> and a C variadic argument
-list. Returns an C<INTVAL>.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-INTVAL
-Parrot_run_meth_fromc_args_reti(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth), ARGIN(const char *sig), ...)
-{
- ASSERT_ARGS(Parrot_run_meth_fromc_args_reti)
- va_list args;
- PMC *ctx;
- INTVAL retval;
-
- va_start(args, sig);
- ctx = runops_args(interp, sub, obj, meth, sig, args);
- va_end(args);
- retval = set_retval_i(interp, *sig, ctx);
- return retval;
-}
-
-/*
-
-=item C<FLOATVAL Parrot_run_meth_fromc_args_retf(PARROT_INTERP, PMC *sub, PMC
-*obj, STRING *meth, const char *sig, ...)>
-
-Called from C code, runs a Parrot subroutine C<sub> as a method on object
-C<obj>. The subroutine has function signature C<sig> and a C variadic argument
-list C<args>. Returns a C<FLOATVAL>.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-FLOATVAL
-Parrot_run_meth_fromc_args_retf(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth), ARGIN(const char *sig), ...)
-{
- ASSERT_ARGS(Parrot_run_meth_fromc_args_retf)
- va_list args;
- PMC *ctx;
- FLOATVAL retval;
-
- va_start(args, sig);
- ctx = runops_args(interp, sub, obj, meth, sig, args);
- va_end(args);
- retval = set_retval_f(interp, *sig, ctx);
- return retval;
-}
-
-/*
-
-=item C<void * Parrot_runops_fromc_arglist(PARROT_INTERP, PMC *sub, const char
-*sig, va_list args)>
-
-Called from C code, runs a Parrot subroutine C<sub>.
-The subroutine has function signature C<sig> and a C C<va_list>
-argument list C<args>.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-void *
-Parrot_runops_fromc_arglist(PARROT_INTERP, ARGIN(PMC *sub),
- ARGIN(const char *sig), va_list args)
-{
- ASSERT_ARGS(Parrot_runops_fromc_arglist)
- PMC * const ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
- void * const retval = set_retval(interp, *sig, ctx);
-
- return retval;
-}
-
-/*
-
-=item C<INTVAL Parrot_runops_fromc_arglist_reti(PARROT_INTERP, PMC *sub, const
-char *sig, va_list args)>
-
-Called from C code, runs a Parrot subroutine C<sub>.
-The subroutine has function signature C<sig> and a C C<va_list>
-argument list C<args>. Returns an C<INTVAL>.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-INTVAL
-Parrot_runops_fromc_arglist_reti(PARROT_INTERP, ARGIN(PMC *sub),
- ARGIN(const char *sig), va_list args)
-{
- ASSERT_ARGS(Parrot_runops_fromc_arglist_reti)
- PMC * const ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
- const INTVAL retval = set_retval_i(interp, *sig, ctx);
-
- return retval;
-}
-
-/*
-
-=item C<FLOATVAL Parrot_runops_fromc_arglist_retf(PARROT_INTERP, PMC *sub, const
-char *sig, va_list args)>
-
-Called from C code, runs a Parrot subroutine C<sub>.
-The subroutine has function signature C<sig> and a C C<va_list>
-argument list C<args>. Returns an C<FLOATVAL>.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-FLOATVAL
-Parrot_runops_fromc_arglist_retf(PARROT_INTERP, ARGIN(PMC *sub),
- ARGIN(const char *sig), va_list args)
-{
- ASSERT_ARGS(Parrot_runops_fromc_arglist_retf)
- PMC * const ctx = runops_args(interp, sub, PMCNULL, NULL, sig, args);
- const FLOATVAL retval = set_retval_f(interp, *sig, ctx);
-
- return retval;
-}
-
-/*
-
-=item C<void* Parrot_run_meth_fromc_arglist(PARROT_INTERP, PMC *sub, PMC *obj,
-STRING *meth, const char *sig, va_list args)>
-
-Calls the subroutine C<sub> as a method on object C<obj>. The method to be
-called is named C<meth>, has the function signature C<sig> and arguments
-C<args>. C<args> is a C variadic argument list created with C<va_start>.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-void*
-Parrot_run_meth_fromc_arglist(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth), ARGIN(const char *sig), va_list args)
-{
- ASSERT_ARGS(Parrot_run_meth_fromc_arglist)
- PMC * const ctx = runops_args(interp, sub, obj, meth, sig, args);
- void * const retval = set_retval(interp, *sig, ctx);
-
- return retval;
-}
-
-/*
-
-=item C<INTVAL Parrot_run_meth_fromc_arglist_reti(PARROT_INTERP, PMC *sub, PMC
-*obj, STRING *meth, const char *sig, va_list args)>
-
-Calls the subroutine C<sub> as a method on object C<obj>. The method to be
-called is named C<meth>, has the function signature C<sig> and arguments
-C<args>. C<args> is a C variadic argument list created with C<va_start>.
-Returns an C<INTVAL>.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-PARROT_CAN_RETURN_NULL
-INTVAL
-Parrot_run_meth_fromc_arglist_reti(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth), ARGIN(const char *sig), va_list args)
-{
- ASSERT_ARGS(Parrot_run_meth_fromc_arglist_reti)
- PMC * const ctx = runops_args(interp, sub, obj, meth, sig, args);
- const INTVAL retval = set_retval_i(interp, *sig, ctx);
-
- return retval;
-}
-
-/*
-
-=item C<FLOATVAL Parrot_run_meth_fromc_arglist_retf(PARROT_INTERP, PMC *sub, PMC
-*obj, STRING *meth, const char *sig, va_list args)>
-
-Calls the subroutine C<sub> as a method on object C<obj>. The method to be
-called is named C<meth>, has the function signature C<sig> and arguments
-C<args>. C<args> is a C variadic argument list created with C<va_start>.
-Returns a C<FLOATVAL>.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_IGNORABLE_RESULT
-FLOATVAL
-Parrot_run_meth_fromc_arglist_retf(PARROT_INTERP, ARGIN(PMC *sub), ARGIN_NULLOK(PMC *obj),
- ARGIN(STRING *meth), ARGIN(const char *sig), va_list args)
-{
- ASSERT_ARGS(Parrot_run_meth_fromc_arglist_retf)
- PMC * const ctx = runops_args(interp, sub, obj, meth, sig, args);
- const FLOATVAL retval = set_retval_f(interp, *sig, ctx);
-
- return retval;
-}
/*
Modified: trunk/src/call/pcc.c
==============================================================================
--- trunk/src/call/pcc.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/call/pcc.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -29,310 +29,6 @@
/* HEADERIZER BEGIN: static */
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
-static void check_for_opt_flag(PARROT_INTERP,
- ARGMOD(call_state *st),
- int has_arg)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-static void check_named(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-static void clone_key_arg(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-static void commit_last_arg(PARROT_INTERP,
- int index,
- int cur,
- ARGMOD(opcode_t *n_regs_used),
- int seen_arrow,
- ARGIN(PMC * const *sigs),
- ARGMOD(opcode_t **indexes),
- ARGMOD(PMC *ctx),
- ARGIN_NULLOK(PMC *pmc),
- ARGIN(va_list *list))
- __attribute__nonnull__(1)
- __attribute__nonnull__(4)
- __attribute__nonnull__(6)
- __attribute__nonnull__(7)
- __attribute__nonnull__(8)
- __attribute__nonnull__(10)
- FUNC_MODIFIES(*n_regs_used)
- FUNC_MODIFIES(*indexes)
- FUNC_MODIFIES(*ctx);
-
-static void commit_last_arg_sig_object(PARROT_INTERP,
- int index,
- int cur,
- ARGMOD(opcode_t *n_regs_used),
- int seen_arrow,
- ARGIN(PMC * const *sigs),
- ARGMOD(opcode_t **indexes),
- ARGMOD(PMC *ctx),
- ARGIN(PMC *sig_obj))
- __attribute__nonnull__(1)
- __attribute__nonnull__(4)
- __attribute__nonnull__(6)
- __attribute__nonnull__(7)
- __attribute__nonnull__(8)
- __attribute__nonnull__(9)
- FUNC_MODIFIES(*n_regs_used)
- FUNC_MODIFIES(*indexes)
- FUNC_MODIFIES(*ctx);
-
-static void convert_arg_from_int(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-static void convert_arg_from_num(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-static void convert_arg_from_pmc(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-static void convert_arg_from_str(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-PARROT_CANNOT_RETURN_NULL
-static PMC * count_signature_elements(PARROT_INTERP,
- ARGIN(const char *signature),
- ARGMOD(PMC *args_sig),
- ARGMOD(PMC *results_sig),
- int flag)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- __attribute__nonnull__(4)
- FUNC_MODIFIES(*args_sig)
- FUNC_MODIFIES(*results_sig);
-
-static int fetch_arg_op(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-static int fetch_arg_sig(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-static void init_call_stats(ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- FUNC_MODIFIES(*st);
-
-static void init_first_dest_named(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-static int locate_named_named(PARROT_INTERP, ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-static void next_arg_sig(PARROT_INTERP, ARGMOD(call_state_item *sti))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*sti);
-
-static void null_val(int sig, ARGMOD(call_state *st))
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*st);
-
-PARROT_CAN_RETURN_NULL
-static const char * set_context_sig_params(PARROT_INTERP,
- ARGIN(const char *signature),
- ARGMOD(INTVAL *n_regs_used),
- ARGMOD(PMC **sigs),
- ARGMOD(opcode_t **indexes),
- ARGMOD(PMC *ctx),
- ARGMOD(PMC *sig_obj))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- __attribute__nonnull__(4)
- __attribute__nonnull__(5)
- __attribute__nonnull__(6)
- __attribute__nonnull__(7)
- FUNC_MODIFIES(*n_regs_used)
- FUNC_MODIFIES(*sigs)
- FUNC_MODIFIES(*indexes)
- FUNC_MODIFIES(*ctx)
- FUNC_MODIFIES(*sig_obj);
-
-static void set_context_sig_returns(PARROT_INTERP,
- ARGMOD(PMC *ctx),
- ARGMOD(opcode_t **indexes),
- ARGIN_NULLOK(const char *ret_x),
- ARGMOD(PMC *result_list))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- __attribute__nonnull__(5)
- FUNC_MODIFIES(*ctx)
- FUNC_MODIFIES(*indexes)
- FUNC_MODIFIES(*result_list);
-
-static void set_context_sig_returns_varargs(PARROT_INTERP,
- ARGMOD(PMC *ctx),
- ARGMOD(opcode_t **indexes),
- ARGIN(const char *ret_x),
- va_list returns)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- __attribute__nonnull__(4)
- FUNC_MODIFIES(*ctx)
- FUNC_MODIFIES(*indexes);
-
-static int set_retval_util(PARROT_INTERP,
- ARGIN(const char *sig),
- ARGIN(PMC *ctx),
- ARGMOD(call_state *st))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- __attribute__nonnull__(4)
- FUNC_MODIFIES(*st);
-
-static void start_flatten(PARROT_INTERP,
- ARGMOD(call_state *st),
- ARGIN(PMC *p_arg))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- FUNC_MODIFIES(*st);
-
-static void store_arg(PARROT_INTERP,
- ARGIN(const call_state *st),
- INTVAL idx)
- __attribute__nonnull__(1)
- __attribute__nonnull__(2);
-
-static void too_few(PARROT_INTERP,
- ARGIN(const call_state *st),
- ARGIN(const char *action))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3);
-
-static void too_many(PARROT_INTERP,
- ARGIN(const call_state *st),
- ARGIN(const char *action))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3);
-
-#define ASSERT_ARGS_check_for_opt_flag __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_check_named __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_clone_key_arg __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_commit_last_arg __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(n_regs_used) \
- , PARROT_ASSERT_ARG(sigs) \
- , PARROT_ASSERT_ARG(indexes) \
- , PARROT_ASSERT_ARG(ctx) \
- , PARROT_ASSERT_ARG(list))
-#define ASSERT_ARGS_commit_last_arg_sig_object __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(n_regs_used) \
- , PARROT_ASSERT_ARG(sigs) \
- , PARROT_ASSERT_ARG(indexes) \
- , PARROT_ASSERT_ARG(ctx) \
- , PARROT_ASSERT_ARG(sig_obj))
-#define ASSERT_ARGS_convert_arg_from_int __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_convert_arg_from_num __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_convert_arg_from_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_convert_arg_from_str __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_count_signature_elements __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(signature) \
- , PARROT_ASSERT_ARG(args_sig) \
- , PARROT_ASSERT_ARG(results_sig))
-#define ASSERT_ARGS_fetch_arg_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_fetch_arg_sig __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_init_call_stats __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_init_first_dest_named __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_locate_named_named __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_next_arg_sig __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sti))
-#define ASSERT_ARGS_null_val __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_set_context_sig_params __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(signature) \
- , PARROT_ASSERT_ARG(n_regs_used) \
- , PARROT_ASSERT_ARG(sigs) \
- , PARROT_ASSERT_ARG(indexes) \
- , PARROT_ASSERT_ARG(ctx) \
- , PARROT_ASSERT_ARG(sig_obj))
-#define ASSERT_ARGS_set_context_sig_returns __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(ctx) \
- , PARROT_ASSERT_ARG(indexes) \
- , PARROT_ASSERT_ARG(result_list))
-#define ASSERT_ARGS_set_context_sig_returns_varargs \
- __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(ctx) \
- , PARROT_ASSERT_ARG(indexes) \
- , PARROT_ASSERT_ARG(ret_x))
-#define ASSERT_ARGS_set_retval_util __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sig) \
- , PARROT_ASSERT_ARG(ctx) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_start_flatten __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st) \
- , PARROT_ASSERT_ARG(p_arg))
-#define ASSERT_ARGS_store_arg __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st))
-#define ASSERT_ARGS_too_few __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st) \
- , PARROT_ASSERT_ARG(action))
-#define ASSERT_ARGS_too_many __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(st) \
- , PARROT_ASSERT_ARG(action))
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: static */
@@ -342,2327 +38,6 @@
/*
-=item C<PMC* Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP, PMC *obj,
-const char *sig, va_list args)>
-
-Converts a varargs list into a CallSignature PMC. The CallSignature stores the
-original short signature string and an array of integer types to pass on to the
-multiple dispatch search.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-PARROT_WARN_UNUSED_RESULT
-PARROT_CANNOT_RETURN_NULL
-PMC*
-Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP, ARGIN_NULLOK(PMC *obj),
- ARGIN(const char *sig), va_list args)
-{
- ASSERT_ARGS(Parrot_pcc_build_sig_object_from_varargs)
- PMC *type_tuple = PMCNULL;
- PMC *returns = PMCNULL;
- PMC * const call_object = pmc_new(interp, enum_class_CallSignature);
- STRING *string_sig = Parrot_str_new_constant(interp, sig);
- const INTVAL sig_len = Parrot_str_byte_length(interp, string_sig);
- INTVAL in_return_sig = 0;
- INTVAL i;
-
- if (!sig_len)
- return call_object;
-
- VTABLE_set_string_native(interp, call_object, string_sig);
-
- /* Process the varargs list */
- for (i = 0; i < sig_len; ++i) {
- const INTVAL type = Parrot_str_indexed(interp, string_sig, i);
-
- /* Only create the returns array if it's needed */
- if (in_return_sig && PMC_IS_NULL(returns)) {
- returns = pmc_new(interp, enum_class_ResizablePMCArray);
- VTABLE_set_attr_str(interp, call_object, CONST_STRING(interp, "results"), returns);
- }
-
- if (in_return_sig) {
- STRING * const signature = CONST_STRING(interp, "signature");
- /* Returns store the original passed-in pointer so they can pass
- * the result back to the caller. */
- PMC * const val_pointer = pmc_new(interp, enum_class_CPointer);
- VTABLE_push_pmc(interp, returns, val_pointer);
-
- switch (type) {
- case 'I':
- VTABLE_set_pointer(interp, val_pointer, (void *)va_arg(args, INTVAL *));
- VTABLE_set_string_keyed_str(interp, val_pointer, signature, CONST_STRING(interp, "I"));
- break;
- case 'N':
- VTABLE_set_pointer(interp, val_pointer, (void *)va_arg(args, FLOATVAL *));
- VTABLE_set_string_keyed_str(interp, val_pointer, signature, CONST_STRING(interp, "N"));
- break;
- case 'S':
- VTABLE_set_pointer(interp, val_pointer, (void *)va_arg(args, STRING **));
- VTABLE_set_string_keyed_str(interp, val_pointer, signature, CONST_STRING(interp, "S"));
- break;
- case 'P':
- VTABLE_set_pointer(interp, val_pointer, (void *)va_arg(args, PMC **));
- VTABLE_set_string_keyed_str(interp, val_pointer, signature, CONST_STRING(interp, "P"));
- break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Multiple Dispatch: invalid argument type %c!", type);
- }
- }
- else {
- /* Regular arguments just set the value */
- switch (type) {
- case 'I':
- VTABLE_push_integer(interp, call_object, va_arg(args, INTVAL));
- break;
- case 'N':
- VTABLE_push_float(interp, call_object, va_arg(args, FLOATVAL));
- break;
- case 'S':
- VTABLE_push_string(interp, call_object, va_arg(args, STRING *));
- break;
- case 'P':
- VTABLE_push_pmc(interp, call_object, va_arg(args, PMC *));
- break;
- case '-':
- i++; /* skip '>' */
- in_return_sig = 1;
- break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Multiple Dispatch: invalid argument type %c!", type);
- }
- }
- }
-
- /* Check if we have an invocant, and add it to the front of the arguments */
- if (!PMC_IS_NULL(obj)) {
- string_sig = Parrot_str_concat(interp, CONST_STRING(interp, "Pi"), string_sig, 0);
- VTABLE_set_string_native(interp, call_object, string_sig);
- VTABLE_unshift_pmc(interp, call_object, obj);
- }
-
- /* Build a type_tuple for multiple dispatch */
- type_tuple = Parrot_mmd_build_type_tuple_from_sig_obj(interp, call_object);
- VTABLE_set_pmc(interp, call_object, type_tuple);
-
- return call_object;
-}
-
-
-/*
-
-=item C<void Parrot_init_arg_nci(PARROT_INTERP, call_state *st, const char
-*sig)>
-
-Initializes the argument passing state C<call_state> for the given NCI
-signature.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-void
-Parrot_init_arg_nci(PARROT_INTERP, ARGOUT(call_state *st),
- ARGIN(const char *sig))
-{
- ASSERT_ARGS(Parrot_init_arg_nci)
- init_call_stats(st);
-
- if (PMC_IS_NULL(interp->args_signature))
- Parrot_init_arg_op(interp, CURRENT_CONTEXT(interp),
- interp->current_args, &st->src);
- else
- Parrot_init_arg_indexes_and_sig_pmc(interp, CURRENT_CONTEXT(interp),
- interp->current_args, interp->args_signature, &st->src);
-
- Parrot_init_arg_sig(interp, CURRENT_CONTEXT(interp), sig, NULL, &st->dest);
-}
-
-
-/*
-
-=item C<void Parrot_init_ret_nci(PARROT_INTERP, call_state *st, const char
-*sig)>
-
-Initializes the return value, passing state C<call_state> for the given NCI
-signature.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-void
-Parrot_init_ret_nci(PARROT_INTERP, ARGOUT(call_state *st), ARGIN(const char *sig))
-{
- ASSERT_ARGS(Parrot_init_ret_nci)
- PMC *ctx = CURRENT_CONTEXT(interp);
- PMC * const current_cont = Parrot_pcc_get_continuation(interp, ctx);
-
- /* if this NCI call was a tailcall, return results to caller's get_results
- * this also means that we pass the caller's register base pointer */
- if (SUB_FLAG_TAILCALL_ISSET(current_cont))
- ctx = PARROT_CONTINUATION(current_cont)->to_ctx;
-
- /* TODO simplify all */
- Parrot_init_arg_sig(interp, CURRENT_CONTEXT(interp), sig, NULL, &st->src);
-
- /* Non-constant signatures are stored in ctx->results_signature instead of
- * in the constants table. */
- if (Parrot_pcc_get_results_signature(interp, ctx))
- Parrot_init_arg_indexes_and_sig_pmc(interp, ctx,
- Parrot_pcc_get_results(interp, ctx),
- Parrot_pcc_get_results_signature(interp, ctx), &st->dest);
- else
- Parrot_init_arg_op(interp, ctx, Parrot_pcc_get_results(interp, ctx), &st->dest);
-
-}
-
-
-/*
-
-=item C<int Parrot_init_arg_indexes_and_sig_pmc(PARROT_INTERP, PMC *ctx,
-opcode_t *indexes, PMC *sig_pmc, call_state_item *sti)>
-
-Initializes argument transfer with given context registers, register indexes,
-and a signature PMC.
-
-All C<Parrot_init_arg*> functions can be used for either source or destination,
-by passing either C<&st.src> or C<&st.dest> of a C<call_state> structure.
-
-These functions return 0 if no arguments are present, or 1 on success.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-int
-Parrot_init_arg_indexes_and_sig_pmc(PARROT_INTERP, ARGIN(PMC *ctx),
- ARGIN_NULLOK(opcode_t *indexes), ARGIN_NULLOK(PMC *sig_pmc),
- ARGMOD(call_state_item *sti))
-{
- ASSERT_ARGS(Parrot_init_arg_indexes_and_sig_pmc)
- if (PMC_IS_NULL(sig_pmc) && indexes) {
- ++indexes;
- sig_pmc = Parrot_pcc_get_pmc_constant(interp, ctx, *indexes);
- ASSERT_SIG_PMC(sig_pmc);
- ++indexes;
- }
-
- sti->used = 1;
- sti->i = 0;
- sti->n = 0;
- sti->mode = CALL_STATE_OP;
- sti->ctx = ctx;
- sti->sig = 0;
- sti->slurp = NULL;
-
- if (indexes) {
- ASSERT_SIG_PMC(sig_pmc);
- sti->u.op.signature = sig_pmc;
- sti->u.op.pc = indexes;
- sti->n = VTABLE_elements(interp, sig_pmc);
-
- /* initialize sti->sig */
- if (sti->n)
- next_arg_sig(interp, sti);
- }
-
- return sti->n > 0;
-}
-
-
-/*
-
-=item C<int Parrot_init_arg_op(PARROT_INTERP, PMC *ctx, opcode_t *pc,
-call_state_item *sti)>
-
-Initializes argument transfer with given context registers and opcode location
-of a C<get_*> or C<set_*> argument opcode.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-int
-Parrot_init_arg_op(PARROT_INTERP, ARGIN(PMC *ctx),
- ARGIN_NULLOK(opcode_t *pc), ARGIN(call_state_item *sti))
-{
- ASSERT_ARGS(Parrot_init_arg_op)
- PMC *sig_pmc = PMCNULL;
-
- if (pc) {
- if (*pc == 0)
- return 0;
- ++pc;
- sig_pmc = Parrot_pcc_get_pmc_constant(interp, ctx, *pc);
- ASSERT_SIG_PMC(sig_pmc);
- ++pc;
- }
-
- return Parrot_init_arg_indexes_and_sig_pmc(interp, ctx, pc, sig_pmc, sti);
-}
-
-
-/*
-
-=item C<int Parrot_init_arg_sig(PARROT_INTERP, PMC *ctx, const char *sig, void
-*ap, call_state_item *sti)>
-
-Initializes argument transfer with given code segment (holding the
-const_table), registers, function signature, and arguments.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-int
-Parrot_init_arg_sig(PARROT_INTERP, ARGIN(PMC *ctx),
- ARGIN(const char *sig), ARGIN_NULLOK(void *ap),
- ARGMOD(call_state_item *sti))
-{
- ASSERT_ARGS(Parrot_init_arg_sig)
- sti->used = 1;
- sti->i = 0;
- sti->n = 0;
- sti->mode = CALL_STATE_SIG;
- sti->ctx = ctx;
- sti->sig = 0;
-
- if (*sig) {
- sti->u.sig.sig = sig;
- sti->u.sig.ap = ap;
- sti->n = strlen(sig);
-
- /* initialize st->sig */
- if (sti->n)
- next_arg_sig(interp, sti);
- }
-
- return sti->n > 0;
-}
-
-
-/*
-
-=item C<static void start_flatten(PARROT_INTERP, call_state *st, PMC *p_arg)>
-
-Marks the source state as flattening with the passed PMC being flattened and
-fetches the first arg from the flattened set.
-
-=cut
-
-*/
-
-static void
-start_flatten(PARROT_INTERP, ARGMOD(call_state *st), ARGIN(PMC *p_arg))
-{
- ASSERT_ARGS(start_flatten)
- if (PARROT_ARG_NAME_ISSET(st->src.sig)) {
-
- /* src ought to be an hash */
- if (!VTABLE_does(interp, p_arg, CONST_STRING(interp, "hash")))
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION, "argument doesn't hash");
-
- /* create key needed to iterate the hash */
- st->key = pmc_new(interp, enum_class_Key);
- VTABLE_set_integer_native(interp, st->key, 0);
- SETATTR_Key_next_key(interp, st->key, (PMC *)INITBucketIndex);
- }
- else {
- /* src ought to be an array */
- if (!VTABLE_does(interp, p_arg, CONST_STRING(interp, "array")))
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION, "argument doesn't array");
- }
-
- st->src.mode |= CALL_STATE_FLATTEN;
- st->src.slurp = p_arg;
- st->src.slurp_i = 0;
- st->src.slurp_n = VTABLE_elements(interp, p_arg);
-
- /* the -1 is because the :flat PMC itself doesn't count. */
- st->n_actual_args += st->src.slurp_n - 1;
-}
-
-
-/*
-
-=item C<static void next_arg_sig(PARROT_INTERP, call_state_item *sti)>
-
-Moves the call state to the next argument in the signature, calculating which
-type of argument/parameter to get next. The index gets increased elsewhere.
-
-=cut
-
-*/
-
-static void
-next_arg_sig(PARROT_INTERP, ARGMOD(call_state_item *sti))
-{
- ASSERT_ARGS(next_arg_sig)
- switch (sti->mode & CALL_S_D_MASK) {
- case CALL_STATE_OP:
- sti->sig = VTABLE_get_integer_keyed_int(interp,
- sti->u.op.signature, sti->i);
- break;
- case CALL_STATE_SIG:
- switch (sti->u.sig.sig[sti->i]) {
- case 'I':
- sti->sig = PARROT_ARG_INTVAL; break;
- case 'N':
- sti->sig = PARROT_ARG_FLOATVAL; break;
- case 'S':
- sti->sig = PARROT_ARG_STRING; break;
- case 'O':
- case 'P':
- sti->sig = PARROT_ARG_PMC; break;
- case '@':
- sti->sig = PARROT_ARG_PMC | PARROT_ARG_SLURPY_ARRAY; break;
- case 'F':
- sti->sig = PARROT_ARG_PMC | PARROT_ARG_FLATTEN; break;
- default:
- break;
- }
- break;
- default:
- break;
- }
-}
-
-
-/*
-
-=item C<static int fetch_arg_sig(PARROT_INTERP, call_state *st)>
-
-Fetches the next argument from the signature in the given call state.
-
-=cut
-
-*/
-
-static int
-fetch_arg_sig(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(fetch_arg_sig)
- va_list * const ap = (va_list *)(st->src.u.sig.ap);
-
- switch (st->src.sig & PARROT_ARG_TYPE_MASK) {
- case PARROT_ARG_INTVAL:
- UVal_int(st->val) = va_arg(*ap, INTVAL);
- break;
- case PARROT_ARG_STRING:
- UVal_str(st->val) = va_arg(*ap, STRING *);
- break;
- case PARROT_ARG_FLOATVAL:
- UVal_num(st->val) = va_arg(*ap, FLOATVAL);
- break;
- case PARROT_ARG_PMC:
- if (st->src.u.sig.sig[st->src.i] == 'O')
- UVal_pmc(st->val) = Parrot_pcc_get_object(interp, CURRENT_CONTEXT(interp));
- else
- UVal_pmc(st->val) = va_arg(*ap, PMC *);
-
- if (st->src.sig & PARROT_ARG_FLATTEN) {
- int retval;
- start_flatten(interp, st, UVal_pmc(st->val));
-
- /* if the :flat arg is empty, just go to the next arg */
- if (!st->src.slurp_n) {
- st->src.mode &= ~CALL_STATE_FLATTEN;
- st->src.i++;
- }
-
- st->src.used = 1;
- retval = Parrot_fetch_arg(interp, st);
-
- return retval;
- }
- break;
- default:
- break;
- }
-
- st->src.i++;
- return 1;
-}
-
-
-/*
-
-=item C<static int fetch_arg_op(PARROT_INTERP, call_state *st)>
-
-Fetches an argument from the appropriate context.
-
-=cut
-
-*/
-
-static int
-fetch_arg_op(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(fetch_arg_op)
- const int constant = PARROT_ARG_CONSTANT_ISSET(st->src.sig);
- const INTVAL idx = st->src.u.op.pc[st->src.i];
-
- switch (PARROT_ARG_TYPE_MASK_MASK(st->src.sig)) {
- case PARROT_ARG_INTVAL:
- UVal_int(st->val) = constant ? idx : CTX_REG_INT(st->src.ctx, idx);
- break;
- case PARROT_ARG_STRING:
- {
- /* ensure that callees don't modify constant caller strings */
- if (constant)
- UVal_str(st->val) = Parrot_str_new_COW(interp,
- Parrot_pcc_get_string_constant(interp, st->src.ctx, idx));
- else
- UVal_str(st->val) = CTX_REG_STR(st->src.ctx, idx);
-
- break;
- }
- case PARROT_ARG_FLOATVAL:
- UVal_num(st->val) = constant
- ? Parrot_pcc_get_num_constant(interp, st->src.ctx, idx)
- : CTX_REG_NUM(st->src.ctx, idx);
- break;
- case PARROT_ARG_PMC:
- UVal_pmc(st->val) = constant
- ? Parrot_pcc_get_pmc_constant(interp, st->src.ctx, idx)
- : CTX_REG_PMC(st->src.ctx, idx);
-
- if (st->src.sig & PARROT_ARG_FLATTEN) {
- int retval;
- start_flatten(interp, st, UVal_pmc(st->val));
-
- /* if the :flat arg is empty, just go to the next arg */
- if (!st->src.slurp_n) {
- st->src.mode &= ~CALL_STATE_FLATTEN;
- st->src.i++;
- }
-
- st->src.used = 1;
- retval = Parrot_fetch_arg(interp, st);
-
- return retval;
- }
- break;
- default:
- break;
- }
-
- st->src.i++;
- return 1;
-}
-
-
-/*
-
-=item C<int Parrot_fetch_arg(PARROT_INTERP, call_state *st)>
-
-Fetches an argument from the current call state object. Retrieves the
-next argument in the parameter list, or the next argument in a flattened
-array, if given. If the parameter is a named object, fetches both the
-name and the value.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-int
-Parrot_fetch_arg(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(Parrot_fetch_arg)
- if (!st->src.used)
- return 1;
-
- if (st->src.i >= st->src.n)
- return 0;
-
- st->src.used = 0;
-
- next_arg_sig(interp, &st->src);
-
- /* check if we're supposed to continue a :flat argument */
- if (st->src.mode & CALL_STATE_FLATTEN) {
- PARROT_ASSERT(st->src.slurp_i < st->src.slurp_n);
- if (!PMC_IS_NULL(st->key)) {
- st->src.slurp_i++;
- st->name = (STRING *)parrot_hash_get_idx(interp,
- (Hash *)VTABLE_get_pointer(interp, st->src.slurp),
- st->key);
- PARROT_ASSERT(st->name);
- UVal_pmc(st->val) = VTABLE_get_pmc_keyed_str(interp,
- st->src.slurp, st->name);
- }
- else {
- UVal_pmc(st->val) = VTABLE_get_pmc_keyed_int(interp,
- st->src.slurp, st->src.slurp_i++);
- }
-
- st->src.sig = PARROT_ARG_PMC;
-
- /* done with flattening */
- if (st->src.slurp_i == st->src.slurp_n) {
- st->src.mode &= ~CALL_STATE_FLATTEN;
-
- st->key = PMCNULL;
- st->src.i++;
- }
-
- return 1;
- }
-
- /* If we're at a named arg, store the name and then get the next arg, which
- * is the actual value of the named arg. */
- if ((st->src.sig & PARROT_ARG_NAME)
- && !(st->src.sig & PARROT_ARG_FLATTEN)) {
- fetch_arg_op(interp, st);
- st->name = UVal_str(st->val);
- next_arg_sig(interp, &st->src);
- }
-
- switch (st->src.mode & CALL_S_D_MASK) {
- case CALL_STATE_OP:
- return fetch_arg_op(interp, st);
- case CALL_STATE_SIG:
- return fetch_arg_sig(interp, st);
- default:
- Parrot_ex_throw_from_c_args(interp, NULL, 1,
- "invalid call state mode");
- }
-}
-
-
-/*
-
-=item C<int Parrot_fetch_arg_nci(PARROT_INTERP, call_state *st)>
-
-Fetches the next argument from the call state and converts it to the proper
-data type for the call signature. If the next argument is a slurpy array,
-all the remaining arguments are slurped together into a ResizablePMCArray
-PMC which is then set as the PMC value of the call_state object.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-int
-Parrot_fetch_arg_nci(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(Parrot_fetch_arg_nci)
- next_arg_sig(interp, &st->dest);
-
- if (st->dest.sig & PARROT_ARG_SLURPY_ARRAY) {
- PMC * const slurped = pmc_new(interp,
- Parrot_get_ctx_HLL_type(interp, enum_class_ResizablePMCArray));
-
- PARROT_ASSERT((st->dest.sig & PARROT_ARG_TYPE_MASK) == PARROT_ARG_PMC);
-
- while (Parrot_fetch_arg(interp, st)) {
- st->src.used = 1;
- Parrot_convert_arg(interp, st);
- VTABLE_push_pmc(interp, slurped, UVal_pmc(st->val));
- }
-
- UVal_pmc(st->val) = slurped;
- }
- else {
- Parrot_fetch_arg(interp, st);
- st->src.used = 1;
- Parrot_convert_arg(interp, st);
- }
-
- st->dest.i++;
- return 1;
-}
-
-
-/*
-
-=item C<static void convert_arg_from_int(PARROT_INTERP, call_state *st)>
-
-Autoboxes an int into the expected container type.
-
-=cut
-
-*/
-
-static void
-convert_arg_from_int(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(convert_arg_from_int)
- switch (st->dest.sig & PARROT_ARG_TYPE_MASK) {
- case PARROT_ARG_FLOATVAL:
- UVal_num(st->val) = (FLOATVAL)UVal_int(st->val);
- break;
- case PARROT_ARG_STRING:
- UVal_str(st->val) = Parrot_str_from_int(interp, UVal_int(st->val));
- break;
- case PARROT_ARG_PMC:
- {
- PMC * const d = pmc_new(interp,
- Parrot_get_ctx_HLL_type(interp, enum_class_Integer));
-
- VTABLE_set_integer_native(interp, d, UVal_int(st->val));
- UVal_pmc(st->val) = d;
- }
- break;
- default:
- break;
- }
-}
-
-
-/*
-
-=item C<static void convert_arg_from_num(PARROT_INTERP, call_state *st)>
-
-Autoboxes a num into the expected container type.
-
-=cut
-
-*/
-
-static void
-convert_arg_from_num(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(convert_arg_from_num)
- switch (st->dest.sig & PARROT_ARG_TYPE_MASK) {
- case PARROT_ARG_INTVAL:
- UVal_int(st->val) = (INTVAL)UVal_num(st->val);
- break;
- case PARROT_ARG_STRING:
- UVal_str(st->val) = Parrot_str_from_num(interp, UVal_num(st->val));
- break;
- case PARROT_ARG_PMC:
- {
- PMC * const d = pmc_new(interp,
- Parrot_get_ctx_HLL_type(interp, enum_class_Float));
-
- VTABLE_set_number_native(interp, d, UVal_num(st->val));
- UVal_pmc(st->val) = d;
- }
- break;
- default:
- break;
- }
-}
-
-
-/*
-
-=item C<static void convert_arg_from_str(PARROT_INTERP, call_state *st)>
-
-Autoboxes a string primitive to the expected container type.
-
-=cut
-
-*/
-
-static void
-convert_arg_from_str(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(convert_arg_from_str)
- switch (st->dest.sig & PARROT_ARG_TYPE_MASK) {
- case PARROT_ARG_INTVAL:
- UVal_int(st->val) = Parrot_str_to_int(interp, UVal_str(st->val));
- break;
- case PARROT_ARG_FLOATVAL:
- UVal_num(st->val) = Parrot_str_to_num(interp, UVal_str(st->val));
- break;
- case PARROT_ARG_PMC:
- {
- PMC * const d = pmc_new(interp,
- Parrot_get_ctx_HLL_type(interp, enum_class_String));
-
- VTABLE_set_string_native(interp, d, UVal_str(st->val));
- UVal_pmc(st->val) = d;
- }
- break;
- default:
- break;
- }
-}
-
-
-/*
-
-=item C<static void convert_arg_from_pmc(PARROT_INTERP, call_state *st)>
-
-Unboxes a PMC to the expected primitive type.
-
-=cut
-
-*/
-
-static void
-convert_arg_from_pmc(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(convert_arg_from_pmc)
- switch (st->dest.sig & PARROT_ARG_TYPE_MASK) {
- case PARROT_ARG_INTVAL:
- UVal_int(st->val) = VTABLE_get_integer(interp, UVal_pmc(st->val));
- break;
- case PARROT_ARG_FLOATVAL:
- UVal_num(st->val) = VTABLE_get_number(interp, UVal_pmc(st->val));
- break;
- case PARROT_ARG_STRING:
- UVal_str(st->val) = VTABLE_get_string(interp, UVal_pmc(st->val));
- break;
- default:
- break;
- }
-}
-
-
-/*
-
-=item C<static void check_for_opt_flag(PARROT_INTERP, call_state *st, int
-has_arg)>
-
-Processes the next argument, if it has the optional flag set.
-Otherwise moves on.
-
-=cut
-
-*/
-
-static void
-check_for_opt_flag(PARROT_INTERP, ARGMOD(call_state *st), int has_arg)
-{
- ASSERT_ARGS(check_for_opt_flag)
- INTVAL idx;
- call_state_item * const dest = &st->dest;
-
- ++st->optionals;
-
- /* look at the next arg */
- dest->i++;
- if (dest->i >= dest->n)
- return;
-
- next_arg_sig(interp, dest);
-
- /* if this isn't an :opt_flag argument, we need to reset things
- * and go to the next argument */
- if (!(st->dest.sig & PARROT_ARG_OPT_FLAG)) {
- dest->i--;
- return;
- }
-
- /* we're at an :opt_flag argument, so actually store something */
- idx = st->dest.u.op.pc[st->dest.i];
-
- --st->params;
- PARROT_ASSERT(idx >= 0);
- CTX_REG_INT(st->dest.ctx, idx) = has_arg;
-}
-
-
-/*
-
-=item C<static void clone_key_arg(PARROT_INTERP, call_state *st)>
-
-Replaces any src registers by their values (done inside clone). This needs a
-test for tailcalls too, but I think there is no syntax to pass a key to a
-tailcalled function or method.
-
-=cut
-
-*/
-
-static void
-clone_key_arg(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(clone_key_arg)
- PMC *key = UVal_pmc(st->val);
-
- if (!key)
- return;
-
- if (key->vtable->base_type != enum_class_Key)
- return;
-
- for (; key; key = VTABLE_shift_pmc(interp, key)) {
- /* register keys have to be cloned */
- if (PObj_get_FLAGS(key) & KEY_register_FLAG) {
- INTVAL n_regs_used[4];
- Regs_ni bp;
- Regs_ps bp_ps;
-
- /* clone sets key values according to refered register items */
- bp = *Parrot_pcc_get_regs_ni(interp, CURRENT_CONTEXT(interp));
- bp_ps = *Parrot_pcc_get_regs_ps(interp, CURRENT_CONTEXT(interp));
- memcpy(n_regs_used, CONTEXT(interp)->n_regs_used, 4 * sizeof (INTVAL));
-
- Parrot_pcc_set_regs_ni(interp, CURRENT_CONTEXT(interp),
- Parrot_pcc_get_regs_ni(interp, st->src.ctx));
- Parrot_pcc_set_regs_ps(interp, CURRENT_CONTEXT(interp),
- Parrot_pcc_get_regs_ps(interp, st->src.ctx));
- memcpy(CONTEXT(interp)->n_regs_used,
- Parrot_pcc_get_context_struct(interp, st->src.ctx),
- 4 * sizeof (INTVAL));
-
- UVal_pmc(st->val) = VTABLE_clone(interp, key);
-
- Parrot_pcc_set_regs_ni(interp, CURRENT_CONTEXT(interp), &bp);
- Parrot_pcc_set_regs_ps(interp, CURRENT_CONTEXT(interp), &bp_ps);
- memcpy(CONTEXT(interp)->n_regs_used, n_regs_used, 4 * sizeof (INTVAL));
-
- return;
- }
- }
-}
-
-
-/*
-
-=item C<static void init_first_dest_named(PARROT_INTERP, call_state *st)>
-
-Initializes dest calling state for the first named arg.
-
-=cut
-
-*/
-
-static void
-init_first_dest_named(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(init_first_dest_named)
- int i, n_named;
-
- if (st->dest.mode & CALL_STATE_SIG)
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "Can't call C function with named arguments");
-
- st->first_named = st->dest.i;
- n_named = 0;
-
- /* 1) if we were slurpying positional args, we are done, turn it off
- * 2) set destination named args bit */
- st->dest.slurp = NULL;
-
- /* 1) count named args, make sure there is less than 32/64
- * 2) create slurpy hash if needed */
- for (i = st->dest.i; i < st->dest.n; ++i) {
- const INTVAL sig = VTABLE_get_integer_keyed_int(interp,
- st->dest.u.op.signature, i);
-
- /* skip the arg name, only count the actual args of the named args */
- if (!(sig & PARROT_ARG_NAME))
- continue;
-
- /* slurpy named args, create slurpy hash */
- else if (sig & PARROT_ARG_SLURPY_ARRAY) {
- int idx;
-
- /* Create PMC for slurpy mode */
- st->dest.slurp = pmc_new(interp,
- Parrot_get_ctx_HLL_type(interp, enum_class_Hash));
-
- /* pass the slurpy hash */
- idx = st->dest.u.op.pc[i];
- CTX_REG_PMC(st->dest.ctx, idx) = st->dest.slurp;
- }
- /* must be the actual arg of a named arg, count it */
- else
- n_named++;
- }
-
- /* only 32/64 named args allowed;
- * uses UINTVAL as a bitfield to detect duplicates */
- if (n_named >= (int)(sizeof (UINTVAL) * 8))
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "Too many named arguments");
-
- st->named_done = 0;
-}
-
-
-/*
-
-=item C<static int locate_named_named(PARROT_INTERP, call_state *st)>
-
-Locates a destination argument name, returning 0 if not found.
-
-=cut
-
-*/
-
-static int
-locate_named_named(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(locate_named_named)
- int i;
- int n_named = -1;
-
- for (i = st->first_named; i < st->dest.n; ++i) {
- int idx;
- STRING *param;
-
- st->dest.sig = VTABLE_get_integer_keyed_int(interp,
- st->dest.u.op.signature, i);
- if (!(st->dest.sig & PARROT_ARG_NAME))
- continue;
-
- if (st->dest.sig & PARROT_ARG_SLURPY_ARRAY)
- return 1;
-
- n_named++;
- idx = st->dest.u.op.pc[i];
- param = PARROT_ARG_CONSTANT_ISSET(st->dest.sig)
- ? Parrot_pcc_get_string_constant(interp, st->dest.ctx, idx)
- : CTX_REG_STR(st->dest.ctx, idx);
-
- if (st->name == param || Parrot_str_equal(interp, st->name, param)) {
- ++i;
- st->dest.sig = VTABLE_get_integer_keyed_int(interp,
- st->dest.u.op.signature, i);
- st->dest.i = i;
-
- /* if bit is set we have a duplicate */
- if (st->named_done & (1 << n_named))
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "duplicate named argument - '%Ss' not expected", param);
-
- st->named_done |= 1 << n_named;
- return 1;
- }
- }
-
- return 0;
-}
-
-
-/*
-
-=item C<static void store_arg(PARROT_INTERP, const call_state *st, INTVAL idx)>
-
-Stores the next argument in the destination register appropriately.
-
-=cut
-
-*/
-
-static void
-store_arg(PARROT_INTERP, ARGIN(const call_state *st), INTVAL idx)
-{
- ASSERT_ARGS(store_arg)
- switch (st->dest.sig & PARROT_ARG_TYPE_MASK) {
- case PARROT_ARG_INTVAL:
- CTX_REG_INT(st->dest.ctx, idx) = UVal_int(st->val);
- break;
- case PARROT_ARG_FLOATVAL:
- CTX_REG_NUM(st->dest.ctx, idx) = UVal_num(st->val);
- break;
- case PARROT_ARG_STRING:
- CTX_REG_STR(st->dest.ctx, idx) = UVal_str(st->val);
- break;
- case PARROT_ARG_PMC:
- CTX_REG_PMC(st->dest.ctx, idx) = UVal_pmc(st->val);
- break;
- default:
- break;
- }
-}
-
-
-/*
-
-=item C<int Parrot_store_arg(PARROT_INTERP, const call_state *st)>
-
-Stores the next function argument into the appropriate destination register.
-Calls C<store_arg> to do most of the work. Returns 0 if an attempt is made
-to store more values then there are in the signature. Returns 1 otherwise.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-int
-Parrot_store_arg(PARROT_INTERP, ARGIN(const call_state *st))
-{
- ASSERT_ARGS(Parrot_store_arg)
- INTVAL idx;
- if (st->dest.i >= st->dest.n)
- return 0;
-
- PARROT_ASSERT(st->dest.mode & CALL_STATE_OP);
- idx = st->dest.u.op.pc[st->dest.i];
- PARROT_ASSERT(idx >= 0);
- store_arg(interp, st, idx);
-
- return 1;
-}
-
-
-/*
-
-=item C<static void too_few(PARROT_INTERP, const call_state *st, const char
-*action)>
-
-Throws an exception if there are too few arguments passed.
-
-=cut
-
-*/
-
-static void
-too_few(PARROT_INTERP, ARGIN(const call_state *st), ARGIN(const char *action))
-{
- ASSERT_ARGS(too_few)
- const int max_expected_args = st->params;
- const int min_expected_args = max_expected_args - st->optionals;
-
- if (st->n_actual_args < min_expected_args) {
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "too few arguments passed (%d) - %s%d %s%s expected",
- st->n_actual_args,
- (min_expected_args < max_expected_args ? "at least " : ""),
- min_expected_args, action,
- (min_expected_args == 1 ? "" : "s"));
- }
-}
-
-
-/*
-
-=item C<static void too_many(PARROT_INTERP, const call_state *st, const char
-*action)>
-
-Throws an exception if there are too many arguments passed.
-
-=cut
-
-*/
-
-static void
-too_many(PARROT_INTERP, ARGIN(const call_state *st), ARGIN(const char *action))
-{
- ASSERT_ARGS(too_many)
- const int max_expected_args = st->params;
- const int min_expected_args = max_expected_args - st->optionals;
-
- if (st->n_actual_args > max_expected_args) {
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "too many arguments passed (%d) - %s%d %s%s expected",
- st->n_actual_args,
- (min_expected_args < max_expected_args ? "at most " : ""),
- max_expected_args, action,
- (max_expected_args == 1 ? "" : "s"));
- }
-}
-
-
-/*
-
-=item C<static void null_val(int sig, call_state *st)>
-
-Adds a null value to the appropriate register.
-
-=cut
-
-*/
-
-static void
-null_val(int sig, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(null_val)
- switch (sig & PARROT_ARG_TYPE_MASK) {
- case PARROT_ARG_INTVAL: UVal_int(st->val) = 0; break;
- case PARROT_ARG_FLOATVAL: UVal_num(st->val) = 0.0; break;
- case PARROT_ARG_STRING: UVal_str(st->val) = NULL; break;
- case PARROT_ARG_PMC: UVal_pmc(st->val) = PMCNULL; break;
- default:
- break;
- }
-}
-
-
-/*
-
-=item C<static void check_named(PARROT_INTERP, call_state *st)>
-
-Makes sure that all required named args are set and that all optional
-args and flags are set to null and false if not present.
-
-A named arg takes the form of
-
- STRING *name, [INPS] actual_arg,
-
-or
-
- STRING *name, [INPS] actual_arg, int opt_arg_flag
-
-=cut
-
-*/
-
-static void
-check_named(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(check_named)
- int i;
- int n_named = -1;
-
- for (i = st->first_named; i < st->dest.n; ++i) {
- /* verify that a name exists */
- const INTVAL sig = st->dest.sig =
- VTABLE_get_integer_keyed_int(interp, st->dest.u.op.signature, i);
-
- if (sig & PARROT_ARG_NAME) {
- int last_name_pos = i;
- INTVAL arg_sig;
-
- /* if slurpy then no errors, return */
- if (sig & PARROT_ARG_SLURPY_ARRAY)
- return;
-
- n_named++;
-
- /* move on to the actual arg */
- i++;
-
- /* verify that an actual arg exists */
- arg_sig = st->dest.sig = VTABLE_get_integer_keyed_int(interp,
- st->dest.u.op.signature, i);
- PARROT_ASSERT(!(arg_sig & PARROT_ARG_NAME));
-
- /* if this named arg is already filled, continue */
- if (st->named_done & (1 << n_named)) {
- if (i + 1 < st->dest.n) {
- arg_sig = st->dest.sig
- = VTABLE_get_integer_keyed_int(interp,
- st->dest.u.op.signature, i + 1);
-
- /* skip associated opt flag arg as well */
- if (arg_sig & PARROT_ARG_OPT_FLAG)
- i++;
- }
-
- continue;
- }
- else if (arg_sig & PARROT_ARG_OPTIONAL) {
- INTVAL idx;
- null_val(arg_sig, st);
- idx = st->dest.u.op.pc[i];
- store_arg(interp, st, idx);
-
- /* Don't walk off the end of the array */
- if (i+1 >= st->dest.n)
- continue;
-
- arg_sig = st->dest.sig = VTABLE_get_integer_keyed_int(interp,
- st->dest.u.op.signature, i + 1);
-
- if (arg_sig & PARROT_ARG_OPT_FLAG) {
- i++;
- idx = st->dest.u.op.pc[i];
- CTX_REG_INT(st->dest.ctx, idx) = 0;
- }
- continue;
- }
- else {
- const INTVAL idx = st->dest.u.op.pc[last_name_pos];
- STRING * const param = PARROT_ARG_CONSTANT_ISSET(sig)
- ? Parrot_pcc_get_string_constant(interp, st->dest.ctx, idx)
- : CTX_REG_STR(st->dest.ctx, idx);
-
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "too few arguments passed"
- " - missing required named arg '%Ss'", param);
- }
- }
- else
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "invalid arg type in named portion of args");
- }
-}
-
-
-/*
-
-=item C<static void init_call_stats(call_state *st)>
-
-Sets the default values of the passed C<call_state>.
-
-=cut
-
-*/
-
-static void
-init_call_stats(ARGMOD(call_state *st))
-{
- ASSERT_ARGS(init_call_stats)
-
- /* initial guess, adjusted for :flat args */
- st->n_actual_args = st->src.n;
-
- st->optionals = 0;
- st->params = st->dest.n;
- st->name = NULL;
- st->key = PMCNULL;
- st->first_named = -1;
-}
-
-
-/*
-
-=item C<void Parrot_process_args(PARROT_INTERP, call_state *st, arg_pass_t
-param_or_result)>
-
-Gets args for the current function call and puts them into position.
-First it gets the positional non-slurpy parameters, then the positional
-slurpy parameters, and finally the named parameters.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-void
-Parrot_process_args(PARROT_INTERP, ARGMOD(call_state *st), arg_pass_t param_or_result)
-{
- ASSERT_ARGS(Parrot_process_args)
- int n_named;
- int err_check = 1;
- call_state_item *src, *dest;
-
- const char * const action = (param_or_result == PARROT_PASS_RESULTS)
- ? "result" : "param";
-
- /* Check if we should be throwing errors. This can be configured separately
- * for parameters and return values. */
- if (param_or_result == PARROT_PASS_RESULTS) {
- if (!PARROT_ERRORS_test(interp, PARROT_ERRORS_RESULT_COUNT_FLAG))
- err_check = 0;
- }
- else if (!PARROT_ERRORS_test(interp, PARROT_ERRORS_PARAM_COUNT_FLAG))
- err_check = 0;
-
- init_call_stats(st);
-
- src = &st->src;
- dest = &st->dest;
-
- /* 1st: Positional non-:slurpy */
- for (; dest->i < dest->n; dest->i++) {
- INTVAL idx;
- int has_arg;
-
- /* check if the next dest arg is :slurpy */
- next_arg_sig(interp, dest);
- if (dest->sig & PARROT_ARG_SLURPY_ARRAY)
- break;
-
- /* Check if there is another argument. We need to store the value to
- * handle :opt_flag, which needs to know if there was a preceding
- * argument. */
- has_arg = Parrot_fetch_arg(interp, st);
-
- /* if the src arg is named, we're done here */
- if (st->name) {
- /* but first, take care of any :optional arguments */
-
- /*
- * Workaround for several argument passing problems
- * RT #54860 and others
- * Save current value while setting the optional
- */
- const UnionCallStateVal old_value = st->val;
-
- while (dest->sig & PARROT_ARG_OPTIONAL) {
- null_val(st->dest.sig, st);
-
- /* actually store the argument */
- idx = st->dest.u.op.pc[st->dest.i];
- PARROT_ASSERT(idx >= 0);
- store_arg(interp, st, idx);
-
- check_for_opt_flag(interp, st, 0);
-
- /* next dest arg */
- dest->i++;
- next_arg_sig(interp, dest);
- }
-
- /* Restore value */
- st->val = old_value;
-
- break;
- }
-
- /* if the dest is a named argument, we need to fill it as a positional
- * since no named arguments have been given. so skip the name. */
- if (dest->sig & PARROT_ARG_NAME) {
- if (!has_arg)
- break;
- dest->i++;
- next_arg_sig(interp, dest);
- }
-
- /* if there *is* an arg, convert it */
- if (has_arg) {
- src->used = 1;
- Parrot_convert_arg(interp, st);
- }
-
- /* if this is an optional argument, null it */
- else if (dest->sig & PARROT_ARG_OPTIONAL)
- null_val(st->dest.sig, st);
-
- /* there's no argument - throw an exception (if we're in to that) */
- else if (err_check)
- too_few(interp, st, action);
-
- /* otherwise, we're done */
- else
- return;
-
- /* actually store the argument */
- idx = st->dest.u.op.pc[st->dest.i];
- PARROT_ASSERT(idx >= 0);
- store_arg(interp, st, idx);
-
- /* if we're at an :optional argument, check for an :opt_flag */
- if (dest->sig & PARROT_ARG_OPTIONAL)
- check_for_opt_flag(interp, st, has_arg);
- }
-
- /* 2nd: Positional :slurpy */
- if (dest->sig & PARROT_ARG_SLURPY_ARRAY && !(dest->sig & PARROT_ARG_NAME)) {
- PMC * const array = pmc_new(interp,
- Parrot_get_ctx_HLL_type(interp, enum_class_ResizablePMCArray));
- const INTVAL idx = st->dest.u.op.pc[dest->i];
-
- PARROT_ASSERT(idx >= 0);
-
- /* Must register this PMC or it may get collected when only the struct
- * references it. */
- CTX_REG_PMC(st->dest.ctx, idx) = array;
-
- while (Parrot_fetch_arg(interp, st)) {
- /* if the src arg is named, we're done here */
- if (st->name)
- break;
-
- src->used = 1;
-
- /* we have to convert to a PMC so we can put it in the PMC array */
- dest->sig |= PARROT_ARG_PMC;
- Parrot_convert_arg(interp, st);
-
- VTABLE_push_pmc(interp, array, UVal_pmc(st->val));
- }
-
- dest->i++;
- }
-
- /* is there another argument? if we're throwing errors, that's an error */
- if (err_check && Parrot_fetch_arg(interp, st)
- && !st->name && !(dest->sig & PARROT_ARG_NAME))
- too_many(interp, st, action);
-
- /* are we at the end? */
- if (dest->i == dest->n)
- return;
-
- /* 3rd: :named */
- init_first_dest_named(interp, st);
- n_named = 0;
-
- while (Parrot_fetch_arg(interp, st)) {
- src->used = 1;
-
- if (!st->name)
- Parrot_ex_throw_from_c_args(interp, NULL, 0,
- "positional inside named args at position %i",
- st->src.i - n_named);
-
- if (!locate_named_named(interp, st))
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "too many named arguments - '%Ss' not expected", st->name);
-
- n_named++;
-
- /* if the dest arg is :named :slurpy */
- if (dest->sig & PARROT_ARG_SLURPY_ARRAY) {
- /* Convert to a PMC to store in the hash */
- dest->sig |= PARROT_ARG_PMC;
- Parrot_convert_arg(interp, st);
- VTABLE_set_pmc_keyed_str(interp, dest->slurp, st->name,
- UVal_pmc(st->val));
- }
- else {
- Parrot_convert_arg(interp, st);
- Parrot_store_arg(interp, st);
-
- /* if we're at an :optional argument, check for an :opt_flag */
- if (dest->sig & PARROT_ARG_OPTIONAL)
- check_for_opt_flag(interp, st, 1);
- }
-
- /* otherwise this doesn't get reset and we can't catch positional args
- * inside of named args */
- st->name = NULL;
- }
-
- check_named(interp, st);
-}
-
-
-/*
-
-=item C<void Parrot_convert_arg(PARROT_INTERP, call_state *st)>
-
-Converts a source argument to the expected destination type.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-void
-Parrot_convert_arg(PARROT_INTERP, ARGMOD(call_state *st))
-{
- ASSERT_ARGS(Parrot_convert_arg)
-
- /* register key args have to be cloned */
- if ((st->src.sig & PARROT_ARG_TYPE_MASK) == PARROT_ARG_PMC)
- clone_key_arg(interp, st);
-
- /* if types are already equivalent, no need to convert */
- if (PARROT_ARG_TYPE(st->dest.sig) == PARROT_ARG_TYPE(st->src.sig))
- return;
-
- /* convert */
- switch (st->src.sig & PARROT_ARG_TYPE_MASK) {
- case PARROT_ARG_INTVAL: convert_arg_from_int(interp, st); break;
- case PARROT_ARG_FLOATVAL: convert_arg_from_num(interp, st); break;
- case PARROT_ARG_STRING: convert_arg_from_str(interp, st); break;
- case PARROT_ARG_PMC: convert_arg_from_pmc(interp, st); break;
- default:
- break;
- }
-}
-
-
-/*
-
-=item C<void parrot_pass_args(PARROT_INTERP, PMC *src_ctx, PMC *dest_ctx,
-opcode_t *src_indexes, opcode_t *dest_indexes, arg_pass_t param_or_result)>
-
-Main argument passing routine.
-
-Prelims: code segments aren't yet switched, so the current constants are still
-that of the caller. The destination context is already created and set,
-C<src_ctx> points to the caller's context. C<dst_seg> has the constants of the
-destination.
-
-C<what> is either C<PARROT_OP_get_params_pc> or C<PARROT_OP_get_results_pc>.
-With the former arguments are passed from the caller into a subroutine, the
-latter handles return values and yields.
-
-=cut
-
-*/
-
-PARROT_EXPORT
-void
-parrot_pass_args(PARROT_INTERP,
- ARGMOD(PMC *src_ctx), ARGMOD(PMC *dest_ctx),
- ARGMOD_NULLOK(opcode_t *src_indexes),
- ARGMOD_NULLOK(opcode_t *dest_indexes),
- arg_pass_t param_or_result)
-{
- ASSERT_ARGS(parrot_pass_args)
- PMC *src_signature, *dest_signature;
- call_state st;
-
- if (param_or_result == PARROT_PASS_PARAMS) {
- src_signature = interp->args_signature;
- dest_signature = interp->params_signature;
- interp->args_signature = NULL;
- interp->params_signature = NULL;
- }
- else /* (param_or_result == PARROT_PASS_RESULTS) */ {
- src_signature = interp->returns_signature;
- dest_signature = Parrot_pcc_get_results_signature(interp, dest_ctx);
- interp->returns_signature = NULL;
- Parrot_pcc_set_results_signature(interp, dest_ctx, NULL);
- }
-
- memset(&st, 0, sizeof st);
-
- Parrot_init_arg_indexes_and_sig_pmc(interp, src_ctx, src_indexes,
- src_signature, &st.src);
-
- Parrot_init_arg_indexes_and_sig_pmc(interp, dest_ctx, dest_indexes,
- dest_signature, &st.dest);
-
- Parrot_process_args(interp, &st, param_or_result);
-}
-
-
-/*
-
-=item C<opcode_t * parrot_pass_args_fromc(PARROT_INTERP, const char *sig,
-opcode_t *dest, PMC *old_ctxp, va_list ap)>
-
-Passes arguments from C code with given signature to a Parrot Sub.
-Prerequisites are like above.
-
-=cut
-
-*/
-
-PARROT_CANNOT_RETURN_NULL
-PARROT_WARN_UNUSED_RESULT
-opcode_t *
-parrot_pass_args_fromc(PARROT_INTERP, ARGIN(const char *sig),
- ARGMOD(opcode_t *dest), ARGIN(PMC *old_ctxp), va_list ap)
-{
- ASSERT_ARGS(parrot_pass_args_fromc)
- call_state st;
-
- Parrot_init_arg_op(interp, CURRENT_CONTEXT(interp), dest, &st.dest);
- Parrot_init_arg_sig(interp, old_ctxp, sig, PARROT_VA_TO_VAPTR(ap), &st.src);
- Parrot_process_args(interp, &st, PARROT_PASS_PARAMS);
- return dest + st.dest.n + 2;
-}
-
-
-/*
-
-=item C<static int set_retval_util(PARROT_INTERP, const char *sig, PMC *ctx,
-call_state *st)>
-
-Adds the current return parameter to the current context, and fetches
-the next return parameter from the call state object.
-
-=cut
-
-*/
-
-static int
-set_retval_util(PARROT_INTERP, ARGIN(const char *sig),
- ARGIN(PMC *ctx), ARGMOD(call_state *st))
-{
- ASSERT_ARGS(set_retval_util)
- opcode_t * const src_pc = interp->current_returns;
- int todo = Parrot_init_arg_op(interp, ctx, src_pc, &st->src);
-
- interp->current_returns = NULL;
-
- if (todo) {
- todo = Parrot_init_arg_sig(interp, CURRENT_CONTEXT(interp), sig, NULL,
- &st->dest);
-
- if (todo) {
- Parrot_fetch_arg(interp, st);
- Parrot_convert_arg(interp, st);
- return 1;
- }
- }
-
- return 0;
-}
-
-
-/*
-
-=item C<void * set_retval(PARROT_INTERP, int sig_ret, PMC *ctx)>
-
-Handles void and pointer (PMC *, STRING *) return values. Returns a PMC,
-STRING, or NULL pointer as appropriate.
-
-=cut
-
-*/
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CAN_RETURN_NULL
-void *
-set_retval(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx))
-{
- ASSERT_ARGS(set_retval)
- call_state st;
-
- if (!sig_ret || sig_ret == 'v')
- return NULL;
-
- switch (sig_ret) {
- case 'S':
- if (set_retval_util(interp, "S", ctx, &st))
- return UVal_str(st.val);
- case 'P':
- if (set_retval_util(interp, "P", ctx, &st)) {
- PMC *retval = UVal_pmc(st.val);
- return (void *)retval;
- }
- default:
- return NULL;
- }
-}
-
-
-/*
-
-=item C<INTVAL set_retval_i(PARROT_INTERP, int sig_ret, PMC *ctx)>
-
-Handles an INTVAL return value, returning its value if present and 0 otherwise.
-
-=cut
-
-*/
-
-INTVAL
-set_retval_i(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx))
-{
- ASSERT_ARGS(set_retval_i)
- call_state st;
-
- if (sig_ret != 'I')
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "return signature not 'I'");
-
- if (set_retval_util(interp, "I", ctx, &st))
- return UVal_int(st.val);
-
- return 0;
-}
-
-
-/*
-
-=item C<FLOATVAL set_retval_f(PARROT_INTERP, int sig_ret, PMC *ctx)>
-
-Handles a FLOATVAL return value, returning its value if present and 0.0
-otherwise.
-
-=cut
-
-*/
-
-FLOATVAL
-set_retval_f(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx))
-{
- ASSERT_ARGS(set_retval_f)
- call_state st;
-
- if (sig_ret != 'N')
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "return signature not 'N'");
-
- if (set_retval_util(interp, "N", ctx, &st))
- return UVal_num(st.val);
-
- return 0.0;
-}
-
-
-/*
-
-=item C<STRING* set_retval_s(PARROT_INTERP, int sig_ret, PMC *ctx)>
-
-Handles a STRING return value, returning its pointer if present and NULL
-otherwise.
-
-=cut
-
-*/
-
-PARROT_CAN_RETURN_NULL
-PARROT_WARN_UNUSED_RESULT
-STRING*
-set_retval_s(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx))
-{
- ASSERT_ARGS(set_retval_s)
- call_state st;
-
- if (sig_ret != 'S')
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "return signature not 'S'");
-
- if (set_retval_util(interp, "S", ctx, &st))
- return UVal_str(st.val);
-
- return NULL;
-}
-
-
-/*
-
-=item C<PMC* set_retval_p(PARROT_INTERP, int sig_ret, PMC *ctx)>
-
-Handles a PMC return value, returning the PMC pointer if present and NULL
-otherwise.
-
-=cut
-
-*/
-
-PARROT_CAN_RETURN_NULL
-PARROT_WARN_UNUSED_RESULT
-PMC*
-set_retval_p(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx))
-{
- ASSERT_ARGS(set_retval_p)
- call_state st;
-
- if (sig_ret != 'P')
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "return signature not 'P'");
-
- if (set_retval_util(interp, "P", ctx, &st))
- return UVal_pmc(st.val);
-
- return NULL;
-}
-
-
-/*
-
-=item C<static void commit_last_arg(PARROT_INTERP, int index, int cur, opcode_t
-*n_regs_used, int seen_arrow, PMC * const *sigs, opcode_t **indexes, PMC *ctx,
-PMC *pmc, va_list *list)>
-
-Called by C<Parrot_PCCINVOKE> when it reaches the end of each arg in the arg
-signature. See C<Parrot_PCCINVOKE> for signature syntax.
-
-=cut
-
-*/
-
-static void
-commit_last_arg(PARROT_INTERP, int index, int cur,
- ARGMOD(opcode_t *n_regs_used), int seen_arrow, ARGIN(PMC * const *sigs),
- ARGMOD(opcode_t **indexes), ARGMOD(PMC *ctx),
- ARGIN_NULLOK(PMC *pmc), ARGIN(va_list *list))
-{
- ASSERT_ARGS(commit_last_arg)
- int reg_offset = 0;
-
- /* invocant already commited, just return */
- if (seen_arrow == 0 && index == 0 && pmc)
- return;
-
- /* calculate arg's register offset */
- switch (cur & PARROT_ARG_TYPE_MASK) { /* calc reg offset */
- case PARROT_ARG_INTVAL:
- reg_offset = n_regs_used[seen_arrow * 4 + REGNO_INT]++; break;
- case PARROT_ARG_FLOATVAL:
- reg_offset = n_regs_used[seen_arrow * 4 + REGNO_NUM]++; break;
- case PARROT_ARG_STRING:
- reg_offset = n_regs_used[seen_arrow * 4 + REGNO_STR]++; break;
- case PARROT_ARG_PMC :
- reg_offset = n_regs_used[seen_arrow * 4 + REGNO_PMC]++; break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_PCCINVOKE: invalid reg type");
- }
-
- /* set the register offset into the index int[] */
- indexes[seen_arrow][index] = reg_offset;
-
- /* set the PARROT_ARG_FLAGS into the signature FIA */
- VTABLE_set_integer_keyed_int(interp, sigs[seen_arrow], index, cur);
-
- /* perform the arg accessor function, assigning the arg to its
- * corresponding register */
- if (!seen_arrow) {
- switch (cur & PARROT_ARG_TYPE_MASK) {
- case PARROT_ARG_INTVAL:
- CTX_REG_INT(ctx, reg_offset) = va_arg(*list, INTVAL); break;
- case PARROT_ARG_FLOATVAL:
- CTX_REG_NUM(ctx, reg_offset) = va_arg(*list, FLOATVAL); break;
- case PARROT_ARG_STRING:
- CTX_REG_STR(ctx, reg_offset) = va_arg(*list, STRING *); break;
- case PARROT_ARG_PMC:
- CTX_REG_PMC(ctx, reg_offset) = va_arg(*list, PMC *); break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_PCCINVOKE: invalid reg type");
- }
- }
-}
-
-
-/*
-
-=item C<static PMC * count_signature_elements(PARROT_INTERP, const char
-*signature, PMC *args_sig, PMC *results_sig, int flag)>
-
-Counts the number of each type of register in a signature object. Returns
-the total number of parameter arguments, the total number of result
-arguments, and the number of each type needed for register allocation.
-Adds the necessary registers to a new context and returns the context.
-
-=cut
-
-*/
-
-PARROT_CANNOT_RETURN_NULL
-static PMC *
-count_signature_elements(PARROT_INTERP, ARGIN(const char *signature),
- ARGMOD(PMC *args_sig), ARGMOD(PMC *results_sig), int flag)
-{
- ASSERT_ARGS(count_signature_elements)
- const char *x;
-
- /*Count of number of each type of arg and result, INSP->INSP */
- int max_regs[8] = { 0, 0, 0, 0, 0, 0, 0, 0 };
-
- /* variables from PCCINVOKE impl in PCCMETHOD.pm */
- /* args INSP, returns INSP */
- INTVAL n_regs_used[] = { 0, 0, 0, 0, 0, 0, 0, 0 };
-
- /* # of args, # of results */
- int arg_ret_cnt[2] = { 0, 0 };
-
- unsigned int seen_arrow = 0;
-
- /* Increment these values if we are not calling from a CallSignature PMC */
- if (flag) {
- arg_ret_cnt[seen_arrow]++;
- max_regs[REGNO_PMC]++;
- }
-
- /* Loop through the signature string to count the number of each
- type of object required. We need to know so we can allocate
- an appropriate number of registers for it. */
- for (x = signature; *x != '\0'; x++) {
- switch (*x) {
- case '-':
- /* detect -> separator */
- seen_arrow = 1;
- ++x;
- if (*x != '>')
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "PCCINVOKE: invalid signature separator %c!",
- *x);
- break;
- case 'I':
- arg_ret_cnt[seen_arrow]++;
- max_regs[seen_arrow * 4 + REGNO_INT]++;
- break;
- case 'N':
- arg_ret_cnt[seen_arrow]++;
- max_regs[seen_arrow * 4 + REGNO_NUM]++;
- break;
- case 'S':
- arg_ret_cnt[seen_arrow]++;
- max_regs[seen_arrow * 4 + REGNO_STR]++;
- break;
- case 'P':
- arg_ret_cnt[seen_arrow]++;
- {
- /* Lookahead to see if PMC is marked as invocant */
- if (*(++x) == 'i') {
- max_regs[REGNO_PMC]++;
- }
- else {
- x--; /* Undo lookahead */
- max_regs[seen_arrow * 4 + REGNO_PMC]++;
- }
- }
- break;
- case 'f':
- case 'n':
- case 's':
- case 'o':
- case 'p':
- /* case 'l': */ /* lookahead parameter */
- case 'i':
- break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_PCCINVOKE: invalid reg type %c!", *x);
- }
- }
-
- /* calculate max reg types needed for both args and results */
- n_regs_used[0] = PARROT_MAX(max_regs[0], max_regs[4]);
- n_regs_used[1] = PARROT_MAX(max_regs[1], max_regs[5]);
- n_regs_used[2] = PARROT_MAX(max_regs[2], max_regs[6]);
- n_regs_used[3] = PARROT_MAX(max_regs[3], max_regs[7]);
-
- /* initialize arg and return sig FIAs with collected info */
- if (arg_ret_cnt[0] > 0)
- VTABLE_set_integer_native(interp, args_sig, arg_ret_cnt[0]);
-
- if (arg_ret_cnt[1] > 0)
- VTABLE_set_integer_native(interp, results_sig, arg_ret_cnt[1]);
-
- return Parrot_push_context(interp, n_regs_used);
-}
-
-
-/*
-
-=item C<static void commit_last_arg_sig_object(PARROT_INTERP, int index, int
-cur, opcode_t *n_regs_used, int seen_arrow, PMC * const *sigs, opcode_t
-**indexes, PMC *ctx, PMC *sig_obj)>
-
-Called by Parrot_pcc_invoke_from_sig_object when it reaches the end of each
-arg in the arg signature. See C<Parrot_pcc_invoke_from_sig_object> for
-signature syntax.
-
-=cut
-
-*/
-
-static void
-commit_last_arg_sig_object(PARROT_INTERP, int index, int cur,
- ARGMOD(opcode_t *n_regs_used), int seen_arrow, ARGIN(PMC * const *sigs),
- ARGMOD(opcode_t **indexes), ARGMOD(PMC *ctx),
- ARGIN(PMC *sig_obj))
-{
- ASSERT_ARGS(commit_last_arg_sig_object)
- int reg_offset = 0;
-
- /* calculate arg's register offset */
- switch (cur & PARROT_ARG_TYPE_MASK) { /* calc reg offset */
- case PARROT_ARG_INTVAL:
- reg_offset = n_regs_used[seen_arrow * 4 + REGNO_INT]++; break;
- case PARROT_ARG_FLOATVAL:
- reg_offset = n_regs_used[seen_arrow * 4 + REGNO_NUM]++; break;
- case PARROT_ARG_STRING:
- reg_offset = n_regs_used[seen_arrow * 4 + REGNO_STR]++; break;
- case PARROT_ARG_PMC :
- if (cur & PARROT_ARG_INVOCANT) {
- if (seen_arrow == 0 && index == 0) {
- n_regs_used[REGNO_PMC]++;
- reg_offset = 0;
- }
- else {
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_pcc_invoke: Only the first parameter can be "
- "an invocant %d, %d", seen_arrow, index);
- }
- }
- else
- reg_offset = n_regs_used[seen_arrow * 4 + REGNO_PMC]++;
- break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_PCCINVOKE: invalid reg type");
- }
-
- /* set the register offset into the index int[] */
- indexes[seen_arrow][index] = reg_offset;
-
- /* set the PARROT_ARG_FLAGS into the signature FIA */
- VTABLE_set_integer_keyed_int(interp, sigs[seen_arrow], index, cur);
-
- /* perform the arg accessor function, assigning the arg to its
- * corresponding register */
- if (!seen_arrow) {
- switch (cur & PARROT_ARG_TYPE_MASK) {
- case PARROT_ARG_INTVAL:
- CTX_REG_INT(ctx, reg_offset) =
- VTABLE_get_integer_keyed_int(interp, sig_obj, index);
- break;
- case PARROT_ARG_FLOATVAL:
- CTX_REG_NUM(ctx, reg_offset) =
- VTABLE_get_number_keyed_int(interp, sig_obj, index);
- break;
- case PARROT_ARG_STRING:
- CTX_REG_STR(ctx, reg_offset) =
- VTABLE_get_string_keyed_int(interp, sig_obj, index);
- break;
- case PARROT_ARG_PMC:
- CTX_REG_PMC(ctx, reg_offset) =
- VTABLE_get_pmc_keyed_int(interp, sig_obj, index);
-
- if (cur & PARROT_ARG_INVOCANT)
- interp->current_object = CTX_REG_PMC(ctx, reg_offset);
- break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_pcc_invoke_from_sig_object: invalid reg type");
- }
- }
-}
-
-
-/*
-
-=item C<static void set_context_sig_returns(PARROT_INTERP, PMC *ctx, opcode_t
-**indexes, const char *ret_x, PMC *result_list)>
-
-Sets the subroutine return arguments in the context C<ctx>. Takes a C string
-for the return signature C<ret_x> and a list of return parameters
-C<result_list>.
-
-=cut
-
-*/
-
-static void
-set_context_sig_returns(PARROT_INTERP,
- ARGMOD(PMC *ctx), ARGMOD(opcode_t **indexes),
- ARGIN_NULLOK(const char *ret_x), ARGMOD(PMC *result_list))
-{
- ASSERT_ARGS(set_context_sig_returns)
- const char *x;
- STRING * const empty_string = CONST_STRING(interp, "");
- unsigned int index = 0;
- unsigned int seen_arrow = 1;
-
- /* result_accessors perform the arg accessor function,
- * assigning the corresponding registers to the result variables */
- for (x = ret_x; x && *x; x++) {
- PMC * const result_item =
- VTABLE_get_pmc_keyed_int(interp, result_list, index);
-
- if (isupper((unsigned char)*x)) {
- switch (*x) {
- case 'I':
- VTABLE_set_integer_native(interp, result_item,
- CTX_REG_INT(ctx, indexes[seen_arrow][index]));
- break;
- case 'N':
- VTABLE_set_number_native(interp, result_item,
- CTX_REG_NUM(ctx, indexes[seen_arrow][index]));
- break;
- case 'S':
- VTABLE_set_string_native(interp, result_item,
- CTX_REG_STR(ctx, indexes[seen_arrow][index]));
- break;
- case 'P':
- VTABLE_set_pmc(interp, result_item,
- CTX_REG_PMC(ctx, indexes[seen_arrow][index]));
- break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_pcc_invoke_from_sig_object: "
- "invalid reg type %c!", *x);
- }
-
- /* invalidate the CPointer's pointers so that GC doesn't try to
- * mark stack values -- RT #59880 */
- VTABLE_set_string_keyed_str(interp, result_item,
- empty_string, empty_string);
- }
- }
-
- Parrot_pop_context(interp);
-}
-
-
-/*
-
-=item C<static void set_context_sig_returns_varargs(PARROT_INTERP, PMC *ctx,
-opcode_t **indexes, const char *ret_x, va_list returns)>
-
-Sets the subroutine return arguments in the context C<ctx>. Takes a C string
-for the return signature C<ret_x> and a varargs list of return parameters
-C<returns>.
-
-To unify this function with C<set_context_sig_returns>, C<Parrot_PCCINVOKE>
-needs to be changed to convert the va_list of input arguments into a signature
-object, and the results list from that object needs to be passed to this
-function instead of the va_list itself.
-
-=cut
-
-*/
-
-static void
-set_context_sig_returns_varargs(PARROT_INTERP, ARGMOD(PMC *ctx),
- ARGMOD(opcode_t **indexes), ARGIN(const char *ret_x), va_list returns)
-{
- ASSERT_ARGS(set_context_sig_returns_varargs)
- const char *x;
- unsigned int index = 0;
- unsigned int seen_arrow = 1;
-
- /* result_accessors perform the arg accessor function,
- * assigning the corresponding registers to the result variables */
- for (x = ret_x; x && *x; x++) {
- if (isupper((unsigned char)*x)) {
- switch (*x) {
- case 'I':
- {
- INTVAL * const tmpINTVAL = va_arg(returns, INTVAL *);
- *tmpINTVAL = CTX_REG_INT(ctx, indexes[seen_arrow][index]);
- }
- break;
- case 'N':
- {
- FLOATVAL * const tmpFLOATVAL = va_arg(returns, FLOATVAL *);
- *tmpFLOATVAL = CTX_REG_NUM(ctx, indexes[seen_arrow][index]);
- }
- break;
- case 'S':
- {
- STRING ** const tmpSTRING = va_arg(returns, STRING **);
- *tmpSTRING = CTX_REG_STR(ctx, indexes[seen_arrow][index]);
- }
- break;
- case 'P':
- {
- PMC ** const tmpPMC = va_arg(returns, PMC **);
- *tmpPMC = CTX_REG_PMC(ctx, indexes[seen_arrow][index]);
- }
- break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_PCCINVOKE: invalid reg type %c!", *x);
- }
- }
- }
-
- Parrot_pop_context(interp);
-}
-
-
-/*
-
-=item C<static const char * set_context_sig_params(PARROT_INTERP, const char
-*signature, INTVAL *n_regs_used, PMC **sigs, opcode_t **indexes, PMC *ctx, PMC
-*sig_obj)>
-
-Sets the subroutine arguments in the C<ctx> context, according to the signature
-string C<signature>. Currently this function is only called from
-C<Parrot_pcc_invoke_from_sig_object>, but eventually when things are unified
-enough it should be called from C<Parrot_PCCINVOKE> as well. The only
-difference currently between the two implementations are the calls to
-C<commit_last_arg_sig_object> and C<commit_last_arg>.
-
-=cut
-
-*/
-
-PARROT_CAN_RETURN_NULL
-static const char *
-set_context_sig_params(PARROT_INTERP, ARGIN(const char *signature),
- ARGMOD(INTVAL *n_regs_used), ARGMOD(PMC **sigs),
- ARGMOD(opcode_t **indexes), ARGMOD(PMC *ctx),
- ARGMOD(PMC *sig_obj))
-{
- ASSERT_ARGS(set_context_sig_params)
-
- const char *x;
- const char *ret_x = 0;
- int index = -1;
- int seen_arrow = 0;
- int cur = 0;
-
- /* second loop through signature to build all index and arg_flag
- * loop also assigns args(up to the ->) to registers */
- for (x = signature; *x != '\0'; x++) {
- /* detect -> separator */
- if (*x == '-') {
-
- /* skip '>' */
- x++;
-
- /* allows us to jump directly to the result signature portion
- * during results assignment */
- ret_x = x;
-
- /* save off pointer to results */
- ret_x++;
-
- if (index >= 0)
- commit_last_arg_sig_object(interp, index, cur, n_regs_used,
- seen_arrow, sigs, indexes, ctx, sig_obj);
-
- /* reset parsing state so we can now handle results */
- seen_arrow = 1;
- index = -1;
-
- /* reset n_regs_used for reuse during result index allocation */
- n_regs_used[0] = 0;
- n_regs_used[1] = 0;
- n_regs_used[2] = 0;
- n_regs_used[3] = 0;
- }
- /* parse arg type */
- else if (isupper((unsigned char)*x)) {
- if (index >= 0)
- commit_last_arg_sig_object(interp, index, cur, n_regs_used,
- seen_arrow, sigs, indexes, ctx, sig_obj);
-
- index++;
-
- switch (*x) {
- case 'I': cur = PARROT_ARG_INTVAL; break;
- case 'N': cur = PARROT_ARG_FLOATVAL; break;
- case 'S': cur = PARROT_ARG_STRING; break;
- case 'P': cur = PARROT_ARG_PMC; break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_pcc_invoke_from_sig_object: "
- "invalid reg type %c!", *x);
- }
- }
- /* parse arg adverbs */
- else if (islower((unsigned char)*x)) {
- switch (*x) {
- case 'n': cur |= PARROT_ARG_NAME; break;
- case 'f': cur |= PARROT_ARG_FLATTEN; break;
- case 's': cur |= PARROT_ARG_SLURPY_ARRAY; break;
- case 'o': cur |= PARROT_ARG_OPTIONAL; break;
- case 'p': cur |= PARROT_ARG_OPT_FLAG; break;
- case 'l': cur |= PARROT_ARG_LOOKAHEAD; break;
- case 'i': cur |= PARROT_ARG_INVOCANT; break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_pcc_invoke_from_sig_object: "
- "invalid adverb type %c!", *x);
- }
- }
- }
-
- if (index >= 0)
- commit_last_arg_sig_object(interp, index, cur, n_regs_used,
- seen_arrow, sigs, indexes, ctx, sig_obj);
-
- interp->current_args = indexes[0];
- interp->args_signature = sigs[0];
-
- Parrot_pcc_set_results(interp, ctx, indexes[1]);
- Parrot_pcc_set_results_signature(interp, ctx, sigs[1]);
-
- return ret_x;
-}
-
-
-/*
-
=item C<void Parrot_pcc_invoke_sub_from_c_args(PARROT_INTERP, PMC *sub_obj,
const char *sig, ...)>
@@ -2756,166 +131,22 @@
ARGIN(const char *signature), ...)
{
ASSERT_ARGS(Parrot_PCCINVOKE)
-#define PCC_ARG_MAX 1024
- /* variables from PCCINVOKE impl in PCCMETHOD.pm */
- /* args INSP, returns INSP */
- INTVAL n_regs_used[] = { 0, 0, 0, 0, 0, 0, 0, 0 };
-
- /* Each of these is 8K. Do we want 16K on the stack? */
- opcode_t arg_indexes[PCC_ARG_MAX];
- opcode_t result_indexes[PCC_ARG_MAX];
-
- PMC * const args_sig = pmc_new(interp, enum_class_FixedIntegerArray);
- PMC * const results_sig = pmc_new(interp, enum_class_FixedIntegerArray);
- PMC * const ret_cont = new_ret_continuation_pmc(interp, NULL);
-
- PMC *ctx; /* The newly created context */
- PMC *pccinvoke_meth;
-
- opcode_t *save_current_args;
- PMC *save_args_signature;
- PMC *save_current_object;
-
- /* temporary state vars for building PCC index and PCC signature arrays. */
-
- /* arg_indexes, result_indexes */
- opcode_t *indexes[2];
-
- /* args_sig, results_sig */
- PMC *sigs[2];
-
- int seen_arrow = 0;
-
- const char *x;
- const char *ret_x = NULL;
- int index = -1;
- int cur = 0;
-
- va_list list;
- va_start(list, signature);
-
- indexes[0] = arg_indexes;
- indexes[1] = result_indexes;
- sigs[0] = args_sig;
- sigs[1] = results_sig;
-
- /* account for passing invocant in-band */
- if (!pmc)
- Parrot_ex_throw_from_c_args(interp, NULL, 1,
- "NULL PMC passed into Parrot_PCCINVOKE");
-
- ctx = count_signature_elements(interp, signature, args_sig, results_sig, 1);
-
- /* second loop through signature to build all index and arg_flag
- * loop also assigns args(up to the ->) to registers */
-
- /* account for passing invocant in-band */
- indexes[0][0] = 0;
-
- VTABLE_set_integer_keyed_int(interp, sigs[0], 0, PARROT_ARG_PMC);
- CTX_REG_PMC(ctx, 0) = pmc;
-
- n_regs_used[REGNO_PMC]++;
- index = 0;
-
- for (x = signature; *x != '\0'; x++) {
- /* detect -> separator */
- if (*x == '-') {
-
- /* skip '>' */
- x++;
-
- /* allows us to jump directly to the result signature portion
- * during results assignment */
- ret_x = x;
-
- /* save off pointer to results */
- ret_x++;
-
- if (index >= 0)
- commit_last_arg(interp, index, cur, n_regs_used, seen_arrow,
- sigs, indexes, ctx, pmc, &list);
-
- /* reset parsing state so we can now handle results */
- seen_arrow = 1;
- index = -1;
-
- /* reset n_regs_used for reuse during result index allocation */
- n_regs_used[0] = 0;
- n_regs_used[1] = 0;
- n_regs_used[2] = 0;
- n_regs_used[3] = 0;
- }
- /* parse arg type */
- else if (isupper((unsigned char)*x)) {
- if (index >= 0)
- commit_last_arg(interp, index, cur, n_regs_used, seen_arrow,
- sigs, indexes, ctx, pmc, &list);
-
- index++;
-
- switch (*x) {
- case 'I': cur = PARROT_ARG_INTVAL; break;
- case 'N': cur = PARROT_ARG_FLOATVAL; break;
- case 'S': cur = PARROT_ARG_STRING; break;
- case 'P': cur = PARROT_ARG_PMC; break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_PCCINVOKE: invalid reg type %c!", *x);
- }
-
- }
- /* parse arg adverbs */
- else if (islower((unsigned char)*x)) {
- switch (*x) {
- case 'n': cur |= PARROT_ARG_NAME; break;
- case 'f': cur |= PARROT_ARG_FLATTEN; break;
- case 's': cur |= PARROT_ARG_SLURPY_ARRAY; break;
- case 'o': cur |= PARROT_ARG_OPTIONAL; break;
- case 'p': cur |= PARROT_ARG_OPT_FLAG; break;
- /* case 'l': cur |= PARROT_ARG_LOOKAHEAD; break; */
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_PCCINVOKE: invalid adverb type %c!", *x);
- }
- }
- }
-
- if (index >= 0)
- commit_last_arg(interp, index, cur, n_regs_used, seen_arrow, sigs,
- indexes, ctx, pmc, &list);
-
- /* code from PCCINVOKE impl in PCCMETHOD.pm */
- save_current_args = interp->current_args;
- save_args_signature = interp->args_signature;
- save_current_object = interp->current_object;
-
- interp->current_args = arg_indexes;
- interp->args_signature = args_sig;
- Parrot_pcc_set_results(interp, ctx, result_indexes);
- Parrot_pcc_set_results_signature(interp, ctx, results_sig);
-
- /* arg_accessors assigned in loop above */
+ PMC *sig_obj;
+ PMC *sub_obj;
+ va_list args;
+ va_start(args, signature);
+ sig_obj = Parrot_pcc_build_sig_object_from_varargs(interp, pmc, signature, args);
+ va_end(args);
- interp->current_object = pmc;
- interp->current_cont = NEED_CONTINUATION;
- Parrot_pcc_set_continuation(interp, ctx, ret_cont);
- PMC_cont(ret_cont)->from_ctx = ctx;
- pccinvoke_meth = VTABLE_find_method(interp, pmc, method_name);
+ /* Find the subroutine object as a named method on pmc */
+ sub_obj = VTABLE_find_method(interp, pmc, method_name);
+ if (PMC_IS_NULL(sub_obj))
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_METHOD_NOT_FOUND,
+ "Method '%Ss' not found", method_name);
- if (PMC_IS_NULL(pccinvoke_meth))
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_METHOD_NOT_FOUND,
- "Method '%Ss' not found", method_name);
- else
- VTABLE_invoke(interp, pccinvoke_meth, NULL);
-
- set_context_sig_returns_varargs(interp, ctx, indexes, ret_x, list);
- interp->current_args = save_current_args;
- interp->args_signature = save_args_signature;
- interp->current_object = save_current_object;
- va_end(list);
+ /* Invoke the subroutine object with the given CallSignature object */
+ interp->current_object = pmc;
+ Parrot_pcc_invoke_from_sig_object(interp, sub_obj, sig_obj);
}
/*
@@ -2958,16 +189,15 @@
"Method '%Ss' not found", method_name);
/* Invoke the subroutine object with the given CallSignature object */
+ interp->current_object = pmc;
Parrot_pcc_invoke_from_sig_object(interp, sub_obj, sig_obj);
- gc_unregister_pmc(interp, sig_obj);
-
}
/*
=item C<void Parrot_pcc_invoke_from_sig_object(PARROT_INTERP, PMC *sub_obj, PMC
-*sig_obj)>
+*call_object)>
Follows the same conventions as C<Parrot_PCCINVOKE>, but the subroutine object
to invoke is passed as an argument rather than looked up by name, and the
@@ -2980,107 +210,43 @@
PARROT_EXPORT
void
Parrot_pcc_invoke_from_sig_object(PARROT_INTERP, ARGIN(PMC *sub_obj),
- ARGIN(PMC *sig_obj))
+ ARGIN(PMC *call_object))
{
ASSERT_ARGS(Parrot_pcc_invoke_from_sig_object)
-#define PCC_ARG_MAX 1024
- /* variables from PCCINVOKE impl in PCCMETHOD.pm */
- /* args INSP, returns INSP */
- INTVAL n_regs_used[] = { 0, 0, 0, 0, 0, 0, 0, 0 };
- /* Each of these is 8K. Do we want 16K on the stack? */
- opcode_t arg_indexes[PCC_ARG_MAX] = {0};
- opcode_t result_indexes[PCC_ARG_MAX] = {0};
-
- /* create the signature string, and the various PMCs that are needed to
- store all the parameters and parameter counts. */
- char * const signature = Parrot_str_to_cstring(interp,
- VTABLE_get_string(interp, sig_obj));
- PMC * const args_sig = temporary_pmc_new(interp,
- enum_class_FixedIntegerArray);
- PMC * const results_sig = temporary_pmc_new(interp,
- enum_class_FixedIntegerArray);
- PMC * const ret_cont = new_ret_continuation_pmc(interp, NULL);
- PMC * const result_list = VTABLE_get_attr_str(interp, sig_obj, CONST_STRING(interp, "returns"));
-
- PMC *ctx;
- opcode_t *dest;
- opcode_t *save_current_args;
- PMC *save_args_signature;
- PMC *save_current_object;
-
- /* temporary state vars for building PCC index and PCC signature arrays. */
-
- /* arg_indexes, result_indexes */
- opcode_t *indexes[2];
-
- /* args_sig, results_sig */
- PMC *sigs[2];
-
- const char *ret_x = NULL;
-
- indexes[0] = arg_indexes;
- indexes[1] = result_indexes;
- sigs[0] = args_sig;
- sigs[1] = results_sig;
-
- /* Count the number of objects of each type that need to be allocated by
- the caller to perform this function call */
- ctx = count_signature_elements(interp, signature, args_sig, results_sig, 0);
-
- /* code from PCCINVOKE impl in PCCMETHOD.pm */
- /* Save the current values of the interpreter arguments so that additional
- child sub calls don't kill our call stack. */
- save_current_args = interp->current_args;
- save_args_signature = interp->args_signature;
- save_current_object = interp->current_object;
-
- /* Set the function input parameters in the context structure, and return
- * the offset in the signature where the return params start. */
- ret_x = set_context_sig_params(interp, signature, n_regs_used,
- sigs, indexes, ctx, sig_obj);
-
- /* Set up the context object for the function invokation */
- if (strncmp(signature, "Pi", 2) == 0)
- interp->current_object = VTABLE_get_pmc_keyed_int(interp, sig_obj, 0);
- else
- interp->current_object = PMCNULL;
+ opcode_t *dest;
+ INTVAL n_regs_used[] = { 0, 0, 0, 0, 0, 0, 0, 0 };
+ PMC *ctx = Parrot_push_context(interp, n_regs_used);
+ PMC * const ret_cont = new_ret_continuation_pmc(interp, NULL);
- interp->current_cont = NEED_CONTINUATION;
+ Parrot_pcc_set_signature(interp, ctx, call_object);
Parrot_pcc_set_continuation(interp, ctx, ret_cont);
- PMC_cont(ret_cont)->from_ctx = ctx;
+ interp->current_cont = NEED_CONTINUATION;
+ PARROT_CONTINUATION(ret_cont)->from_ctx = ctx;
/* Invoke the function */
dest = VTABLE_invoke(interp, sub_obj, NULL);
- /* PIR Subs need runops to run their opcodes. Methods and NCI subs don't. */
- if (sub_obj->vtable->base_type == enum_class_Sub
- && PMC_IS_NULL(interp->current_object)) {
+ /* PIR Subs need runops to run their opcodes. Methods and NCI subs
+ * don't. */
+ if ((sub_obj->vtable->base_type == enum_class_Sub
+ || sub_obj->vtable->base_type == enum_class_MultiSub
+ || (sub_obj->vtable->base_type == enum_class_Eval))
+ && PMC_IS_NULL(interp->current_object)) {
Parrot_runcore_t *old_core = interp->run_core;
- const opcode_t offset = dest - interp->code->base.data;
+ const opcode_t offset = dest - interp->code->base.data;
/* can't re-enter the runloop from here with PIC cores: RT #60048 */
if (PARROT_RUNCORE_PREDEREF_OPS_TEST(interp->run_core))
Parrot_runcore_switch(interp, CONST_STRING(interp, "slow"));
runops(interp, offset);
- interp->run_core = old_core;
+ Interp_core_SET(interp, old_core);
}
-
- /* Set the return values from the subroutine's context into the
- caller's context */
- set_context_sig_returns(interp, ctx, indexes, ret_x, result_list);
-
- temporary_pmc_free(interp, args_sig);
- temporary_pmc_free(interp, results_sig);
-
- interp->current_args = save_current_args;
- interp->args_signature = save_args_signature;
- interp->current_object = save_current_object;
- Parrot_str_free_cstring(signature);
+ Parrot_pcc_set_signature(interp, ctx, NULL);
+ Parrot_pop_context(interp);
}
-
/*
=back
Modified: trunk/src/debug.c
==============================================================================
--- trunk/src/debug.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/debug.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -3507,6 +3507,7 @@
STRING *str;
PMC *old = PMCNULL;
int rec_level = 0;
+ int limit_count = 0;
/* information about the current sub */
PMC *sub = interpinfo_p(interp, CURRENT_SUB);
@@ -3538,23 +3539,35 @@
/* backtrace: follow the continuation chain */
while (1) {
Parrot_Continuation_attributes *sub_cont;
+
+ /* Limit the levels dumped, no segfault on infinite recursion */
+ if (++limit_count > RECURSION_LIMIT)
+ break;
+
sub = Parrot_pcc_get_continuation(interp, ctx);
if (PMC_IS_NULL(sub))
break;
+
sub_cont = PARROT_CONTINUATION(sub);
if (!sub_cont)
break;
- str = Parrot_Context_infostr(interp, sub_cont->to_ctx);
+
+ str = Parrot_Context_infostr(interp, Parrot_pcc_get_caller_ctx(interp, ctx));
+
if (!str)
break;
+
/* recursion detection */
- if (!PMC_IS_NULL(old) && PMC_cont(old) &&
+ if (ctx == sub_cont->to_ctx) {
+ ++rec_level;
+ }
+ else if (!PMC_IS_NULL(old) && PMC_cont(old) &&
Parrot_pcc_get_pc(interp, PMC_cont(old)->to_ctx) ==
Parrot_pcc_get_pc(interp, PMC_cont(sub)->to_ctx) &&
Parrot_pcc_get_sub(interp, PMC_cont(old)->to_ctx) ==
@@ -3590,7 +3603,7 @@
}
/* get the next Continuation */
- ctx = PARROT_CONTINUATION(sub)->to_ctx;
+ ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
old = sub;
if (!ctx)
Modified: trunk/src/embed.c
==============================================================================
--- trunk/src/embed.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/embed.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -824,7 +824,7 @@
Parrot_pcc_set_sub(interp, CURRENT_CONTEXT(interp), NULL);
Parrot_pcc_set_constants(interp, interp->ctx, interp->code->const_table->constants);
- Parrot_runops_fromc_args(interp, main_sub, "vP", userargv);
+ Parrot_pcc_invoke_sub_from_c_args(interp, main_sub, "P->", userargv);
}
Modified: trunk/src/events.c
==============================================================================
--- trunk/src/events.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/events.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -1471,8 +1471,8 @@
break;
case EVENT_TYPE_TIMER:
/* run ops, save registers */
- Parrot_runops_fromc_args_event(interp,
- event->u.timer_event.sub, "v");
+ Parrot_pcc_invoke_sub_from_c_args(interp,
+ event->u.timer_event.sub, "->");
break;
case EVENT_TYPE_CALL_BACK:
edebug((stderr, "starting user cb\n"));
@@ -1481,9 +1481,9 @@
break;
case EVENT_TYPE_IO:
edebug((stderr, "starting io handler\n"));
- Parrot_runops_fromc_args_event(interp,
+ Parrot_pcc_invoke_sub_from_c_args(interp,
event->u.io_event.handler,
- "vPP",
+ "PP->",
event->u.io_event.pio,
event->u.io_event.user_data);
break;
Modified: trunk/src/exceptions.c
==============================================================================
--- trunk/src/exceptions.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/exceptions.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -38,24 +38,16 @@
__attribute__nonnull__(3);
PARROT_CAN_RETURN_NULL
-static opcode_t * pass_exception_args(PARROT_INTERP,
- ARGIN(const char *sig),
- ARGIN(opcode_t *dest),
- ARGIN(PMC * old_ctx),
- ...)
+static void setup_exception_args(PARROT_INTERP, ARGIN(const char *sig), ...)
__attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3)
- __attribute__nonnull__(4);
+ __attribute__nonnull__(2);
#define ASSERT_ARGS_build_exception_from_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(format))
-#define ASSERT_ARGS_pass_exception_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+#define ASSERT_ARGS_setup_exception_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(sig) \
- , PARROT_ASSERT_ARG(dest) \
- , PARROT_ASSERT_ARG(old_ctx))
+ , PARROT_ASSERT_ARG(sig))
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: static */
@@ -240,20 +232,7 @@
}
address = VTABLE_invoke(interp, handler, dest);
-
- /* XXX This is an obvious hack. We need to identify here whether this is
- an ExceptionHandler proper or a PIR-defined subclass. This conditional
- monstrosity attempts to check whether this is an object of a PIR-defined
- subclass. When we have garbage-collectable PMCs, we shouldn't need to do
- this nonsense. See TT#154 for details */
- if (handler->vtable->base_type == enum_class_Object) {
- /* Don't know what to do here to make sure the exception parameter gets
- passed properly. */
- }
- /* Set up the continuation context of the handler in the interpreter. */
- else if (PARROT_CONTINUATION(handler)->current_results)
- address = pass_exception_args(interp, "P", address,
- CURRENT_CONTEXT(interp), exception);
+ setup_exception_args(interp, "P", exception);
if (PObj_get_FLAGS(handler) & SUB_FLAG_C_HANDLER) {
/* it's a C exception handler */
@@ -267,30 +246,29 @@
/*
-=item C<static opcode_t * pass_exception_args(PARROT_INTERP, const char *sig,
-opcode_t *dest, PMC * old_ctx, ...)>
+=item C<static void setup_exception_args(PARROT_INTERP, const char *sig, ...)>
-Passes arguments to the exception handler routine. These are retrieved with
-the .get_results() directive in PIR code.
+Sets up arguments to the exception handler invocation.
=cut
*/
PARROT_CAN_RETURN_NULL
-static opcode_t *
-pass_exception_args(PARROT_INTERP, ARGIN(const char *sig),
- ARGIN(opcode_t *dest), ARGIN(PMC * old_ctx), ...)
-{
- ASSERT_ARGS(pass_exception_args)
- va_list ap;
- opcode_t *next;
-
- va_start(ap, old_ctx);
- next = parrot_pass_args_fromc(interp, sig, dest, old_ctx, ap);
- va_end(ap);
+static void
+setup_exception_args(PARROT_INTERP, ARGIN(const char *sig), ...)
+{
+ ASSERT_ARGS(setup_exception_args)
+ va_list args;
+ PMC *sig_obj;
- return next;
+ va_start(args, sig);
+ sig_obj = Parrot_pcc_build_sig_object_from_varargs(interp, PMCNULL, sig, args);
+ va_end(args);
+
+ CALLSIGNATURE_is_exception_SET(sig_obj);
+
+ Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), sig_obj);
}
/*
@@ -380,6 +358,7 @@
/* Don't split line. It will break CONST_STRING handling */
VTABLE_set_attr_str(interp, exception, CONST_STRING(interp, "thrower"), Parrot_pcc_get_continuation(interp, CURRENT_CONTEXT(interp)));
+
/* it's a C exception handler */
if (PObj_get_FLAGS(handler) & SUB_FLAG_C_HANDLER) {
Parrot_runloop * const jump_point =
@@ -389,9 +368,7 @@
/* Run the handler. */
address = VTABLE_invoke(interp, handler, NULL);
- if (PARROT_CONTINUATION(handler)->current_results)
- address = pass_exception_args(interp, "P", address,
- CURRENT_CONTEXT(interp), exception);
+ setup_exception_args(interp, "P", exception);
PARROT_ASSERT(return_point->handler_start == NULL);
return_point->handler_start = address;
longjmp(return_point->resume, 2);
Modified: trunk/src/extend.c
==============================================================================
--- trunk/src/extend.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/extend.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -1010,6 +1010,67 @@
/*
+=item C<void append_result(PARROT_INTERP, PMC *sig_object, Parrot_String type,
+void *result)>
+
+Helper function between old and new style PCC to append return pointer to signature.
+
+To be removed with deprecated functions.
+
+=cut
+
+*/
+
+void
+append_result(PARROT_INTERP, ARGIN(PMC *sig_object), ARGIN(Parrot_String type), ARGIN(void *result))
+{
+ ASSERT_ARGS(append_result)
+ Parrot_String full_sig;
+ Parrot_PMC returns;
+ Parrot_PMC return_pointer;
+ Parrot_PMC return_flags;
+
+ Parrot_String return_name = Parrot_str_new_constant(interp, "returns");
+ Parrot_String return_flags_name = Parrot_str_new_constant(interp, "return_flags");
+ Parrot_String sig_name = Parrot_str_new_constant(interp, "signature");
+
+ full_sig = VTABLE_get_string(interp, sig_object);
+ /* Append ->[T] */
+ Parrot_str_concat(interp, full_sig, Parrot_str_new_constant(interp, "->"), 0);
+ Parrot_str_concat(interp, full_sig, type, 0);
+
+ return_pointer = pmc_new(interp, enum_class_CPointer);
+
+ returns = VTABLE_get_attr_str(interp, sig_object, return_name);
+ if (PMC_IS_NULL(returns)) {
+ returns = pmc_new(interp, enum_class_ResizablePMCArray);
+ VTABLE_set_attr_str(interp, sig_object, return_name, returns);
+ }
+ VTABLE_set_pointer(interp, return_pointer, result);
+ VTABLE_set_string_keyed_str(interp, return_pointer, sig_name, type);
+ VTABLE_push_pmc(interp, returns, return_pointer);
+
+ /* Update returns_flag */
+ return_flags = VTABLE_get_attr_str(interp, sig_object, return_flags_name);
+ if (PMC_IS_NULL(return_flags)) {
+ return_flags = pmc_new(interp, enum_class_ResizablePMCArray);
+ VTABLE_set_attr_str(interp, sig_object, return_flags_name, return_flags);
+ }
+ switch (Parrot_str_indexed(interp, type, 0)) {
+ case 'I': VTABLE_push_integer(interp, return_flags, PARROT_ARG_INTVAL); break;
+ case 'N': VTABLE_push_integer(interp, return_flags, PARROT_ARG_FLOATVAL); break;
+ case 'S': VTABLE_push_integer(interp, return_flags, PARROT_ARG_STRING); break;
+ case 'P': VTABLE_push_integer(interp, return_flags, PARROT_ARG_PMC); break;
+ default:
+ Parrot_ex_throw_from_c_args(interp, NULL,
+ EXCEPTION_INVALID_OPERATION,
+ "invalid signature string element!");
+ }
+
+}
+
+/*
+
=item C<void* Parrot_call_sub(PARROT_INTERP, Parrot_PMC sub_pmc, const char
*signature, ...)>
@@ -1038,19 +1099,44 @@
ARGIN(const char *signature), ...)
{
ASSERT_ARGS(Parrot_call_sub)
- va_list ap;
- void *result;
- Parrot_Sub_attributes *sub;
+ va_list args;
+ PMC *sig_object;
+ void *result;
+ char return_sig = signature[0];
+ const char *arg_sig = signature;
+ Parrot_sub *sub;
+
+ arg_sig++;
+ va_start(args, signature);
+ sig_object = Parrot_pcc_build_sig_object_from_varargs(interp, PMCNULL, arg_sig, args);
+ va_end(args);
+
+ /* Add the return argument onto the call signature object (a bit
+ * hackish, added for backward compatibility in deprecated API function,
+ * see TT #XXX). */
+ switch (return_sig) {
+ case 'v':
+ {
+ Parrot_String full_sig = VTABLE_get_string(interp, sig_object);
+ Parrot_str_concat(interp, full_sig,
+ Parrot_str_new_constant(interp, "->"), 0);
+ break;
+ }
+ case 'V':
+ case 'P':
+ {
+ append_result(interp, sig_object, Parrot_str_new_constant(interp, "P"), &result);
+ break;
+ }
+ default:
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Dispatch: invalid return type %c!", return_sig);
+ }
- PARROT_CALLIN_START(interp);
-
- va_start(ap, signature);
PMC_get_sub(interp, sub_pmc, sub);
Parrot_pcc_set_constants(interp, CURRENT_CONTEXT(interp), sub->seg->const_table->constants);
- result = Parrot_runops_fromc_arglist(interp, sub_pmc, signature, ap);
- va_end(ap);
+ Parrot_pcc_invoke_from_sig_object(interp, sub_pmc, sig_object);
- PARROT_CALLIN_END(interp);
return result;
}
@@ -1071,19 +1157,24 @@
ARGIN(const char *signature), ...)
{
ASSERT_ARGS(Parrot_call_sub_ret_int)
- va_list ap;
+ va_list args;
+ PMC *sig_object;
Parrot_Int result;
- Parrot_Sub_attributes *sub;
-
- PARROT_CALLIN_START(interp);
-
- va_start(ap, signature);
- PMC_get_sub(interp, sub_pmc, sub);
- Parrot_pcc_set_constants(interp, CURRENT_CONTEXT(interp), sub->seg->const_table->constants);
- result = Parrot_runops_fromc_arglist_reti(interp, sub_pmc, signature, ap);
- va_end(ap);
+ char return_sig = signature[0];
+ const char *arg_sig = signature;
+ Parrot_sub *sub;
+
+ arg_sig++;
+ va_start(args, signature);
+ sig_object = Parrot_pcc_build_sig_object_from_varargs(interp, PMCNULL, arg_sig, args);
+ va_end(args);
+
+ /* Add the return argument onto the call signature object (a bit
+ * hackish, added for backward compatibility in deprecated API function,
+ * see TT #XXX). */
+ append_result(interp, sig_object, Parrot_str_new_constant(interp, "I"), &result);
+ Parrot_pcc_invoke_from_sig_object(interp, sub_pmc, sig_object);
- PARROT_CALLIN_END(interp);
return result;
}
@@ -1104,26 +1195,33 @@
ARGIN(const char *signature), ...)
{
ASSERT_ARGS(Parrot_call_sub_ret_float)
- va_list ap;
- Parrot_Float result;
- Parrot_Sub_attributes *sub;
-
- PARROT_CALLIN_START(interp);
-
- va_start(ap, signature);
+ va_list args;
+ PMC *sig_object;
+ Parrot_Float result;
+ char return_sig = signature[0];
+ const char *arg_sig = signature;
+ Parrot_sub *sub;
+
+ arg_sig++;
+ va_start(args, signature);
+ sig_object = Parrot_pcc_build_sig_object_from_varargs(interp, PMCNULL, arg_sig, args);
+ va_end(args);
+
+ /* Add the return argument onto the call signature object (a bit
+ * hackish, added for backward compatibility in deprecated API function,
+ * see TT #XXX). */
+ append_result(interp, sig_object, Parrot_str_new_constant(interp, "N"), &result);
PMC_get_sub(interp, sub_pmc, sub);
Parrot_pcc_set_constants(interp, CURRENT_CONTEXT(interp), sub->seg->const_table->constants);
- result = Parrot_runops_fromc_arglist_retf(interp, sub_pmc, signature, ap);
- va_end(ap);
+ Parrot_pcc_invoke_from_sig_object(interp, sub_pmc, sig_object);
- PARROT_CALLIN_END(interp);
return result;
}
/*
-=item C<void * Parrot_call_method(PARROT_INTERP, Parrot_PMC sub, Parrot_PMC obj,
-Parrot_String method, const char *signature, ...)>
+=item C<void * Parrot_call_method(PARROT_INTERP, Parrot_PMC sub_pmc, Parrot_PMC
+obj, Parrot_String method, const char *signature, ...)>
Call the parrot subroutine C<sub> as a method on PMC object C<obj>. The method
should have the name C<method> as a Parrot_string, and should have a function
@@ -1138,25 +1236,58 @@
PARROT_WARN_UNUSED_RESULT
PARROT_CAN_RETURN_NULL
void *
-Parrot_call_method(PARROT_INTERP, Parrot_PMC sub, Parrot_PMC obj,
+Parrot_call_method(PARROT_INTERP, Parrot_PMC sub_pmc, Parrot_PMC obj,
Parrot_String method, ARGIN(const char *signature), ...)
{
ASSERT_ARGS(Parrot_call_method)
- void *result;
- va_list ap;
+ va_list args;
+ PMC *sig_object;
+ void *result = NULL;
+ char return_sig = signature[0];
+ char *arg_sig = (char*)malloc(strlen(signature)+2);
+ Parrot_sub *sub;
+ arg_sig[0] = 'P';
+ arg_sig[1] = 'i';
+ arg_sig[2] = 0;
+ strcat(arg_sig, signature);
+
+ va_start(args, signature);
+ sig_object = Parrot_pcc_build_sig_object_from_varargs(interp, obj, arg_sig, args);
+ va_end(args);
+ free(arg_sig);
+
+ /* Add the return argument onto the call signature object (a bit
+ * hackish, added for backward compatibility in deprecated API function,
+ * see TT #XXX). */
+ switch (return_sig) {
+ case 'v':
+ {
+ Parrot_String full_sig = VTABLE_get_string(interp, sig_object);
+ Parrot_str_concat(interp, full_sig,
+ Parrot_str_new_constant(interp, "->"), 0);
+ break;
+ }
+ case 'V':
+ case 'P':
+ {
+ append_result(interp, sig_object, Parrot_str_new_constant(interp, "P"), &result);
+ break;
+ }
+ default:
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Dispatch: invalid return type %c!", return_sig);
+ }
+
+ PMC_get_sub(interp, sub_pmc, sub);
+ Parrot_pcc_set_constants(interp, CURRENT_CONTEXT(interp), sub->seg->const_table->constants);
+ Parrot_pcc_invoke_from_sig_object(interp, sub_pmc, sig_object);
- PARROT_CALLIN_START(interp);
- va_start(ap, signature);
- result = Parrot_run_meth_fromc_arglist(interp, sub,
- obj, method, signature, ap);
- va_end(ap);
- PARROT_CALLIN_END(interp);
return result;
}
/*
-=item C<Parrot_Int Parrot_call_method_ret_int(PARROT_INTERP, Parrot_PMC sub,
+=item C<Parrot_Int Parrot_call_method_ret_int(PARROT_INTERP, Parrot_PMC sub_pmc,
Parrot_PMC obj, Parrot_String method, const char *signature, ...)>
Call the parrot subroutine C<sub> as a method on PMC object C<obj>. The method
@@ -1170,26 +1301,38 @@
PARROT_EXPORT
Parrot_Int
-Parrot_call_method_ret_int(PARROT_INTERP, Parrot_PMC sub,
+Parrot_call_method_ret_int(PARROT_INTERP, Parrot_PMC sub_pmc,
Parrot_PMC obj, Parrot_String method, ARGIN(const char *signature), ...)
{
ASSERT_ARGS(Parrot_call_method_ret_int)
- Parrot_Int result;
- va_list ap;
+ va_list args;
+ PMC *sig_object;
+ Parrot_Int result = 0;
+ char return_sig = signature[0];
+ char *arg_sig = (char*)malloc(strlen(signature)+2);
+ Parrot_sub *sub;
+ arg_sig[0] = 'P';
+ arg_sig[1] = 'i';
+ arg_sig[2] = 0;
+ strcat(arg_sig, signature);
+
+ va_start(args, signature);
+ sig_object = Parrot_pcc_build_sig_object_from_varargs(interp, obj, arg_sig, args);
+ va_end(args);
+ free(arg_sig);
+
+ append_result(interp, sig_object, Parrot_str_new_constant(interp, "I"), &result);
+ PMC_get_sub(interp, sub_pmc, sub);
+ Parrot_pcc_set_constants(interp, CURRENT_CONTEXT(interp), sub->seg->const_table->constants);
+ Parrot_pcc_invoke_from_sig_object(interp, sub_pmc, sig_object);
- PARROT_CALLIN_START(interp);
- va_start(ap, signature);
- result = Parrot_run_meth_fromc_arglist_reti(interp, sub,
- obj, method, signature, ap);
- va_end(ap);
- PARROT_CALLIN_END(interp);
return result;
}
/*
-=item C<Parrot_Float Parrot_call_method_ret_float(PARROT_INTERP, Parrot_PMC sub,
-Parrot_PMC obj, Parrot_String method, const char *signature, ...)>
+=item C<Parrot_Float Parrot_call_method_ret_float(PARROT_INTERP, Parrot_PMC
+sub_pmc, Parrot_PMC obj, Parrot_String method, const char *signature, ...)>
Call a parrot method for the given object.
@@ -1199,19 +1342,31 @@
PARROT_EXPORT
Parrot_Float
-Parrot_call_method_ret_float(PARROT_INTERP, Parrot_PMC sub,
+Parrot_call_method_ret_float(PARROT_INTERP, Parrot_PMC sub_pmc,
Parrot_PMC obj, Parrot_String method, ARGIN(const char *signature), ...)
{
ASSERT_ARGS(Parrot_call_method_ret_float)
- Parrot_Float result;
- va_list ap;
+ va_list args;
+ PMC *sig_object;
+ Parrot_Float result = 0.0;
+ char return_sig = signature[0];
+ char *arg_sig = (char*)malloc(strlen(signature)+2);
+ Parrot_sub *sub;
+ arg_sig[0] = 'P';
+ arg_sig[1] = 'i';
+ arg_sig[2] = 0;
+ strcat(arg_sig, signature);
+
+ va_start(args, signature);
+ sig_object = Parrot_pcc_build_sig_object_from_varargs(interp, obj, arg_sig, args);
+ va_end(args);
+ free(arg_sig);
+
+ append_result(interp, sig_object, Parrot_str_new_constant(interp, "N"), &result);
+ PMC_get_sub(interp, sub_pmc, sub);
+ Parrot_pcc_set_constants(interp, CURRENT_CONTEXT(interp), sub->seg->const_table->constants);
+ Parrot_pcc_invoke_from_sig_object(interp, sub_pmc, sig_object);
- PARROT_CALLIN_START(interp);
- va_start(ap, signature);
- result = Parrot_run_meth_fromc_arglist_retf(interp, sub,
- obj, method, signature, ap);
- va_end(ap);
- PARROT_CALLIN_END(interp);
return result;
}
Modified: trunk/src/frame_builder.c
==============================================================================
--- trunk/src/frame_builder.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/frame_builder.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -100,129 +100,6 @@
return rv;
}
-INTVAL
-get_nci_I(PARROT_INTERP, ARGMOD(call_state *st), int n)
-{
- if (n >= st->src.n)
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "too few arguments passed to NCI function");
-
- Parrot_fetch_arg_nci(interp, st);
-
- return UVal_int(st->val);
-}
-
-FLOATVAL
-get_nci_N(PARROT_INTERP, ARGMOD(call_state *st), int n)
-{
- if (n >= st->src.n)
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "too few arguments passed to NCI function");
-
- Parrot_fetch_arg_nci(interp, st);
-
- return UVal_num(st->val);
-}
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CANNOT_RETURN_NULL
-STRING*
-get_nci_S(PARROT_INTERP, ARGMOD(call_state *st), int n)
-{
- /* TODO or act like below? */
- if (n >= st->src.n)
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "too few arguments passed to NCI function");
-
- Parrot_fetch_arg_nci(interp, st);
-
- return UVal_str(st->val);
-}
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CAN_RETURN_NULL
-PMC*
-get_nci_P(PARROT_INTERP, ARGMOD(call_state *st), int n)
-{
- /*
- * excessive args are passed as NULL
- * used by e.g. MMD infix like __add
- */
- if (n < st->src.n) {
- PMC *value;
- Parrot_fetch_arg_nci(interp, st);
- value = UVal_pmc(st->val);
- return PMC_IS_NULL(value) ? (PMC *)NULL : value;
- }
- else
- return NULL;
-}
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CAN_RETURN_NULL
-void*
-get_nci_p(PARROT_INTERP, ARGMOD(call_state *st), int n)
-{
- /*
- * excessive args are passed as NULL
- * used by e.g. MMD infix like __add
- */
- if (n < st->src.n) {
- PMC *value;
- Parrot_fetch_arg_nci(interp, st);
- value = UVal_pmc(st->val);
- return PMC_IS_NULL(value) ? (PMC *)NULL : VTABLE_get_pointer(interp, value);
- }
- else
- return NULL;
-}
-
-/*
- * set return value
- */
-void
-set_nci_I(PARROT_INTERP, ARGOUT(call_state *st), INTVAL val)
-{
- Parrot_init_ret_nci(interp, st, "I");
- if (st->dest.i < st->dest.n) {
- UVal_int(st->val) = val;
- Parrot_convert_arg(interp, st);
- Parrot_store_arg(interp, st);
- }
-}
-
-void
-set_nci_N(PARROT_INTERP, ARGOUT(call_state *st), FLOATVAL val)
-{
- Parrot_init_ret_nci(interp, st, "N");
- if (st->dest.i < st->dest.n) {
- UVal_num(st->val) = val;
- Parrot_convert_arg(interp, st);
- Parrot_store_arg(interp, st);
- }
-}
-
-void
-set_nci_S(PARROT_INTERP, ARGOUT(call_state *st), STRING *val)
-{
- Parrot_init_ret_nci(interp, st, "S");
- if (st->dest.i < st->dest.n) {
- UVal_str(st->val) = val;
- Parrot_convert_arg(interp, st);
- Parrot_store_arg(interp, st);
- }
-}
-
-void
-set_nci_P(PARROT_INTERP, ARGOUT(call_state *st), PMC* val)
-{
- Parrot_init_ret_nci(interp, st, "P");
- if (st->dest.i < st->dest.n) {
- UVal_pmc(st->val) = val;
- Parrot_convert_arg(interp, st);
- Parrot_store_arg(interp, st);
- }
-}
int
emit_is8bit(long disp)
@@ -461,8 +338,9 @@
emitm_movl_m_r(interp, pc, emit_EAX, emit_EBP, 0, 1, 8);
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, temp_calls_offset + 0);
- if (sig && *sig)
- emitm_call_cfunc(pc, Parrot_init_arg_nci);
+ /* XXX FIXME This whole function require major rework */
+ /* XXX FIXME if (sig && *sig) */
+ /* XXX FIXME emitm_call_cfunc(pc, Parrot_init_arg_nci); */
while (*sig) {
emitm_movl_i_m(pc, arg_count, emit_EBP, 0, 1, temp_calls_offset + 8);
@@ -473,23 +351,23 @@
emitm_movl_m_r(interp, pc, emit_EAX, emit_EBP, 0, 1, args_offset);
break;
case 'f':
- emitm_call_cfunc(pc, get_nci_N);
+ /* FIXME emitm_call_cfunc(pc, get_nci_N); */
emitm_fstps(interp, pc, emit_EBP, 0, 1, args_offset);
break;
case 'N':
case 'd':
- emitm_call_cfunc(pc, get_nci_N);
+ /* FIXME emitm_call_cfunc(pc, get_nci_N); */
emitm_fstpl(interp, pc, emit_EBP, 0, 1, args_offset);
args_offset += 4;
break;
case 'I': /* INTVAL */
case 'l': /* long */
case 'i': /* int */
- emitm_call_cfunc(pc, get_nci_I);
+ /* FIXME emitm_call_cfunc(pc, get_nci_I); */
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, args_offset);
break;
case 't': /* string, pass a cstring */
- emitm_call_cfunc(pc, get_nci_S);
+ /* FIXME emitm_call_cfunc(pc, get_nci_S); */
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, temp_calls_offset + 4);
emitm_call_cfunc(pc, string_to_cstring_nullable);
@@ -503,12 +381,12 @@
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, temp_calls_offset + 4);
break;
case 's': /* short: movswl intreg_o(base), %eax */
- emitm_call_cfunc(pc, get_nci_I);
+ /* FIXME emitm_call_cfunc(pc, get_nci_I); */
emitm_movswl_r_r(pc, emit_EAX, emit_EAX);
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, args_offset);
break;
case 'c': /* char: movsbl intreg_o(base), %eax */
- emitm_call_cfunc(pc, get_nci_I);
+ /* emitm_call_cfunc(pc, get_nci_I); */
emitm_movsbl_r_r(pc, emit_EAX, emit_EAX);
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, args_offset);
break;
@@ -518,31 +396,31 @@
arg_count--;
break;
case 'p': /* push pmc->data */
- emitm_call_cfunc(pc, get_nci_p);
+ /* FIXME emitm_call_cfunc(pc, get_nci_p); */
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, args_offset);
break;
case 'O': /* push PMC * object in P2 */
case 'P': /* push PMC * */
case '@':
- emitm_call_cfunc(pc, get_nci_P);
+ /* FIXME emitm_call_cfunc(pc, get_nci_P); */
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, args_offset);
break;
case 'v':
break;
case 'b': /* buffer (void*) pass Buffer_bufstart(SReg) */
- emitm_call_cfunc(pc, get_nci_S);
+ /* FIXME emitm_call_cfunc(pc, get_nci_S); */
emitm_movl_m_r(interp, pc, emit_EAX, emit_EAX, 0, 1,
(size_t) &Buffer_bufstart((STRING *) NULL));
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, args_offset);
break;
case 'B': /* buffer (void**) pass &Buffer_bufstart(SReg) */
- emitm_call_cfunc(pc, get_nci_S);
+ /* FIXME emitm_call_cfunc(pc, get_nci_S); */
emitm_lea_m_r(interp, pc, emit_EAX, emit_EAX, 0, 1,
(size_t) &Buffer_bufstart((STRING *) NULL));
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, args_offset);
break;
case 'S':
- emitm_call_cfunc(pc, get_nci_S);
+ /* FIXME emitm_call_cfunc(pc, get_nci_S); */
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, args_offset);
break;
@@ -619,37 +497,37 @@
emitm_movl_m_r(interp, pc, emit_EAX, emit_EAX, 0, 1, 0);
if (*sig == 2) /* short */
emitm_movswl_r_r(pc, emit_EAX, emit_EAX);
- emitm_call_cfunc(pc, set_nci_I);
+ /* XXX FIXME emitm_call_cfunc(pc, set_nci_I);*/
break;
case 'f':
case 'd':
jit_emit_fstore_mb_n(interp, pc, emit_EBP, temp_calls_offset + 8);
- emitm_call_cfunc(pc, set_nci_N);
+ /* XXX FIXME emitm_call_cfunc(pc, set_nci_N); */
/* pop num from st(0) and mov to reg */
break;
case 's':
/* movswl %ax, %eax */
emitm_movswl_r_r(pc, emit_EAX, emit_EAX);
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, temp_calls_offset + 8);
- emitm_call_cfunc(pc, set_nci_I);
+ /* XXX FIXME emitm_call_cfunc(pc, set_nci_I); */
break;
case 'c':
/* movsbl %al, %eax */
emitm_movsbl_r_r(pc, emit_EAX, emit_EAX);
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, temp_calls_offset + 8);
- emitm_call_cfunc(pc, set_nci_I);
+ /* XXX FIXME emitm_call_cfunc(pc, set_nci_I); */
break;
case 'I': /* INTVAL */
case 'l':
case 'i':
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, temp_calls_offset + 8);
- emitm_call_cfunc(pc, set_nci_I);
+ /* XXX FIXME emitm_call_cfunc(pc, set_nci_I); */
break;
case 'v': /* void - do nothing */
break;
case 'P':
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, temp_calls_offset + 8);
- emitm_call_cfunc(pc, set_nci_P);
+ /* XXX FIXME emitm_call_cfunc(pc, set_nci_P); */
break;
case 'p': /* make a new unmanaged struct */
/* save return value on stack */
@@ -678,11 +556,11 @@
emitm_lea_m_r(interp, pc, emit_EAX, emit_EBP, 0, 1, st_offset);
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, temp_calls_offset + 4);
- emitm_call_cfunc(pc, set_nci_P);
+ /* XXX FIXME emitm_call_cfunc(pc, set_nci_P); */
break;
case 'S':
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, temp_calls_offset + 8);
- emitm_call_cfunc(pc, set_nci_S);
+ /* XXX FIXME emitm_call_cfunc(pc, set_nci_S); */
break;
case 't': /* string */
/* EAX is char* */
@@ -699,7 +577,7 @@
emitm_lea_m_r(interp, pc, emit_EAX, emit_EBP, 0, 1, st_offset);
emitm_movl_r_m(interp, pc, emit_EAX, emit_EBP, 0, 1, temp_calls_offset + 4);
- emitm_call_cfunc(pc, set_nci_S);
+ /* XXX FIXME emitm_call_cfunc(pc, set_nci_S); */
break;
default:
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_JIT_ERROR,
Modified: trunk/src/frame_builder.h
==============================================================================
--- trunk/src/frame_builder.h Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/frame_builder.h Wed Oct 21 16:54:18 2009 (r41972)
@@ -56,41 +56,6 @@
/*
* helper funcs - get argument n
*/
-INTVAL get_nci_I(PARROT_INTERP, ARGMOD(call_state *st), int n);
-
-FLOATVAL get_nci_N(PARROT_INTERP, ARGMOD(call_state *st), int n);
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CANNOT_RETURN_NULL
-STRING*
-get_nci_S(PARROT_INTERP, ARGMOD(call_state *st), int n);
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CAN_RETURN_NULL
-PMC*
-get_nci_P(PARROT_INTERP, ARGMOD(call_state *st), int n);
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CAN_RETURN_NULL
-void*
-get_nci_p(PARROT_INTERP, ARGMOD(call_state *st), int n);
-
-#define GET_NCI_I(n) get_nci_I(interp, &st, (n))
-#define GET_NCI_S(n) get_nci_S(interp, &st, (n))
-#define GET_NCI_N(n) get_nci_N(interp, &st, (n))
-#define GET_NCI_P(n) get_nci_P(interp, &st, (n))
-#define GET_NCI_p(n) get_nci_p(interp, &st, (n))
-
-/*
- * set return value
- */
-void set_nci_I(PARROT_INTERP, ARGOUT(call_state *st), INTVAL val);
-
-void set_nci_N(PARROT_INTERP, ARGOUT(call_state *st), FLOATVAL val);
-
-void set_nci_S(PARROT_INTERP, ARGOUT(call_state *st), STRING *val);
-
-void set_nci_P(PARROT_INTERP, ARGOUT(call_state *st), PMC* val);
/*
* if we have a delegated method like typeof_i_p, that returns an INTVAL
Modified: trunk/src/hash.c
==============================================================================
--- trunk/src/hash.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/hash.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -1302,18 +1302,19 @@
const UINTVAL hashval = (hash->hash_val)(interp, key, hash->seed);
HashBucket *bucket = hash->bi[hashval & hash->mask];
- /* Very complex assert that we'll not put non-constant stuff into constant hash */
- PARROT_ASSERT(
- PMC_IS_NULL(hash->container)
- || !(PObj_constant_TEST(hash->container))
- || (
- (
- !(hash->key_type == Hash_key_type_STRING)
- || PObj_constant_TEST((PObj *)key))
- && (
- !((hash->entry_type == enum_type_PMC) || (hash->entry_type == enum_type_STRING))
- || PObj_constant_TEST((PObj *)value)))
- || !"Use non-constant key or value in constant hash");
+ /* When the hash is constant, check that the key and value are also
+ * constant. */
+ if (!PMC_IS_NULL(hash->container)
+ && PObj_constant_TEST(hash->container)) {
+ if (hash->key_type == Hash_key_type_STRING
+ && !PObj_constant_TEST((PObj *)key))
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Used non-constant key in constant hash.");
+ if (((hash->entry_type == enum_type_PMC) || (hash->entry_type == enum_type_STRING))
+ && !PObj_constant_TEST((PObj *)value))
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Used non-constant value in constant hash.");
+ }
while (bucket) {
/* store hash_val or not */
Modified: trunk/src/interp/inter_cb.c
==============================================================================
--- trunk/src/interp/inter_cb.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/interp/inter_cb.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -294,7 +294,7 @@
char *p;
char ch;
char *sig_cstr;
- char pasm_sig[4];
+ char pasm_sig[5];
INTVAL i_param;
PMC *p_param;
void *param = NULL; /* avoid -Ox warning */
@@ -310,13 +310,12 @@
p = sig_cstr;
++p; /* Skip return type */
- pasm_sig[0] = 'v'; /* no return value supported yet */
- pasm_sig[1] = 'P';
+ pasm_sig[0] = 'P';
if (*p == 'U') /* user_data Z in pdd16 */
++p; /* p is now type of external data */
switch (*p) {
case 'v':
- pasm_sig[2] = 'v';
+ pasm_sig[1] = 'v';
break;
#if 0
case '2':
@@ -335,7 +334,7 @@
case 'c':
i_param = (INTVAL)(char)(long)external_data;
case_I:
- pasm_sig[2] = 'I';
+ pasm_sig[1] = 'I';
param = (void*) i_param;
break;
#if 0
@@ -350,16 +349,16 @@
/* created a UnManagedStruct */
p_param = pmc_new(interp, enum_class_UnManagedStruct);
VTABLE_set_pointer(interp, p_param, external_data);
- pasm_sig[2] = 'P';
+ pasm_sig[1] = 'P';
param = (void*) p_param;
break;
#if 0
case 'P':
- pasm_sig[2] = 'P';
+ pasm_sig[1] = 'P';
break;
#endif
case 't':
- pasm_sig[2] = 'S';
+ pasm_sig[1] = 'S';
param = Parrot_str_new(interp, external_data, 0);
break;
default:
@@ -369,8 +368,10 @@
"unhandled signature char '%c' in run_cb", ch);
}
Parrot_str_free_cstring(sig_cstr);
- pasm_sig[3] = '\0';
- Parrot_runops_fromc_args_event(interp, sub, pasm_sig,
+ pasm_sig[2] = '-';
+ pasm_sig[3] = '>'; /* no return value supported yet */
+ pasm_sig[4] = '\0';
+ Parrot_pcc_invoke_sub_from_c_args(interp, sub, pasm_sig,
user_data, param);
}
/*
Modified: trunk/src/library.c
==============================================================================
--- trunk/src/library.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/library.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -162,6 +162,7 @@
PMC *paths;
STRING *entry;
STRING *versionlib = NULL;
+ STRING *builddir = NULL;
PMC * const iglobals = interp->iglobals;
PMC * const config_hash =
@@ -173,21 +174,31 @@
VTABLE_set_pmc_keyed_int(interp, iglobals,
IGLOBALS_LIB_PATHS, lib_paths);
+ if (VTABLE_elements(interp, config_hash)) {
+ STRING * const libkey = CONST_STRING(interp, "libdir");
+ STRING * const verkey = CONST_STRING(interp, "versiondir");
+ STRING * const builddirkey = CONST_STRING(interp, "build_dir");
+ versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey);
+ entry = VTABLE_get_string_keyed_str(interp, config_hash, verkey);
+ versionlib = Parrot_str_append(interp, versionlib, entry);
+
+ builddir = VTABLE_get_string_keyed_str(interp, config_hash, builddirkey);
+ }
+
/* each is an array of strings */
/* define include paths */
paths = pmc_new(interp, enum_class_ResizableStringArray);
VTABLE_set_pmc_keyed_int(interp, lib_paths,
PARROT_LIB_PATH_INCLUDE, paths);
- entry = CONST_STRING(interp, "runtime/parrot/include/");
- VTABLE_push_string(interp, paths, entry);
+ if (!STRING_IS_NULL(builddir)) {
+ entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/"), 0);
+ VTABLE_push_string(interp, paths, entry);
+ entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/include/"), 0);
+ VTABLE_push_string(interp, paths, entry);
+ }
entry = CONST_STRING(interp, "./");
VTABLE_push_string(interp, paths, entry);
- if (VTABLE_elements(interp, config_hash)) {
- STRING * const libkey = CONST_STRING(interp, "libdir");
- STRING * const verkey = CONST_STRING(interp, "versiondir");
- versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey);
- entry = VTABLE_get_string_keyed_str(interp, config_hash, verkey);
- versionlib = Parrot_str_append(interp, versionlib, entry);
+ if (!STRING_IS_NULL(versionlib)) {
entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/include/"), 0);
VTABLE_push_string(interp, paths, entry);
}
@@ -197,8 +208,10 @@
paths = pmc_new(interp, enum_class_ResizableStringArray);
VTABLE_set_pmc_keyed_int(interp, lib_paths,
PARROT_LIB_PATH_LIBRARY, paths);
- entry = CONST_STRING(interp, "runtime/parrot/library/");
- VTABLE_push_string(interp, paths, entry);
+ if (!STRING_IS_NULL(builddir)) {
+ entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/library/"), 0);
+ VTABLE_push_string(interp, paths, entry);
+ }
entry = CONST_STRING(interp, "./");
VTABLE_push_string(interp, paths, entry);
if (!STRING_IS_NULL(versionlib)) {
@@ -210,8 +223,10 @@
paths = pmc_new(interp, enum_class_ResizableStringArray);
VTABLE_set_pmc_keyed_int(interp, lib_paths,
PARROT_LIB_PATH_LANG, paths);
- entry = CONST_STRING(interp, "runtime/parrot/languages/");
- VTABLE_push_string(interp, paths, entry);
+ if (!STRING_IS_NULL(builddir)) {
+ entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/languages/"), 0);
+ VTABLE_push_string(interp, paths, entry);
+ }
entry = CONST_STRING(interp, "./");
VTABLE_push_string(interp, paths, entry);
if (!STRING_IS_NULL(versionlib)) {
@@ -223,8 +238,10 @@
paths = pmc_new(interp, enum_class_ResizableStringArray);
VTABLE_set_pmc_keyed_int(interp, lib_paths,
PARROT_LIB_PATH_DYNEXT, paths);
- entry = CONST_STRING(interp, "runtime/parrot/dynext/");
- VTABLE_push_string(interp, paths, entry);
+ if (!STRING_IS_NULL(builddir)) {
+ entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/dynext/"), 0);
+ VTABLE_push_string(interp, paths, entry);
+ }
entry = CONST_STRING(interp, "dynext/");
VTABLE_push_string(interp, paths, entry);
if (!STRING_IS_NULL(versionlib)) {
Modified: trunk/src/multidispatch.c
==============================================================================
--- trunk/src/multidispatch.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/multidispatch.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -136,11 +136,6 @@
__attribute__nonnull__(3);
PARROT_WARN_UNUSED_RESULT
-PARROT_CANNOT_RETURN_NULL
-static PMC* Parrot_mmd_arg_tuple_func(PARROT_INTERP)
- __attribute__nonnull__(1);
-
-PARROT_WARN_UNUSED_RESULT
PARROT_CAN_RETURN_NULL
static PMC * Parrot_mmd_get_cached_multi_sig(PARROT_INTERP,
ARGIN(PMC *sub_pmc))
@@ -214,8 +209,6 @@
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(name) \
, PARROT_ASSERT_ARG(candidates))
-#define ASSERT_ARGS_Parrot_mmd_arg_tuple_func __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp))
#define ASSERT_ARGS_Parrot_mmd_get_cached_multi_sig \
__attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
@@ -396,141 +389,6 @@
}
-/*
-
-=item C<PMC * Parrot_mmd_sort_manhattan(PARROT_INTERP, PMC *candidates)>
-
-Given an array PMC (usually a MultiSub) sorts the mmd candidates by their
-manhattan distance to the current args and returns the best one.
-
-=cut
-
-*/
-PARROT_EXPORT
-PARROT_CAN_RETURN_NULL
-PARROT_WARN_UNUSED_RESULT
-PMC *
-Parrot_mmd_sort_manhattan(PARROT_INTERP, ARGIN(PMC *candidates))
-{
- ASSERT_ARGS(Parrot_mmd_sort_manhattan)
- const INTVAL n = VTABLE_elements(interp, candidates);
-
- if (n) {
- PMC * const arg_tuple = Parrot_mmd_arg_tuple_func(interp);
- return Parrot_mmd_sort_candidates(interp, arg_tuple, candidates);
- }
-
- return PMCNULL;
-}
-
-
-/*
-
-=item C<static PMC* Parrot_mmd_arg_tuple_func(PARROT_INTERP)>
-
-Return a list of argument types. PMC arguments are taken from registers
-according to calling conventions.
-
-=cut
-
-*/
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CANNOT_RETURN_NULL
-static PMC*
-Parrot_mmd_arg_tuple_func(PARROT_INTERP)
-{
- ASSERT_ARGS(Parrot_mmd_arg_tuple_func)
- PMC *arg;
- PMC *args_array; /* from recent set_args opcode */
- PackFile_Constant **constants;
-
- /*
- * if there is no signature e.g. because of
- * m = getattribute l, "__add"
- * - we have to return the MultiSub
- * - create a BoundMulti
- * - dispatch in invoke - yeah ugly
- */
-
- PMC * const arg_tuple = pmc_new(interp, enum_class_ResizableIntegerArray);
- opcode_t *args_op = interp->current_args;
- INTVAL sig_len, i, type;
-
- if (!args_op)
- return arg_tuple;
-
- PARROT_ASSERT(*args_op == PARROT_OP_set_args_pc);
- constants = interp->code->const_table->constants;
- ++args_op;
- args_array = constants[*args_op]->u.key;
-
- ASSERT_SIG_PMC(args_array);
-
- sig_len = VTABLE_elements(interp, args_array);
- if (!sig_len)
- return arg_tuple;
-
- ++args_op;
-
- for (i = 0; i < sig_len; ++i, ++args_op) {
- type = VTABLE_get_integer_keyed_int(interp, args_array, i);
-
- /* named don't MMD */
- if (type & PARROT_ARG_NAME)
- break;
- switch (type & (PARROT_ARG_TYPE_MASK | PARROT_ARG_FLATTEN)) {
- case PARROT_ARG_INTVAL:
- VTABLE_push_integer(interp, arg_tuple, enum_type_INTVAL);
- break;
- case PARROT_ARG_FLOATVAL:
- VTABLE_push_integer(interp, arg_tuple, enum_type_FLOATVAL);
- break;
- case PARROT_ARG_STRING:
- VTABLE_push_integer(interp, arg_tuple, enum_type_STRING);
- break;
- case PARROT_ARG_PMC:
- {
- const int idx = *args_op;
- if ((type & PARROT_ARG_CONSTANT))
- arg = constants[idx]->u.key;
- else
- arg = REG_PMC(interp, idx);
-
- if (PMC_IS_NULL(arg))
- type = enum_type_PMC;
- else
- type = VTABLE_type(interp, arg);
-
- VTABLE_push_integer(interp, arg_tuple, type);
- }
- break;
- case PARROT_ARG_FLATTEN | PARROT_ARG_PMC: {
- /* expand flattening args */
- int j, n;
-
- const int idx = *args_op;
- arg = REG_PMC(interp, idx);
- n = VTABLE_elements(interp, arg);
-
- for (j = 0; j < n; ++j) {
- PMC * const elem = VTABLE_get_pmc_keyed_int(interp, arg, j);
- type = VTABLE_type(interp, elem);
- VTABLE_push_integer(interp, arg_tuple, type);
- }
- break;
- }
- default:
- Parrot_ex_throw_from_c_args(interp, NULL, 1,
- "Unknown signature type %d in mmd_arg_tuple", type);
- break;
- }
- }
-
-
- return arg_tuple;
-}
-
/*
@@ -654,25 +512,19 @@
Parrot_mmd_build_type_tuple_from_sig_obj(PARROT_INTERP, ARGIN(PMC *sig_obj))
{
ASSERT_ARGS(Parrot_mmd_build_type_tuple_from_sig_obj)
- PMC * const type_tuple = pmc_new(interp, enum_class_FixedIntegerArray);
+ PMC * const type_tuple = pmc_new(interp, enum_class_ResizableIntegerArray);
STRING *string_sig = VTABLE_get_string(interp, sig_obj);
- const INTVAL sig_len = Parrot_str_byte_length(interp, string_sig);
INTVAL tuple_size = 0;
INTVAL args_ended = 0;
INTVAL i, seen_invocant = 0;
+ INTVAL sig_len;
- /* First calculate the number of arguments participating in MMD */
- for (i = 0; i < sig_len; ++i) {
- INTVAL type = Parrot_str_indexed(interp, string_sig, i);
- if (type == '-')
- break;
- if (type == 'i')
- continue;
-
- tuple_size++;
+ if (STRING_IS_NULL(string_sig)) {
+ Parrot_ex_throw_from_c_args(interp, NULL, 1,
+ "Call has no signature, unable to dispatch.\n");
}
- VTABLE_set_integer_native(interp, type_tuple, tuple_size);
+ sig_len = Parrot_str_byte_length(interp, string_sig);
for (i = 0; i < sig_len; ++i) {
INTVAL type = Parrot_str_indexed(interp, string_sig, i + seen_invocant);
@@ -690,9 +542,16 @@
i, enum_type_FLOATVAL);
break;
case 'S':
- VTABLE_set_integer_keyed_int(interp, type_tuple,
- i, enum_type_STRING);
- break;
+ {
+ INTVAL type_lookahead = Parrot_str_indexed(interp, string_sig, (i + 1));
+ if (type_lookahead == 'n') {
+ args_ended = 1;
+ break;
+ }
+ VTABLE_set_integer_keyed_int(interp, type_tuple,
+ i, enum_type_STRING);
+ break;
+ }
case 'P':
{
INTVAL type_lookahead = Parrot_str_indexed(interp, string_sig, (i + 1));
@@ -703,6 +562,10 @@
"Multiple Dispatch: only the first argument can be an invocant");
seen_invocant = 1;
}
+ else if (type_lookahead == 'f') {
+ args_ended = 1;
+ break;
+ }
else {
PMC *pmc_arg = VTABLE_get_pmc_keyed_int(interp, sig_obj, i);
if (PMC_IS_NULL(pmc_arg))
Modified: trunk/src/nci_test.c
==============================================================================
--- trunk/src/nci_test.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/nci_test.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -36,7 +36,7 @@
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
-#include <parrot/config.h>
+#include <parrot/parrot.h>
#ifdef __cplusplus
extern "C" {
@@ -747,7 +747,7 @@
PARROT_EXPORT void
nci_vP(void *pmc)
{
- if (pmc)
+ if (!PMC_IS_NULL(pmc))
puts("ok");
else
puts("got null");
Modified: trunk/src/ops/core.ops
==============================================================================
--- trunk/src/ops/core.ops Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/ops/core.ops Wed Oct 21 16:54:18 2009 (r41972)
@@ -457,10 +457,14 @@
}
inline op tailcall(invar PMC) :flow {
- PMC * const p = $1;
- opcode_t *dest = expr NEXT();
- interp->current_cont = Parrot_pcc_get_continuation(interp,
- CURRENT_CONTEXT(interp));
+ PMC * const p = $1;
+ opcode_t *dest = expr NEXT();
+ PMC * const ctx = CURRENT_CONTEXT(interp);
+ PMC * const parent_ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
+ PMC * const this_call_sig = Parrot_pcc_get_signature(interp, ctx);
+ PMC * const parent_call_sig = Parrot_pcc_get_signature(interp, parent_ctx);
+ interp->current_cont = Parrot_pcc_get_continuation(interp, ctx);
+ Parrot_pcc_merge_signature_for_tailcall(interp, parent_call_sig, this_call_sig);
SUB_FLAG_TAILCALL_SET(interp->current_cont);
dest = VTABLE_invoke(interp, p, dest);
@@ -516,94 +520,71 @@
op set_args(inconst PMC) :flow {
- opcode_t * const _this = CUR_OPCODE;
+ opcode_t * const raw_args = CUR_OPCODE;
PMC * const signature = $1;
+ PMC * call_sig;
INTVAL argc;
- /* for now just point to the opcode */
- interp->current_args = _this;
+ call_sig = Parrot_pcc_build_sig_object_from_op(interp,
+ PMCNULL, signature, raw_args);
+ Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), call_sig);
+
argc = VTABLE_elements(interp, signature);
goto OFFSET(argc + 2);
}
op get_results(inconst PMC) :flow {
- opcode_t * const _this = CUR_OPCODE;
+ opcode_t * const raw_returns = CUR_OPCODE;
PMC * const signature = $1;
+ PMC * call_sig;
INTVAL argc;
- Parrot_pcc_set_results(interp, CURRENT_CONTEXT(interp), _this);
+ call_sig = Parrot_pcc_build_sig_object_returns_from_op(interp,
+ Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp)),
+ signature, raw_returns);
+ Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), call_sig);
+
argc = VTABLE_elements(interp, signature);
goto OFFSET(argc + 2);
}
op get_params(inconst PMC) :flow {
- opcode_t * const _this = CUR_OPCODE;
+ opcode_t * const raw_params = CUR_OPCODE;
PMC *caller_ctx, *ctx;
- PMC * ccont;
+ PMC *ccont, *call_object;
PMC * const signature = $1;
INTVAL argc;
- opcode_t *src_indexes, *dst_indexes;
- interp->current_params = _this;
ctx = CURRENT_CONTEXT(interp);
ccont = Parrot_pcc_get_continuation(interp, ctx);
caller_ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
+ call_object = Parrot_pcc_get_signature(interp, caller_ctx);
- src_indexes = interp->current_args;
- dst_indexes = interp->current_params;
- /* the args and params are now 'used.' */
- interp->current_args = NULL;
- interp->current_params = NULL;
+ Parrot_pcc_fill_params_from_op(interp, call_object, signature, raw_params);
- parrot_pass_args(interp, caller_ctx, ctx, src_indexes, dst_indexes, PARROT_PASS_PARAMS);
/* TODO Factor out with Sub.invoke */
if (PObj_get_FLAGS(ccont) & SUB_FLAG_TAILCALL) {
PObj_get_FLAGS(ccont) &= ~SUB_FLAG_TAILCALL;
Parrot_pcc_dec_recursion_depth(interp, ctx);
Parrot_pcc_set_caller_ctx(interp, ctx, Parrot_pcc_get_caller_ctx(interp, caller_ctx));
- interp->current_args = NULL;
}
argc = VTABLE_elements(interp, signature);
goto OFFSET(argc + 2);
}
op set_returns(inconst PMC) :flow {
- opcode_t * const _this = CUR_OPCODE;
- PMC *ctx, *caller_ctx;
- PMC *ccont;
- PMC *signature = $1;
- INTVAL argc;
- opcode_t *src_indexes, *dest_indexes;
+ opcode_t * const raw_returns = CUR_OPCODE;
+ PMC *signature = $1;
+ PMC *ctx = CURRENT_CONTEXT(interp);
+ PMC *caller_ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
+ PMC *call_object = Parrot_pcc_get_signature(interp, caller_ctx);
+ INTVAL argc = VTABLE_elements(interp, signature);
- interp->current_returns = _this;
- ctx = CURRENT_CONTEXT(interp);
- caller_ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
- ccont = Parrot_pcc_get_continuation(interp, ctx);
-
- if (PARROT_CONTINUATION(ccont)->address) {
- /* Call is from runops_fromc */
- caller_ctx = PMC_cont(ccont)->to_ctx;
- if (PMC_IS_NULL(caller_ctx)) {
- /* there is no point calling Parrot_ex_throw_..., because
- PDB_backtrace can't deal with a missing to_ctx either. */
- exit_fatal(1, "No caller_ctx for continuation %p.", ccont);
- }
+ Parrot_pcc_fill_returns_from_op(interp, call_object, signature, raw_returns);
+
+ Parrot_pcc_set_signature(interp, ctx, NULL);
- src_indexes = interp->current_returns;
- dest_indexes = Parrot_pcc_get_results(interp, caller_ctx);
- interp->current_returns = NULL;
- /* does this need to be here */
- interp->current_args = NULL;
-
- parrot_pass_args(interp, ctx, caller_ctx, src_indexes, dest_indexes, PARROT_PASS_RESULTS);
- }
- else if (Parrot_pcc_get_results_signature(interp, caller_ctx)) {
- /* We have a dynamic result signature, from pcc_invoke */
- parrot_pass_args(interp, ctx, caller_ctx, interp->current_returns,
- Parrot_pcc_get_results(interp, caller_ctx), PARROT_PASS_RESULTS);
- }
- argc = VTABLE_elements(interp, signature);
goto OFFSET(argc + 2);
}
@@ -617,17 +598,10 @@
=cut
inline op result_info(out PMC) {
- /* Get context of callee from return continuation. */
- PMC * const cc = Parrot_pcc_get_continuation(interp, CURRENT_CONTEXT(interp));
- PMC *sig = NULL;
- if (cc && PARROT_CONTINUATION(cc)->to_ctx) {
- /* caller context has results */
- opcode_t * const results = Parrot_pcc_get_results(interp, PMC_cont(cc)->to_ctx);
- if (results) {
- /* get results PMC index and get PMC. */
- sig = PF_CONST(PARROT_CONTINUATION(cc)->seg, results[1])->u.key;
- }
- }
+ PMC *caller_ctx = Parrot_pcc_get_caller_ctx(interp, CURRENT_CONTEXT(interp));
+ PMC *call_object = Parrot_pcc_get_signature(interp, caller_ctx);
+ PMC *sig = VTABLE_get_attr_str(interp, call_object,
+ Parrot_str_new_constant(interp, "return_flags"));
/* If no elements, hand back empty array; otherwise PMC. */
if (!sig)
Modified: trunk/src/ops/object.ops
==============================================================================
--- trunk/src/ops/object.ops Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/ops/object.ops Wed Oct 21 16:54:18 2009 (r41972)
@@ -51,11 +51,8 @@
STRING * const meth = $2;
opcode_t * const next = expr NEXT();
- /* a class-specific find_method can overwrite interp->current_args()! */
- opcode_t *current_args = interp->current_args;
PMC * const method_pmc = VTABLE_find_method(interp, object, meth);
opcode_t *dest = NULL;
- interp->current_args = current_args;
if (PMC_IS_NULL(method_pmc)) {
PMC * const _class = VTABLE_get_class(interp, object);
@@ -95,11 +92,8 @@
STRING * const meth = $2;
opcode_t * const next = expr NEXT();
- /* a class-specific find_method can overwrite interp->current_args()! */
- opcode_t *current_args = interp->current_args;
PMC * const method_pmc = VTABLE_find_method(interp, object, meth);
opcode_t *dest = NULL;
- interp->current_args = current_args;
if (PMC_IS_NULL(method_pmc)) {
Modified: trunk/src/packfile.c
==============================================================================
--- trunk/src/packfile.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/packfile.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -669,7 +669,7 @@
{
ASSERT_ARGS(run_sub)
Parrot_runcore_t *old_core = interp->run_core;
- PMC *retval;
+ PMC *retval = PMCNULL;
/* turn off JIT and prederef - both would act on the whole
* PackFile which probably isn't worth the effort */
@@ -680,7 +680,7 @@
Parrot_pcc_set_constants(interp, CURRENT_CONTEXT(interp),
interp->code->const_table->constants);
- retval = (PMC *)Parrot_runops_fromc_args(interp, sub_pmc, "P");
+ Parrot_pcc_invoke_sub_from_c_args(interp, sub_pmc, "->P", &retval);
interp->run_core = old_core;
return retval;
Modified: trunk/src/pmc/callsignature.pmc
==============================================================================
--- trunk/src/pmc/callsignature.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/callsignature.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -19,18 +19,340 @@
*/
-#define CAPTURE_DATA_SIZE 2
-#define CAPTURE_array_CREATE(i, obj) \
- if (!PARROT_CAPTURE(obj)->array) \
- PARROT_CAPTURE(obj)->array = pmc_new((i), enum_class_ResizablePMCArray);
-#define CAPTURE_hash_CREATE(i, obj) \
- if (!PARROT_CAPTURE(obj)->hash) \
- PARROT_CAPTURE(obj)->hash = pmc_new((i), enum_class_Hash);
-
-pmclass CallSignature extends Capture auto_attrs provides array provides hash {
- ATTR PMC *returns; /* Result PMCs, if they were passed with the call */
- ATTR PMC *type_tuple; /* Cached argument types for multiple dispatch */
- ATTR STRING *short_sig; /* Simple string signature args & returns */
+typedef struct Pcc_cell
+{
+ union u {
+ PMC *p;
+ STRING *s;
+ INTVAL i;
+ FLOATVAL n;
+ } u;
+ struct Pcc_cell *next;
+} Pcc_cell;
+
+/* mask off lower two bits (1 + 2 = 3) for pointer tags */
+#define TAG_BITS 3
+#define UNTAG_CELL(c) INTVAL2PTR(Pcc_cell *, (PTR2INTVAL(c)) & ~TAG_BITS)
+
+#define CELL_INT(c) UNTAG_CELL(c)->u.i
+#define CELL_FLOAT(c) UNTAG_CELL(c)->u.n
+#define CELL_STRING(c) UNTAG_CELL(c)->u.s
+#define CELL_PMC(c) UNTAG_CELL(c)->u.p
+
+#define NEXT_CELL(c) UNTAG_CELL(c)->next
+#define FREE_CELL(c) mem_sys_free(UNTAG_CELL(c))
+
+#define CELL_TYPE_MASK(c) (PTR2INTVAL(c)) & 3
+#define INTCELL 0
+#define FLOATCELL 1
+#define STRINGCELL 2
+#define PMCCELL 3
+
+#define SET_CELL_INT(c) \
+ INTVAL2PTR(Pcc_cell *, PTR2INTVAL(UNTAG_CELL(c)) | INTCELL)
+
+#define SET_CELL_FLOAT(c) \
+ INTVAL2PTR(Pcc_cell *, PTR2INTVAL(UNTAG_CELL(c)) | FLOATCELL)
+
+#define SET_CELL_STRING(c) \
+ INTVAL2PTR(Pcc_cell *, PTR2INTVAL(UNTAG_CELL(c)) | STRINGCELL)
+
+#define SET_CELL_PMC(c) \
+ INTVAL2PTR(Pcc_cell *, PTR2INTVAL(UNTAG_CELL(c)) | PMCCELL)
+
+#define CREATE_INTVAL_CELL SET_CELL_INT(mem_allocate_zeroed_typed(Pcc_cell))
+
+#define CREATE_FLOATVAL_CELL SET_CELL_FLOAT(mem_allocate_zeroed_typed(Pcc_cell))
+
+#define CREATE_STRING_CELL SET_CELL_STRING(mem_allocate_zeroed_typed(Pcc_cell))
+
+#define CREATE_PMC_CELL SET_CELL_PMC(mem_allocate_zeroed_typed(Pcc_cell))
+
+#define APPEND_CELL(SELF, cell) \
+ do { \
+ Parrot_CallSignature_attributes * const a = PARROT_CALLSIGNATURE(SELF);\
+ (a)->num_positionals++; \
+ if ((a)->positionals) { \
+ Pcc_cell *c = (a)->positionals; \
+ while (NEXT_CELL(c)) { \
+ c = NEXT_CELL(c); \
+ } \
+ NEXT_CELL(c) = (cell); \
+ } \
+ else \
+ (a)->positionals = (cell); \
+ } while (0)
+
+#define PREPEND_CELL(SELF, cell) \
+ do { \
+ Parrot_CallSignature_attributes * const a = PARROT_CALLSIGNATURE(SELF);\
+ a->num_positionals++; \
+ NEXT_CELL(cell) = a->positionals; \
+ a->positionals = (cell); \
+ } while (0)
+
+/* TODO: could use get_cell_at */
+static Pcc_cell *
+pop_cell(PARROT_INTERP, ARGIN(PMC *SELF))
+{
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+ Pcc_cell *cell = attrs->positionals;
+ Pcc_cell *prev = NULL;
+
+ /* no cells */
+ if (!cell)
+ return NULL;
+
+ attrs->num_positionals--;
+
+ /* one cell */
+ if (!NEXT_CELL(cell)) {
+ attrs->positionals = NULL;
+ return cell;
+ }
+
+ while (cell) {
+ if (!NEXT_CELL(cell)) {
+ NEXT_CELL(prev) = NULL;
+ return cell;
+ }
+
+ prev = cell;
+ cell = NEXT_CELL(cell);
+ }
+
+ /* should abort here */
+ attrs->num_positionals++;
+ return NULL;
+}
+
+static Pcc_cell *
+shift_cell(PARROT_INTERP, ARGIN(PMC *SELF))
+{
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+ Pcc_cell *cell = attrs->positionals;
+
+ /* no cells */
+ if (!cell)
+ return NULL;
+
+ attrs->num_positionals--;
+
+ /* one cell */
+ if (!NEXT_CELL(cell))
+ attrs->positionals = NULL;
+ else
+ attrs->positionals = NEXT_CELL(cell);
+
+ return cell;
+}
+
+static Pcc_cell *
+get_cell_at(PARROT_INTERP, ARGIN(PMC *SELF), INTVAL key)
+{
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+ Pcc_cell *cell = attrs->positionals;
+ INTVAL i;
+
+ if (key > attrs->num_positionals)
+ return NULL;
+
+ while (key) {
+ /* XXX: shouldn't happen */
+ if (!NEXT_CELL(cell))
+ return NULL;
+
+ cell = NEXT_CELL(cell);
+ key--;
+ }
+
+ return cell;
+
+}
+
+static INTVAL
+autobox_intval(PARROT_INTERP, Pcc_cell *cell)
+{
+ switch (CELL_TYPE_MASK(cell)) {
+ case INTCELL:
+ return CELL_INT(cell);
+ case FLOATCELL:
+ return (INTVAL)CELL_FLOAT(cell);
+ case STRINGCELL:
+ return CELL_STRING(cell) ? Parrot_str_to_int(interp, CELL_STRING(cell)) : 0;
+ case PMCCELL:
+ return PMC_IS_NULL(CELL_PMC(cell))
+ ? 0
+ : VTABLE_get_integer(interp, CELL_PMC(cell));
+ default:
+ break;
+ }
+
+ /* exception */
+ return 0;
+}
+
+static FLOATVAL
+autobox_floatval(PARROT_INTERP, Pcc_cell *cell)
+{
+ switch (CELL_TYPE_MASK(cell)) {
+ case INTCELL:
+ return (FLOATVAL)CELL_INT(cell);
+ case FLOATCELL:
+ return CELL_FLOAT(cell);
+ case STRINGCELL:
+ return CELL_STRING(cell) ? Parrot_str_to_num(interp, CELL_STRING(cell)) : 0.0;
+ case PMCCELL:
+ return PMC_IS_NULL(CELL_PMC(cell))
+ ? 0.0
+ : VTABLE_get_number(interp, CELL_PMC(cell));
+ default:
+ break;
+ }
+
+ /* exception */
+ return 0.0;
+}
+
+static STRING *
+autobox_string(PARROT_INTERP, Pcc_cell *cell)
+{
+ switch (CELL_TYPE_MASK(cell)) {
+ case INTCELL:
+ return Parrot_str_from_int(interp, CELL_INT(cell));
+ case FLOATCELL:
+ return Parrot_str_from_num(interp, CELL_FLOAT(cell));
+ case STRINGCELL:
+ return CELL_STRING(cell);
+ case PMCCELL:
+ return PMC_IS_NULL(CELL_PMC(cell))
+ ? NULL
+ : VTABLE_get_string(interp, CELL_PMC(cell));
+ default:
+ break;
+ }
+
+ /* exception */
+ return NULL;
+}
+
+static PMC *
+autobox_pmc(PARROT_INTERP, Pcc_cell *cell)
+{
+ PMC *result = PMCNULL;
+
+ /* TODO: respect HLL types? */
+ switch (CELL_TYPE_MASK(cell)) {
+ case INTCELL:
+ result = pmc_new(interp, enum_class_Integer);
+ VTABLE_set_integer_native(interp, result, CELL_INT(cell));
+ break;
+ case FLOATCELL:
+ result = pmc_new(interp, enum_class_Float);
+ VTABLE_set_number_native(interp, result, CELL_FLOAT(cell));
+ break;
+ case STRINGCELL:
+ result = pmc_new(interp, enum_class_String);
+ VTABLE_set_string_native(interp, result, CELL_STRING(cell));
+ break;
+ case PMCCELL:
+ return CELL_PMC(cell);
+ default:
+ /* exception */
+ break;
+ }
+
+ return result;
+}
+
+static Hash *
+get_hash(PARROT_INTERP, ARGIN(PMC *SELF))
+{
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+
+ if (!attrs->hash)
+ attrs->hash = parrot_new_hash(interp);
+
+ return attrs->hash;
+}
+
+static void
+mark_positionals(PARROT_INTERP, ARGIN(Pcc_cell *c))
+{
+ while (c) {
+ switch (CELL_TYPE_MASK(c)) {
+ case STRINGCELL:
+ if (CELL_STRING(c))
+ Parrot_gc_mark_STRING_alive(interp, CELL_STRING(c));
+ break;
+ case PMCCELL:
+ if (!PMC_IS_NULL(CELL_PMC(c)))
+ Parrot_gc_mark_PMC_alive(interp, CELL_PMC(c));
+ break;
+ case INTCELL:
+ case FLOATCELL:
+ default:
+ break;
+ }
+
+ c = NEXT_CELL(c);
+ }
+}
+
+/* don't look now, but here goes encapsulation.... */
+static void
+mark_hash(PARROT_INTERP, ARGIN(Hash *h))
+{
+ UINTVAL entries = h->entries;
+ INTVAL i;
+
+ for (i = h->mask; i >= 0; --i) {
+ HashBucket *b = h->bi[i];
+
+ while (b) {
+ Parrot_gc_mark_STRING_alive(interp, (STRING *)b->key);
+ mark_positionals(interp, (Pcc_cell *)b->value);
+ b = b->next;
+ }
+
+ }
+}
+
+static PMC *
+get_named_names(PARROT_INTERP, ARGIN(PMC *SELF))
+{
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+ PMC *result = PMCNULL;
+
+ /* yes, this *looks* risky, but it's a Parrot STRING hash internally */
+ if (attrs->hash && attrs->hash->entries) {
+ UINTVAL i, j = 0;
+ result = pmc_new(interp, enum_class_FixedStringArray);
+ VTABLE_set_integer_native(interp, result, attrs->hash->entries);
+
+ for (i = 0; i <= attrs->hash->mask; i++) {
+ HashBucket *b = attrs->hash->bi[i];
+
+ while (b) {
+ VTABLE_set_string_keyed_int(interp, result,
+ j++, (STRING *)b->key);
+ b = b->next;
+ }
+ }
+ }
+
+ return result;
+}
+
+pmclass CallSignature auto_attrs provides array provides hash {
+ ATTR struct Pcc_cell *positionals; /* linked list of positionals */
+ ATTR PMC *results; /* Storage for return arguments */
+ ATTR PMC *type_tuple; /* Cached argument types for MDD */
+ ATTR STRING *short_sig; /* Simple string sig args & returns */
+ ATTR PMC *arg_flags; /* Integer array of argument flags */
+ ATTR PMC *return_flags; /* Integer array of return flags */
+ ATTR Hash *hash; /* Hash of named arguments */
+ ATTR INTVAL num_positionals; /* count of positionals */
/*
@@ -43,11 +365,14 @@
*/
VTABLE void init() {
- Parrot_CallSignature_attributes * const sig_struct =
- (Parrot_CallSignature_attributes *) PMC_data(SELF);
+ Parrot_CallSignature_attributes * const attrs =
+ PMC_data_typed(SELF, Parrot_CallSignature_attributes *);
SUPER();
- sig_struct->type_tuple = PMCNULL;
- sig_struct->returns = PMCNULL;
+ attrs->type_tuple = PMCNULL;
+ attrs->results = PMCNULL;
+ attrs->positionals = NULL;
+ attrs->num_positionals = 0;
+ PObj_custom_mark_destroy_SETALL(SELF);
}
/*
@@ -61,8 +386,8 @@
*/
VTABLE void set_string_native(STRING *value) {
- Parrot_CallSignature_attributes * const sig_struct = PARROT_CALLSIGNATURE(SELF);
- sig_struct->short_sig = value;
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+ attrs->short_sig = value;
}
/*
@@ -76,8 +401,8 @@
*/
VTABLE STRING *get_string() {
- Parrot_CallSignature_attributes * const sig_struct = PARROT_CALLSIGNATURE(SELF);
- return sig_struct->short_sig;
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+ return attrs->short_sig;
}
/*
@@ -91,8 +416,8 @@
*/
VTABLE void set_pmc(PMC *value) {
- Parrot_CallSignature_attributes * const sig_struct = PARROT_CALLSIGNATURE(SELF);
- sig_struct->type_tuple = value;
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+ attrs->type_tuple = value;
}
/*
@@ -128,10 +453,20 @@
=over
-=item returns
+=item results
Stores the return signature, an array of PMCs.
+=item arg_flags
+
+Stores a set of flags for the call signature arguments, an array of
+integers.
+
+=item return_flags
+
+Stores a set of flags for the call signature return arguments, an array
+of integers.
+
=back
=cut
@@ -139,8 +474,24 @@
*/
VTABLE void set_attr_str(STRING *key, PMC *value) {
- Parrot_CallSignature_attributes * const sig_struct = PARROT_CALLSIGNATURE(SELF);
- sig_struct->returns = value;
+
+ if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "results"))) {
+ SET_ATTR_results(interp, SELF, value);
+ }
+ else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "returns"))) {
+ SET_ATTR_results(interp, SELF, value);
+ }
+ else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "arg_flags"))) {
+ SET_ATTR_arg_flags(interp, SELF, value);
+ }
+ else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "return_flags"))) {
+ SET_ATTR_return_flags(interp, SELF, value);
+ }
+ else {
+ /* If unknown attribute name, throw an exception. */
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ATTRIB_NOT_FOUND,
+ "No such attribute '%S'", key);
+ }
}
/*
@@ -151,10 +502,24 @@
=over
-=item returns
+=item results
Retrieves the return signature, an array of PMCs.
+=item arg_flags
+
+Retrieves the flags for the call signature arguments, an array of
+integers.
+
+=item return_flags
+
+Retrieves the flags for the call signature return arguments, an array of
+integers.
+
+=item named
+
+Retrieves the hash of named arguments.
+
=back
=cut
@@ -162,8 +527,30 @@
*/
VTABLE PMC *get_attr_str(STRING *key) {
- Parrot_CallSignature_attributes * const sig_struct = PARROT_CALLSIGNATURE(SELF);
- return sig_struct->returns;
+ PMC *value = PMCNULL;
+
+ if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "named"))) {
+ value = get_named_names(INTERP, SELF);
+ }
+ else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "results"))) {
+ GET_ATTR_results(interp, SELF, value);
+ }
+ else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "returns"))) {
+ GET_ATTR_results(interp, SELF, value);
+ }
+ else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "arg_flags"))) {
+ GET_ATTR_arg_flags(interp, SELF, value);
+ }
+ else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "return_flags"))) {
+ GET_ATTR_return_flags(interp, SELF, value);
+ }
+ else {
+ /* If unknown attribute name, throw an exception. */
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ATTRIB_NOT_FOUND,
+ "No such attribute '%S'", key);
+ }
+
+ return value;
}
/*
@@ -177,15 +564,565 @@
*/
VTABLE void mark() {
Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+ if (!attrs)
+ return;
- if (attrs) {
- Parrot_gc_mark_PMC_alive(interp, attrs->returns);
- Parrot_gc_mark_PMC_alive(interp, attrs->type_tuple);
- Parrot_gc_mark_STRING_alive(interp, attrs->short_sig);
+ Parrot_gc_mark_PMC_alive(interp, attrs->results);
+ Parrot_gc_mark_PMC_alive(interp, attrs->type_tuple);
+ Parrot_gc_mark_STRING_alive(interp, attrs->short_sig);
+ Parrot_gc_mark_PMC_alive(interp, attrs->arg_flags);
+ Parrot_gc_mark_PMC_alive(interp, attrs->return_flags);
+
+ if (attrs->num_positionals)
+ mark_positionals(interp, attrs->positionals);
+
+ if (attrs->hash)
+ mark_hash(interp, attrs->hash);
+ }
+
+ VTABLE void destroy() {
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+ if (!attrs)
+ return;
+
+ if (attrs->num_positionals) {
+ Pcc_cell *c = attrs->positionals;
+
+ while (c) {
+ Pcc_cell *to_free = c;
+ c = NEXT_CELL(c);
+ FREE_CELL(to_free);
+ }
}
- SUPER();
+
+ if (attrs->hash) {
+ UINTVAL i;
+
+ for (i = 0; i <= attrs->hash->mask; i++) {
+ HashBucket *b = attrs->hash->bi[i];
+
+ while (b) {
+ FREE_CELL((Pcc_cell *)b->value);
+ b = b->next;
+ }
+ }
+
+ parrot_hash_destroy(interp, attrs->hash);
+ }
+ }
+
+ VTABLE INTVAL elements() {
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+ if (!attrs)
+ return 0;
+
+ return attrs->num_positionals;
+ }
+
+ VTABLE void push_integer(INTVAL value) {
+ Pcc_cell *cell = CREATE_INTVAL_CELL;
+ APPEND_CELL(SELF, cell);
+ CELL_INT(cell) = value;
+ }
+
+ VTABLE void push_float(FLOATVAL value) {
+ Pcc_cell *cell = CREATE_FLOATVAL_CELL;
+ APPEND_CELL(SELF, cell);
+ CELL_FLOAT(cell) = value;
+ }
+
+ VTABLE void push_string(STRING *value) {
+ Pcc_cell *cell = CREATE_STRING_CELL;
+ APPEND_CELL(SELF, cell);
+ CELL_STRING(cell) = value;
+ }
+
+ VTABLE void push_pmc(PMC *value) {
+ Pcc_cell *cell = CREATE_PMC_CELL;
+ APPEND_CELL(SELF, cell);
+ CELL_PMC(cell) = value;
}
+ VTABLE INTVAL pop_integer() {
+ Pcc_cell *cell = pop_cell(interp, SELF);
+
+ if (cell) {
+ INTVAL result = autobox_intval(interp, cell);
+ FREE_CELL(cell);
+ return result;
+ }
+
+ return 0;
+ }
+
+ VTABLE FLOATVAL pop_float() {
+ Pcc_cell *cell = pop_cell(interp, SELF);
+
+ if (cell) {
+ FLOATVAL result = autobox_floatval(interp, cell);
+ FREE_CELL(cell);
+ return result;
+ }
+
+ return 0.0;
+ }
+
+ VTABLE PMC * pop_pmc() {
+ Pcc_cell *cell = pop_cell(interp, SELF);
+
+ if (cell) {
+ PMC *result = autobox_pmc(interp, cell);
+ FREE_CELL(cell);
+ return result;
+ }
+
+ return PMCNULL;
+ }
+
+ VTABLE STRING * pop_string() {
+ Pcc_cell *cell = pop_cell(interp, SELF);
+
+ if (cell) {
+ STRING *result = autobox_string(interp, cell);
+ FREE_CELL(cell);
+ return result;
+ }
+
+ return NULL;
+ }
+
+ VTABLE INTVAL get_integer_keyed_int(INTVAL key) {
+ Pcc_cell *cell = get_cell_at(interp, SELF, key);
+
+ if (!cell)
+ return 0;
+
+ return autobox_intval(interp, cell);
+ }
+
+ VTABLE FLOATVAL get_number_keyed_int(INTVAL key) {
+ Pcc_cell *cell = get_cell_at(interp, SELF, key);
+
+ if (!cell)
+ return 0.0;
+
+ return autobox_floatval(interp, cell);
+ }
+
+ VTABLE STRING * get_string_keyed_int(INTVAL key) {
+ Pcc_cell *cell = get_cell_at(interp, SELF, key);
+
+ if (!cell)
+ return NULL;
+
+ return autobox_string(interp, cell);
+ }
+
+ VTABLE PMC * get_pmc_keyed_int(INTVAL key) {
+ Pcc_cell *cell = get_cell_at(interp, SELF, key);
+
+ if (!cell)
+ return PMCNULL;
+
+ return autobox_pmc(interp, cell);
+ }
+
+ VTABLE void unshift_integer(INTVAL value) {
+ Pcc_cell *cell = CREATE_INTVAL_CELL;
+ PREPEND_CELL(SELF, cell);
+ CELL_INT(cell) = value;
+ }
+
+ VTABLE void unshift_float(FLOATVAL value) {
+ Pcc_cell *cell = CREATE_FLOATVAL_CELL;
+ PREPEND_CELL(SELF, cell);
+ CELL_FLOAT(cell) = value;
+ }
+
+ VTABLE void unshift_string(STRING *value) {
+ Pcc_cell *cell = CREATE_STRING_CELL;
+ PREPEND_CELL(SELF, cell);
+ CELL_STRING(cell) = value;
+ }
+
+ VTABLE void unshift_pmc(PMC *value) {
+ Parrot_CallSignature_attributes * const a = PARROT_CALLSIGNATURE(SELF);
+ Pcc_cell *cell = CREATE_PMC_CELL;
+ PREPEND_CELL(SELF, cell);
+ CELL_PMC(cell) = value;
+ }
+
+ VTABLE INTVAL shift_integer() {
+ Pcc_cell *cell = shift_cell(interp, SELF);
+
+ if (cell) {
+ INTVAL result = autobox_intval(interp, cell);
+ FREE_CELL(cell);
+ return result;
+ }
+
+ return 0;
+ }
+
+ VTABLE FLOATVAL shift_float() {
+ Pcc_cell *cell = shift_cell(interp, SELF);
+
+ if (cell) {
+ FLOATVAL result = autobox_floatval(interp, cell);
+ FREE_CELL(cell);
+ return result;
+ }
+
+ return 0.0;
+ }
+
+ VTABLE STRING * shift_string() {
+ Pcc_cell *cell = shift_cell(interp, SELF);
+
+ if (cell) {
+ STRING *result = autobox_string(interp, cell);
+ FREE_CELL(cell);
+ return result;
+ }
+
+ return NULL;
+ }
+
+ VTABLE PMC * shift_pmc() {
+ Pcc_cell *cell = shift_cell(interp, SELF);
+
+ if (cell) {
+ PMC *result = autobox_pmc(interp, cell);
+ FREE_CELL(cell);
+ return result;
+ }
+
+ return PMCNULL;
+ }
+
+ VTABLE void set_integer_keyed_int(INTVAL key, INTVAL value) {
+ Pcc_cell *cell = get_cell_at(interp, SELF, key);
+
+ if (!cell) {
+ Parrot_CallSignature_attributes * const a =
+ PARROT_CALLSIGNATURE(SELF);
+ if (key == a->num_positionals)
+ VTABLE_push_integer(interp, SELF, value);
+
+ /* XXX: else throw exception? */
+ return;
+ }
+
+ CELL_INT(cell) = value;
+ }
+
+ VTABLE void set_number_keyed_int(INTVAL key, FLOATVAL value) {
+ Pcc_cell *cell = get_cell_at(interp, SELF, key);
+
+ if (!cell) {
+ Parrot_CallSignature_attributes * const a =
+ PARROT_CALLSIGNATURE(SELF);
+ if (key == a->num_positionals)
+ VTABLE_push_float(interp, SELF, value);
+
+ /* XXX: else throw exception? */
+ return;
+ }
+
+ CELL_FLOAT(cell) = value;
+ }
+
+ VTABLE void set_string_keyed_int(INTVAL key, STRING *value) {
+ Pcc_cell *cell = get_cell_at(interp, SELF, key);
+
+ if (!cell) {
+ Parrot_CallSignature_attributes * const a =
+ PARROT_CALLSIGNATURE(SELF);
+ if (key == a->num_positionals)
+ VTABLE_push_string(interp, SELF, value);
+
+ /* XXX: else throw exception? */
+ return;
+ }
+
+ CELL_STRING(cell) = value;
+ }
+
+ VTABLE void set_pmc_keyed_int(INTVAL key, PMC *value) {
+ Pcc_cell *cell = get_cell_at(interp, SELF, key);
+
+ if (!cell) {
+ Parrot_CallSignature_attributes * const a =
+ PARROT_CALLSIGNATURE(SELF);
+ if (key == a->num_positionals)
+ VTABLE_push_pmc(interp, SELF, value);
+
+ /* XXX: else throw exception? */
+ return;
+ }
+
+ CELL_PMC(cell) = value;
+ }
+
+ VTABLE void set_integer_keyed_str(STRING *key, INTVAL value) {
+ Hash *hash = get_hash(interp, SELF);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, (void *)key);
+
+ if (!cell) {
+ cell = CREATE_INTVAL_CELL;
+ parrot_hash_put(interp, hash, (void *)key, (void *)cell);
+ }
+ else
+ SET_CELL_INT(cell);
+
+ CELL_INT(cell) = value;
+ }
+
+ VTABLE void set_number_keyed_str(STRING *key, FLOATVAL value) {
+ Hash *hash = get_hash(interp, SELF);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, (void *)key);
+
+ if (!cell) {
+ cell = CREATE_FLOATVAL_CELL;
+ parrot_hash_put(interp, hash, (void *)key, (void *)cell);
+ }
+ else
+ SET_CELL_FLOAT(cell);
+
+ CELL_FLOAT(cell) = value;
+ }
+
+ VTABLE void set_string_keyed_str(STRING *key, STRING *value) {
+ Hash *hash = get_hash(interp, SELF);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, (void *)key);
+
+ if (!cell) {
+ cell = CREATE_STRING_CELL;
+ parrot_hash_put(interp, hash, (void *)key, (void *)cell);
+ }
+ else
+ SET_CELL_STRING(cell);
+
+ CELL_STRING(cell) = value;
+ }
+
+ VTABLE void set_pmc_keyed_str(STRING *key, PMC *value) {
+ Hash *hash = get_hash(interp, SELF);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, (void *)key);
+
+ if (!cell) {
+ cell = CREATE_PMC_CELL;
+ parrot_hash_put(interp, hash, (void *)key, (void *)cell);
+ }
+ else
+ SET_CELL_PMC(cell);
+
+ CELL_PMC(cell) = value;
+ }
+
+ VTABLE void set_integer_keyed(PMC *key, INTVAL value) {
+ Hash *hash = get_hash(interp, SELF);
+ void *k = hash_key_from_pmc(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (!cell) {
+ cell = CREATE_INTVAL_CELL;
+ parrot_hash_put(interp, hash, k, (void *)cell);
+ }
+ else
+ SET_CELL_INT(cell);
+
+ CELL_INT(cell) = value;
+ }
+
+ VTABLE void set_number_keyed(PMC *key, FLOATVAL value) {
+ Hash *hash = get_hash(interp, SELF);
+ void *k = hash_key_from_pmc(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (!cell) {
+ cell = CREATE_FLOATVAL_CELL;
+ parrot_hash_put(interp, hash, k, (void *)cell);
+ }
+ else
+ SET_CELL_FLOAT(cell);
+
+ CELL_FLOAT(cell) = value;
+ }
+
+ VTABLE void set_string_keyed(PMC *key, STRING *value) {
+ Hash *hash = get_hash(interp, SELF);
+ void *k = hash_key_from_pmc(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (!cell) {
+ cell = CREATE_STRING_CELL;
+ parrot_hash_put(interp, hash, k, (void *)cell);
+ }
+ else
+ SET_CELL_STRING(cell);
+
+ CELL_STRING(cell) = value;
+ }
+
+ VTABLE void set_pmc_keyed(PMC *key, PMC *value) {
+ Hash *hash = get_hash(interp, SELF);
+ void *k = hash_key_from_pmc(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (!cell) {
+ cell = CREATE_PMC_CELL;
+ parrot_hash_put(interp, hash, k, (void *)cell);
+ }
+ else
+ SET_CELL_PMC(cell);
+
+ CELL_PMC(cell) = value;
+ }
+
+ VTABLE INTVAL get_integer_keyed_str(STRING *key) {
+ Hash *hash = get_hash(interp, SELF);
+
+ if (hash) {
+ void *k = hash_key_from_string(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (cell)
+ return autobox_intval(interp, cell);
+ }
+
+ return 0;
+ }
+
+ VTABLE FLOATVAL get_number_keyed_str(STRING *key) {
+ Hash *hash = get_hash(interp, SELF);
+
+ if (hash) {
+ void *k = hash_key_from_string(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (cell)
+ return autobox_floatval(interp, cell);
+ }
+
+ return 0.0;
+ }
+
+
+ VTABLE STRING * get_string_keyed_str(STRING *key) {
+ Hash *hash = get_hash(interp, SELF);
+
+ if (hash) {
+ void *k = hash_key_from_string(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (cell)
+ return autobox_string(interp, cell);
+ }
+
+ return NULL;
+ }
+
+ VTABLE PMC * get_pmc_keyed_str(STRING *key) {
+ Hash *hash = get_hash(interp, SELF);
+
+ if (hash) {
+ void *k = hash_key_from_string(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (cell)
+ return autobox_pmc(interp, cell);
+ }
+
+ return PMCNULL;
+ }
+
+ VTABLE INTVAL get_integer_keyed(PMC *key) {
+ Hash *hash = get_hash(interp, SELF);
+
+ if (hash) {
+ void *k = hash_key_from_pmc(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (cell)
+ return autobox_intval(interp, cell);
+ }
+
+ return 0;
+ }
+
+ VTABLE FLOATVAL get_number_keyed(PMC *key) {
+ Hash *hash = get_hash(interp, SELF);
+
+ if (hash) {
+ void *k = hash_key_from_pmc(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (cell)
+ return autobox_floatval(interp, cell);
+ }
+
+ return 0.0;
+ }
+
+ VTABLE STRING * get_string_keyed(PMC *key) {
+ Hash *hash = get_hash(interp, SELF);
+
+ if (hash) {
+ void *k = hash_key_from_pmc(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (cell)
+ return autobox_string(interp, cell);
+ }
+
+ return NULL;
+ }
+
+ VTABLE PMC * get_pmc_keyed(PMC *key) {
+ Hash *hash = get_hash(interp, SELF);
+
+ if (hash) {
+ void *k = hash_key_from_pmc(interp, hash, key);
+ Pcc_cell *cell = (Pcc_cell *)parrot_hash_get(interp, hash, k);
+
+ if (cell)
+ return autobox_pmc(interp, cell);
+ }
+
+ return PMCNULL;
+ }
+
+ VTABLE INTVAL exists_keyed(PMC *key) {
+ Hash *hash = get_hash(interp, SELF);
+
+ if (hash) {
+ void *k = hash_key_from_pmc(interp, hash, key);
+ return parrot_hash_exists(interp, hash, k);
+ }
+
+ return 0;
+ }
+
+ VTABLE INTVAL exists_keyed_str(STRING *key) {
+ Hash *hash = get_hash(interp, SELF);
+
+ if (hash) {
+ void *k = hash_key_from_string(interp, hash, key);
+ return parrot_hash_exists(interp, hash, k);
+ }
+
+ return 0;
+ }
+
+ VTABLE INTVAL exists_keyed_int(INTVAL key) {
+ Parrot_CallSignature_attributes * const attrs = PARROT_CALLSIGNATURE(SELF);
+
+ if (attrs->num_positionals)
+ return key < attrs->num_positionals;
+
+ return 0;
+ }
/*
Modified: trunk/src/pmc/capture.pmc
==============================================================================
--- trunk/src/pmc/capture.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/capture.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -18,7 +18,6 @@
*/
-#define CAPTURE_DATA_SIZE 2
#define CAPTURE_array_CREATE(i, obj) \
if (!PARROT_CAPTURE(obj)->array) \
PARROT_CAPTURE(obj)->array = pmc_new((i), enum_class_ResizablePMCArray);
@@ -29,7 +28,6 @@
pmclass Capture auto_attrs {
ATTR PMC *array;
ATTR PMC *hash;
- ATTR INTVAL data_size;
/*
@@ -42,9 +40,6 @@
*/
VTABLE void init() {
- Parrot_Capture_attributes *capture =
- (Parrot_Capture_attributes *) PMC_data(SELF);
- capture->data_size = CAPTURE_DATA_SIZE;
PObj_custom_mark_SET(SELF);
}
@@ -417,6 +412,90 @@
/*
+=item C<void set_number_keyed_str(STRING *key, FLOATVAL value)>
+
+=item C<void set_integer_keyed_str(STRING *key, INTVAL value)>
+
+=item C<void set_pmc_keyed_str(STRING *key, PMC *value)>
+
+=item C<void set_string_keyed_str(STRING *key, STRING *value)>
+
+Sets a value in the hash component of the Capture.
+
+=cut
+
+*/
+
+ VTABLE void set_number_keyed_str(STRING *key, FLOATVAL value) {
+ CAPTURE_hash_CREATE(INTERP, SELF);
+ VTABLE_set_number_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash,
+ key, value);
+ }
+
+ VTABLE void set_integer_keyed_str(STRING *key, INTVAL value) {
+ CAPTURE_hash_CREATE(INTERP, SELF);
+ VTABLE_set_integer_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash,
+ key, value);
+ }
+
+ VTABLE void set_pmc_keyed_str(STRING *key, PMC *value) {
+ CAPTURE_hash_CREATE(INTERP, SELF);
+ VTABLE_set_pmc_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash,
+ key, value);
+ }
+
+ VTABLE void set_string_keyed_str(STRING *key, STRING *value) {
+ CAPTURE_hash_CREATE(INTERP, SELF);
+ VTABLE_set_string_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash,
+ key, value);
+ }
+
+/*
+
+=item C<FLOATVAL get_number_keyed_str(STRING *key)>
+
+=item C<INTVAL get_integer_keyed_str(STRING *key)>
+
+=item C<PMC *get_pmc_keyed_str(STRING *key)>
+
+=item C<STRING *get_string_keyed_str(STRING *key)>
+
+Retrieves a value in the hash component of the Capture.
+
+=cut
+
+*/
+
+ VTABLE FLOATVAL get_number_keyed_str(STRING *key) {
+ if (!(PARROT_CAPTURE(SELF)->hash))
+ return 0.0;
+ return VTABLE_get_number_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash,
+ key);
+ }
+
+ VTABLE INTVAL get_integer_keyed_str(STRING *key) {
+ if (!(PARROT_CAPTURE(SELF)->hash))
+ return 0;
+ return VTABLE_get_integer_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash,
+ key);
+ }
+
+ VTABLE PMC *get_pmc_keyed_str(STRING *key) {
+ if (!(PARROT_CAPTURE(SELF)->hash))
+ return PMCNULL;
+ return VTABLE_get_pmc_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash,
+ key);
+ }
+
+ VTABLE STRING *get_string_keyed_str(STRING *key) {
+ if (!(PARROT_CAPTURE(SELF)->hash))
+ return CONST_STRING(INTERP, "");
+ return VTABLE_get_string_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash,
+ key);
+ }
+
+/*
+
=item C<INTVAL defined_keyed(PMC *key)>
Return true if element C<key> of the hash component is defined.
@@ -450,6 +529,39 @@
/*
+=item C<INTVAL defined_keyed_str(STRING *key)>
+
+Return true if element C<key> of the hash component is defined.
+
+=item C<INTVAL exists_keyed_str(STRING *key)>
+
+Return true if element C<key> of the hash component exists.
+
+=item C<void delete_keyed_str(STRING *key)>
+
+Delete the element corresponding to C<key> in the hash component.
+
+=cut
+
+*/
+
+ VTABLE INTVAL defined_keyed_str(STRING *key) {
+ if (!PARROT_CAPTURE(SELF)->hash) return 0;
+ return VTABLE_defined_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, key);
+ }
+
+ VTABLE INTVAL exists_keyed_str(STRING *key) {
+ if (!PARROT_CAPTURE(SELF)->hash) return 0;
+ return VTABLE_exists_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, key);
+ }
+
+ VTABLE void delete_keyed_str(STRING *key) {
+ if (PARROT_CAPTURE(SELF)->hash)
+ VTABLE_delete_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, key);
+ }
+
+/*
+
=item C<void set_pmc(PMC *capture)>
Set this capture to hold the value of another. If set to PMCNULL,
@@ -500,14 +612,11 @@
*/
VTABLE void mark() {
- PMC ** const data = PMC_data_typed(SELF, PMC **);
- INTVAL i;
-
+ Parrot_Capture_attributes * const data = PARROT_CAPTURE(SELF);
if (!data)
return;
-
- for (i = PARROT_CAPTURE(SELF)->data_size - 1; i >= 0; --i)
- Parrot_gc_mark_PMC_alive(interp, data[i]);
+ Parrot_gc_mark_PMC_alive(INTERP, data->array);
+ Parrot_gc_mark_PMC_alive(INTERP, data->hash);
}
/*
Modified: trunk/src/pmc/class.pmc
==============================================================================
--- trunk/src/pmc/class.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/class.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -344,11 +344,14 @@
if (!PMC_IS_NULL(meth)) {
/* build an empty signature; it has an invocant but no args/retvals */
PMC * const sig_obj = pmc_new(interp, enum_class_CallSignature);
+ /* preserve current_object */
+ PMC * const old_object = interp->current_object;
VTABLE_set_string_native(interp, sig_obj, CONST_STRING(interp, "Pi->"));
/* add the invocant */
VTABLE_unshift_pmc(interp, sig_obj, object);
+ interp->current_object = object;
Parrot_pcc_invoke_from_sig_object(interp, meth, sig_obj);
- gc_unregister_pmc(interp, sig_obj);
+ interp->current_object = old_object;
}
}
}
@@ -375,7 +378,8 @@
meth = Parrot_oo_find_vtable_override_for_class(interp, parent, name);
if (!PMC_IS_NULL(meth))
- Parrot_run_meth_fromc_args(interp, meth, object, name, "vP", init);
+ Parrot_pcc_invoke_sub_from_c_args(interp, meth,
+ "PiP->", object, init);
}
}
Modified: trunk/src/pmc/context.pmc
==============================================================================
--- trunk/src/pmc/context.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/context.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -69,6 +69,7 @@
Parrot_gc_mark_PMC_alive(INTERP, ctx->current_object);
Parrot_gc_mark_PMC_alive(INTERP, ctx->current_namespace);
Parrot_gc_mark_PMC_alive(INTERP, ctx->results_signature);
+ Parrot_gc_mark_PMC_alive(INTERP, ctx->current_sig);
if (!ctx->n_regs_used)
return;
Modified: trunk/src/pmc/continuation.pmc
==============================================================================
--- trunk/src/pmc/continuation.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/continuation.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -48,10 +48,9 @@
ATTR PackFile_ByteCode *seg; /* bytecode segment */
ATTR opcode_t *address; /* start of bytecode, addr to continue */
ATTR PMC *to_ctx; /* pointer to dest context */
+ ATTR PMC *to_call_object; /* pointer to CallSignature */
/* a Continuation keeps the from_ctx alive */
ATTR PMC *from_ctx; /* sub, this cont is returning from */
- ATTR opcode_t *current_results; /* ptr into code with get_results opcode
- full continuation only */
ATTR int runloop_id; /* id of the creating runloop. */
ATTR int invoked; /* flag when a handler has been invoked. */
/*
@@ -67,12 +66,12 @@
VTABLE void init() {
Parrot_Continuation_attributes * const attrs = PARROT_CONTINUATION(SELF);
- attrs->to_ctx = CURRENT_CONTEXT(interp);
- attrs->from_ctx = CURRENT_CONTEXT(interp);
- attrs->runloop_id = 0;
- attrs->seg = interp->code;
- attrs->address = NULL;
- attrs->current_results = Parrot_pcc_get_results(interp, attrs->to_ctx);
+ attrs->to_ctx = CURRENT_CONTEXT(interp);
+ attrs->to_call_object = Parrot_pcc_get_signature(INTERP, attrs->to_ctx);
+ attrs->from_ctx = CURRENT_CONTEXT(interp);
+ attrs->runloop_id = 0;
+ attrs->seg = interp->code;
+ attrs->address = NULL;
PObj_custom_mark_SET(SELF);
@@ -91,12 +90,12 @@
Parrot_Continuation_attributes * const attrs = PARROT_CONTINUATION(SELF);
Parrot_Continuation_attributes * const theirs = PARROT_CONTINUATION(values);
- attrs->to_ctx = theirs->to_ctx;
- attrs->from_ctx = CURRENT_CONTEXT(interp);
- attrs->runloop_id = 0;
- attrs->seg = theirs->seg;
- attrs->address = theirs->address;
- attrs->current_results = Parrot_pcc_get_results(interp, attrs->to_ctx);
+ attrs->to_ctx = theirs->to_ctx;
+ attrs->to_call_object = Parrot_pcc_get_signature(INTERP, attrs->to_ctx);
+ attrs->from_ctx = CURRENT_CONTEXT(interp);
+ attrs->runloop_id = 0;
+ attrs->seg = theirs->seg;
+ attrs->address = theirs->address;
PObj_custom_mark_SET(SELF);
@@ -130,6 +129,7 @@
return;
Parrot_gc_mark_PMC_alive(INTERP, cc->to_ctx);
+ Parrot_gc_mark_PMC_alive(INTERP, cc->to_call_object);
Parrot_gc_mark_PMC_alive(INTERP, cc->from_ctx);
}
@@ -182,13 +182,6 @@
cc->address = pos;
cc->runloop_id = INTERP->current_runloop_id;
-
- cc->current_results = (cc->seg
- && (pos >= cc->seg->base.data)
- && (pos < (cc->seg->base.data + cc->seg->base.size)
- && (*pos == PARROT_OP_get_results_pc))) ?
- pos :
- (opcode_t *)NULL;
}
/*
@@ -241,36 +234,30 @@
PMC *from_ctx = CURRENT_CONTEXT(interp);
PMC *to_ctx = cc->to_ctx;
opcode_t *pc = cc->address;
+ PMC *call_obj = cc->to_call_object;
+ PMC *from_obj = Parrot_pcc_get_signature(interp, from_ctx);
UNUSED(next)
Parrot_continuation_check(interp, SELF);
Parrot_continuation_rewind_environment(interp, SELF);
- /* pass args to where caller wants result */
- if (cc->current_results)
- Parrot_pcc_set_results(interp, to_ctx, cc->current_results);
-
- if (Parrot_pcc_get_results(interp, to_ctx) && INTERP->current_args) {
- /*
- * the register pointer is already switched back
- * to the caller, therefore the registers of the
- * sub we are returning from aren't marked, if
- * inside argument passing a GC run is triggered
- * therefore we have to block GC
- */
- opcode_t *src_indexes = interp->current_args;
- opcode_t *dest_indexes = Parrot_pcc_get_results(interp, to_ctx);
- interp->current_args = NULL;
-
- Parrot_block_GC_mark(INTERP);
- parrot_pass_args(INTERP, from_ctx, to_ctx,
- src_indexes, dest_indexes, PARROT_PASS_PARAMS);
- Parrot_unblock_GC_mark(INTERP);
+ if (!PMC_IS_NULL(from_obj)) {
+ STRING *string_sig = VTABLE_get_string(INTERP, from_obj);
+ /* If there is no string - there is no args */
+ if (string_sig) {
+ PMC *raw_sig, *invalid_sig;
+ Parrot_pcc_parse_signature_string(INTERP, string_sig, &raw_sig, &invalid_sig);
+
+ /* Build results signature for continuation */
+ if (*pc == PARROT_OP_get_results_pc)
+ call_obj = Parrot_pcc_build_sig_object_returns_from_op(INTERP, call_obj,
+ Parrot_pcc_get_pmc_constant(INTERP, to_ctx, pc[1]), pc);
+
+ Parrot_pcc_fill_returns_from_continuation(interp, call_obj, raw_sig, from_obj);
+ }
}
/* switch segment */
- INTERP->current_args = NULL;
-
if (INTERP->code != cc->seg)
Parrot_switch_to_cs(INTERP, cc->seg, 1);
Modified: trunk/src/pmc/cpointer.pmc
==============================================================================
--- trunk/src/pmc/cpointer.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/cpointer.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -85,19 +85,6 @@
void *pointer;
GET_ATTR_pointer(INTERP, SELF, pointer);
Parrot_gc_mark_STRING_alive(interp, sig);
-
- if (pointer) {
- if (Parrot_str_equal(interp, sig, CONST_STRING(interp, "P"))) {
- PMC ** const pmc_pointer = (PMC **) pointer;
- PARROT_ASSERT(*pmc_pointer);
- Parrot_gc_mark_PMC_alive(interp, *pmc_pointer);
- }
- else if (Parrot_str_equal(interp, sig, CONST_STRING(interp, "S"))) {
- STRING ** const str_pointer = (STRING **) pointer;
- PARROT_ASSERT(*str_pointer);
- Parrot_gc_mark_STRING_alive(interp, *str_pointer);
- }
- }
}
}
@@ -205,16 +192,25 @@
Parrot_CPointer_attributes * const data = PARROT_CPOINTER(SELF);
if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "I"))) {
- const INTVAL * const int_pointer = (INTVAL *) data->pointer;
+ INTVAL * const int_pointer = (INTVAL *) data->pointer;
return *int_pointer;
}
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "N"))) {
+ FLOATVAL * const num_pointer = (FLOATVAL *) data->pointer;
+ return (INTVAL)*num_pointer;
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "S"))) {
+ STRING ** const str_pointer = (STRING **) data->pointer;
+ return Parrot_str_to_int(INTERP, *str_pointer);
+ }
else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "P"))) {
PMC ** const pmc_pointer = (PMC **) data->pointer;
- return VTABLE_get_integer(interp, *pmc_pointer);
+ return VTABLE_get_integer(INTERP, *pmc_pointer);
+ }
+ else {
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Unable to fetch value, broken signature!");
}
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "Unable to fetch integer value, the pointer is not an integer");
-
}
/*
@@ -235,13 +231,21 @@
INTVAL * const int_pointer = (INTVAL *) data->pointer;
*int_pointer = value;
}
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "N"))) {
+ FLOATVAL * const num_pointer = (FLOATVAL *) data->pointer;
+ *num_pointer = value;
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "S"))) {
+ STRING ** const str_pointer = (STRING **) data->pointer;
+ *str_pointer = Parrot_str_from_int(INTERP, value);
+ }
else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "P"))) {
PMC ** const pmc_pointer = (PMC **) data->pointer;
- VTABLE_set_integer_native(interp, *pmc_pointer, value);
+ *pmc_pointer = get_integer_pmc(INTERP, value);
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "Unable to set integer value, the pointer is not an integer");
+ "Unable to set value, broken signature!");
}
}
@@ -259,16 +263,26 @@
VTABLE FLOATVAL get_number() {
Parrot_CPointer_attributes * const data = PARROT_CPOINTER(SELF);
- if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "N"))) {
- const FLOATVAL * const num_pointer = (FLOATVAL *) data->pointer;
+ if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "I"))) {
+ INTVAL * const int_pointer = (INTVAL *) data->pointer;
+ return (FLOATVAL)*int_pointer;
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "N"))) {
+ FLOATVAL * const num_pointer = (FLOATVAL *) data->pointer;
return *num_pointer;
}
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "S"))) {
+ STRING ** const str_pointer = (STRING **) data->pointer;
+ return Parrot_str_to_num(INTERP, *str_pointer);
+ }
else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "P"))) {
PMC ** const pmc_pointer = (PMC **) data->pointer;
- return VTABLE_get_number(interp, *pmc_pointer);
+ return VTABLE_get_number(INTERP, *pmc_pointer);
+ }
+ else {
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Unable to fetch value, broken signature!");
}
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "Unable to fetch number value, the pointer is not a number");
}
/*
@@ -285,17 +299,25 @@
VTABLE void set_number_native(FLOATVAL value) {
Parrot_CPointer_attributes * const data = PARROT_CPOINTER(SELF);
- if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "N"))) {
+ if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "I"))) {
+ INTVAL * const int_pointer = (INTVAL *) data->pointer;
+ *int_pointer = (INTVAL)value;
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "N"))) {
FLOATVAL * const num_pointer = (FLOATVAL *) data->pointer;
*num_pointer = value;
}
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "S"))) {
+ STRING ** const str_pointer = (STRING **) data->pointer;
+ *str_pointer = Parrot_str_from_num(INTERP, value);
+ }
else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "P"))) {
PMC ** const pmc_pointer = (PMC **) data->pointer;
- VTABLE_set_number_native(interp, *pmc_pointer, value);
+ *pmc_pointer = get_number_pmc(INTERP, value);
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "Unable to set number value, the pointer is not a number");
+ "Unable to set value, broken signature!");
}
}
@@ -313,16 +335,26 @@
VTABLE STRING *get_string() {
Parrot_CPointer_attributes * const data = PARROT_CPOINTER(SELF);
- if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "S"))) {
+ if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "I"))) {
+ INTVAL * const int_pointer = (INTVAL *) data->pointer;
+ return Parrot_str_from_int(INTERP, *int_pointer);
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "N"))) {
+ FLOATVAL * const num_pointer = (FLOATVAL *) data->pointer;
+ return Parrot_str_from_num(INTERP, *num_pointer);
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "S"))) {
STRING ** const str_pointer = (STRING **) data->pointer;
return *str_pointer;
}
else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "P"))) {
PMC ** const pmc_pointer = (PMC **) data->pointer;
- return VTABLE_get_string(interp, *pmc_pointer);
+ return VTABLE_get_string(INTERP, *pmc_pointer);
+ }
+ else {
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Unable to fetch value, broken signature!");
}
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "Unable to fetch string value, the pointer is not a string");
}
/*
@@ -339,17 +371,25 @@
VTABLE void set_string_native(STRING *value) {
Parrot_CPointer_attributes * const data = PARROT_CPOINTER(SELF);
- if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "S"))) {
+ if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "I"))) {
+ INTVAL * const int_pointer = (INTVAL *) data->pointer;
+ *int_pointer = Parrot_str_to_int(INTERP, value);
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "N"))) {
+ FLOATVAL * const num_pointer = (FLOATVAL *) data->pointer;
+ *num_pointer = Parrot_str_to_num(INTERP, value);
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "S"))) {
STRING ** const str_pointer = (STRING **) data->pointer;
*str_pointer = value;
}
else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "P"))) {
PMC ** const pmc_pointer = (PMC **) data->pointer;
- VTABLE_set_string_native(interp, *pmc_pointer, value);
+ *pmc_pointer = get_string_pmc(INTERP, value);
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "Unable to set string value, the pointer is not a string");
+ "Unable to set value, broken signature!");
}
}
@@ -366,12 +406,26 @@
VTABLE PMC *get_pmc() {
const Parrot_CPointer_attributes * const data = PARROT_CPOINTER(SELF);
- if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "P"))) {
+ if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "I"))) {
+ INTVAL * const int_pointer = (INTVAL *) data->pointer;
+ return get_integer_pmc(INTERP, *int_pointer);
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "N"))) {
+ FLOATVAL * const num_pointer = (FLOATVAL *) data->pointer;
+ return get_number_pmc(INTERP, *num_pointer);
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "S"))) {
+ STRING ** const str_pointer = (STRING **) data->pointer;
+ return get_string_pmc(INTERP, *str_pointer);
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "P"))) {
PMC ** const pmc_pointer = (PMC **) data->pointer;
return *pmc_pointer;
}
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "Unable to fetch PMC value, the pointer is not a PMC");
+ else {
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Unable to fetch value, broken signature!");
+ }
}
/*
@@ -387,13 +441,25 @@
VTABLE void set_pmc(PMC *value) {
const Parrot_CPointer_attributes * const data = PARROT_CPOINTER(SELF);
- if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "P"))) {
+ if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "I"))) {
+ INTVAL * const int_pointer = (INTVAL *) data->pointer;
+ *int_pointer = VTABLE_get_integer(INTERP, value);
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "N"))) {
+ FLOATVAL * const num_pointer = (FLOATVAL *) data->pointer;
+ *num_pointer = VTABLE_get_number(INTERP, value);
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "S"))) {
+ STRING ** const str_pointer = (STRING **) data->pointer;
+ *str_pointer = VTABLE_get_string(INTERP, value);
+ }
+ else if (Parrot_str_equal(interp, data->sig, CONST_STRING(interp, "P"))) {
PMC ** const pmc_pointer = (PMC **) data->pointer;
*pmc_pointer = value;
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
- "Unable to set PMC value, the pointer is not a PMC");
+ "Unable to set value, broken signature!");
}
}
Modified: trunk/src/pmc/exception.pmc
==============================================================================
--- trunk/src/pmc/exception.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/exception.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -731,7 +731,7 @@
*/
METHOD backtrace() {
- PMC *result = pmc_new(interp, enum_class_ResizablePMCArray);
+ PMC *result = PMCNULL;
PMC *resume;
PMC *cur_ctx;
Parrot_Continuation_attributes *cont;
Modified: trunk/src/pmc/multisub.pmc
==============================================================================
--- trunk/src/pmc/multisub.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/multisub.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -57,7 +57,9 @@
}
VTABLE opcode_t *invoke(void *next) {
- PMC * const func = Parrot_mmd_sort_manhattan(interp, SELF);
+ PMC * const sig_obj = CONTEXT(interp)->current_sig;
+ PMC * const func = Parrot_mmd_sort_manhattan_by_sig_pmc(interp,
+ SELF, sig_obj);
if (PMC_IS_NULL(func))
Parrot_ex_throw_from_c_args(INTERP, NULL, 1, "No applicable methods.\n");
@@ -66,10 +68,13 @@
}
VTABLE PMC *get_iter() {
- PMC * const sub = Parrot_mmd_sort_manhattan(INTERP, SELF);
+ PMC * const sig_obj = CONTEXT(interp)->current_sig;
+ PMC * const sub = Parrot_mmd_sort_manhattan_by_sig_pmc(interp,
+ SELF, sig_obj);
if (PMC_IS_NULL(sub))
Parrot_ex_throw_from_c_args(INTERP, NULL, 1, "No applicable methods.\n");
+
return SUPER();
}
@@ -78,14 +83,20 @@
ResizablePMCArray's VTABLE methods of the same names. Hopefully we
don't need anything beyond that. */
VTABLE PMC *get_pmc_keyed(PMC *key) {
- PMC * const sub = Parrot_mmd_sort_manhattan(INTERP, SELF);
+ PMC * const sig_obj = CONTEXT(interp)->current_sig;
+ PMC * const sub = Parrot_mmd_sort_manhattan_by_sig_pmc(interp,
+ SELF, sig_obj);
+
if (PMC_IS_NULL(sub))
Parrot_ex_throw_from_c_args(INTERP, NULL, 1, "No applicable methods.\n");
return SUPER(key);
}
VTABLE PMC *get_pmc_keyed_str(STRING *s) {
- PMC * const sub = Parrot_mmd_sort_manhattan(INTERP, SELF);
+ PMC * const sig_obj = CONTEXT(interp)->current_sig;
+ PMC * const sub = Parrot_mmd_sort_manhattan_by_sig_pmc(interp,
+ SELF, sig_obj);
+
if (PMC_IS_NULL(sub))
Parrot_ex_throw_from_c_args(INTERP, NULL, 1, "No applicable methods.\n");
return SUPER(s);
Modified: trunk/src/pmc/nci.pmc
==============================================================================
--- trunk/src/pmc/nci.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/nci.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -72,8 +72,8 @@
case (INTVAL)'@':
param_sig[j++] = '@';
break;
- case (INTVAL)'b': /* buffer (void*) pass PObj_bufstart(SReg) */
- case (INTVAL)'B': /* buffer (void**) pass &PObj_bufstart(SReg) */
+ case (INTVAL)'b': /* buffer (void*) pass Buffer_bufstart(SReg) */
+ case (INTVAL)'B': /* buffer (void**) pass &Buffer_bufstart(SReg) */
param_sig[j++] = 'S';
break;
default:
Modified: trunk/src/pmc/object.pmc
==============================================================================
--- trunk/src/pmc/object.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/object.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -171,8 +171,12 @@
/* If there's a vtable override for 'name' run that instead. */
PMC * const method = Parrot_oo_find_vtable_override(interp, _class, name);
- if (!PMC_IS_NULL(method))
- return (STRING *)Parrot_run_meth_fromc_args(interp, method, SELF, name, "S");
+ if (!PMC_IS_NULL(method)) {
+ STRING *result = NULL;
+ Parrot_pcc_invoke_sub_from_c_args(interp, method, "Pi->S",
+ SELF, &result);
+ return result;
+ }
else
return VTABLE_get_string(interp, _class);
}
@@ -214,9 +218,12 @@
PMC * const method = Parrot_oo_find_vtable_override(interp,
VTABLE_get_class(interp, SELF), get_attr);
- if (!PMC_IS_NULL(method))
- return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF,
- get_attr, "PS", name);
+ if (!PMC_IS_NULL(method)) {
+ PMC *result = PMCNULL;
+ Parrot_pcc_invoke_sub_from_c_args(interp, method, "PiS->P",
+ SELF, name, &result);
+ return result;
+ }
/* Look up the index. */
index = get_attrib_index(interp, obj->_class, name);
@@ -273,9 +280,8 @@
PMC * const method = Parrot_oo_find_vtable_override(interp,
VTABLE_get_class(interp, SELF), vtable_meth_name);
if (!PMC_IS_NULL(method)) {
- PMC *unused = (PMC *)Parrot_run_meth_fromc_args(interp, method,
- SELF, vtable_meth_name, "vSP", name, value);
- UNUSED(unused);
+ Parrot_pcc_invoke_sub_from_c_args(interp, method, "PiSP->",
+ SELF, name, value);
return;
}
@@ -345,9 +351,12 @@
method = Parrot_oo_find_vtable_override_for_class(interp, cur_class,
find_method);
- if (!PMC_IS_NULL(method))
- return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF,
- find_method, "PS", name);
+ if (!PMC_IS_NULL(method)) {
+ PMC *result = PMCNULL;
+ Parrot_pcc_invoke_sub_from_c_args(interp, method,
+ "PiS->P", SELF, name, &result);
+ return result;
+ }
/* If it's from this universe or the class doesn't inherit from
* anything outside of it... */
@@ -391,9 +400,8 @@
cur_class, meth_name);
if (!PMC_IS_NULL(meth)) {
INTVAL result;
- Parrot_pcc_invoke_sub_from_c_args(interp, meth, "P->I", pmc, &result);
+ Parrot_pcc_invoke_sub_from_c_args(interp, meth, "Pi->I", pmc, &result);
return result;
-/* return (INTVAL)Parrot_run_meth_fromc_args_reti(interp, meth, pmc, meth_name, "I"); */
}
/* method name is get_integer */
@@ -427,9 +435,12 @@
PMC * const method = Parrot_oo_find_vtable_override(interp,
classobj, get_class);
- if (!PMC_IS_NULL(method))
- return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF,
- get_class, "P");
+ if (!PMC_IS_NULL(method)) {
+ PMC *result;
+ Parrot_pcc_invoke_sub_from_c_args(interp, method, "Pi->P",
+ SELF, &result);
+ return result;
+ }
return classobj;
}
@@ -451,9 +462,12 @@
PMC * const method = Parrot_oo_find_vtable_override(interp,
classobj, get_namespace);
- if (!PMC_IS_NULL(method))
- return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF,
- get_namespace, "P");
+ if (!PMC_IS_NULL(method)) {
+ PMC *result;
+ Parrot_pcc_invoke_sub_from_c_args(interp, method, "Pi->P",
+ SELF, &result);
+ return result;
+ }
else
return VTABLE_inspect_str(interp, classobj, CONST_STRING(interp, "namespace"));
@@ -537,9 +551,13 @@
PMC * const method = Parrot_oo_find_vtable_override(interp,
classobj, meth_name);
- if (!PMC_IS_NULL(method)
- && Parrot_run_meth_fromc_args_reti(interp, method, SELF, meth_name, "IS", role_name))
- return 1;
+ if (!PMC_IS_NULL(method)) {
+ INTVAL result;
+ Parrot_pcc_invoke_sub_from_c_args(interp, method,
+ "PiS->I", SELF, role_name, &result);
+ if (result)
+ return 1;
+ }
}
/* Check the superclass's vtable interface, if any. */
if (SUPER(role_name))
@@ -646,8 +664,12 @@
STRING * const meth_name = CONST_STRING(interp, "clone");
PMC * const meth =
Parrot_oo_find_vtable_override(interp, obj->_class, meth_name);
- if (!PMC_IS_NULL(meth))
- return (PMC*)Parrot_run_meth_fromc_args(interp, meth, pmc, meth_name, "P");
+ if (!PMC_IS_NULL(meth)) {
+ PMC *result;
+ Parrot_pcc_invoke_sub_from_c_args(interp, meth, "Pi->P",
+ pmc, &result);
+ return result;
+ }
else
return Parrot_oo_clone_object(interp, SELF, obj->_class, NULL);
}
@@ -793,7 +815,8 @@
classobj, meth_name);
if (!PMC_IS_NULL(method))
- Parrot_run_meth_fromc_args(interp, method, SELF, meth_name, "vP", type);
+ Parrot_pcc_invoke_sub_from_c_args(interp, method, "PiP->",
+ SELF, type);
else
SUPER(type);
}
Modified: trunk/src/pmc/parrotinterpreter.pmc
==============================================================================
--- trunk/src/pmc/parrotinterpreter.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/parrotinterpreter.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -143,7 +143,7 @@
if (flags & PARROT_CLONE_GLOBALS)
pt_clone_globals(d, s);
- Parrot_unblock_GC_sweep(d);
+ Parrot_unblock_GC_mark(d);
}
Modified: trunk/src/pmc/retcontinuation.pmc
==============================================================================
--- trunk/src/pmc/retcontinuation.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/retcontinuation.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -42,9 +42,7 @@
attrs->from_ctx = CURRENT_CONTEXT(interp); /* filled in during a call */
attrs->runloop_id = 0;
attrs->seg = interp->code;
- attrs->current_results = NULL;
attrs->address = NULL;
-
}
Modified: trunk/src/pmc/role.pmc
==============================================================================
--- trunk/src/pmc/role.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/role.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -724,7 +724,8 @@
PMC *alias_method :optional :named("alias_method"),
int got_alias_method :opt_flag) {
Parrot_Role_attributes *role_info = PARROT_ROLE(SELF);
- STRING *s_name, *r_name;
+ STRING *s_name = NULL;
+ STRING *r_name = NULL;
(STRING *s_name) = PCCINVOKE(interp, SELF, "name");
(STRING *r_name) = PCCINVOKE(interp, role, "name");
Modified: trunk/src/pmc/sub.pmc
==============================================================================
--- trunk/src/pmc/sub.pmc Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/pmc/sub.pmc Wed Oct 21 16:54:18 2009 (r41972)
@@ -387,6 +387,7 @@
context = Parrot_set_new_context(INTERP, sub->n_regs_used);
Parrot_pcc_set_sub(interp, context, SELF);
Parrot_pcc_set_continuation(interp, context, ccont);
+ Parrot_pcc_set_constants(interp, context, sub->seg->const_table->constants);
/* check recursion/call depth */
if (Parrot_pcc_inc_recursion_depth(INTERP, context) > INTERP->recursion_limit)
@@ -1053,7 +1054,7 @@
METHOD set_outer(PMC *outer) {
/* Set outer sub. */
Parrot_Sub_attributes *sub;
- PMC *tmp1, *tmp2;
+ PMC *tmp1;
PMC_get_sub(INTERP, SELF, sub);
sub->outer_sub = outer;
@@ -1070,16 +1071,14 @@
/* If we've got a context around for the outer sub, set it as the
* outer context. */
-
- /* XXX This code looks very suspicious. */
- /* (CONTEXT(interp)->caller_ctx->caller_ctx->current_sub */
- tmp1 = Parrot_pcc_get_caller_ctx(interp, CURRENT_CONTEXT(interp));
- tmp2 = Parrot_pcc_get_caller_ctx(interp, tmp1);
- if (Parrot_pcc_get_sub(interp, tmp2) == outer)
- sub->outer_ctx = tmp2;
- /* else if (CONTEXT(interp)->caller_ctx->current_sub == outer) */
- else if (Parrot_pcc_get_sub(interp, tmp1) == outer)
- sub->outer_ctx = tmp1;
+ tmp1 = CURRENT_CONTEXT(interp);
+ while (!PMC_IS_NULL(tmp1)) {
+ if (Parrot_pcc_get_sub(interp, tmp1) == outer) {
+ sub->outer_ctx = tmp1;
+ break;
+ }
+ tmp1 = Parrot_pcc_get_caller_ctx(interp, tmp1);
+ }
}
METHOD get_multisig() {
Modified: trunk/src/scheduler.c
==============================================================================
--- trunk/src/scheduler.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/scheduler.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -140,8 +140,8 @@
PMC * const handler = Parrot_cx_find_handler_for_task(interp, task);
if (!PMC_IS_NULL(handler)) {
PMC * const handler_sub = VTABLE_get_attr_str(interp, handler, CONST_STRING(interp, "code"));
- Parrot_runops_fromc_args_event(interp, handler_sub,
- "vPP", handler, task);
+ Parrot_pcc_invoke_sub_from_c_args(interp, handler_sub,
+ "PP->", handler, task);
}
}
else {
@@ -952,8 +952,8 @@
Parrot_floatval_time());
#endif
if (!PMC_IS_NULL(timer_struct->codeblock)) {
- Parrot_runops_fromc_args_event(interp,
- timer_struct->codeblock, "v");
+ Parrot_pcc_invoke_sub_from_c_args(interp,
+ timer_struct->codeblock, "->");
}
}
Modified: trunk/src/sub.c
==============================================================================
--- trunk/src/sub.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/sub.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -138,12 +138,6 @@
* the running program.
*/
PMC * const saved_ccont = interp->current_cont;
- opcode_t * const current_args = interp->current_args;
- opcode_t * const current_params = interp->current_params;
- opcode_t * const current_returns = interp->current_returns;
- PMC * const args_signature = interp->args_signature;
- PMC * const params_signature = interp->params_signature;
- PMC * const returns_signature = interp->returns_signature;
Parrot_block_GC_mark(interp);
@@ -151,12 +145,6 @@
/* Restore stuff that might have got overwritten */
interp->current_cont = saved_ccont;
- interp->current_args = current_args;
- interp->current_params = current_params;
- interp->current_returns = current_returns;
- interp->args_signature = args_signature;
- interp->params_signature = params_signature;
- interp->returns_signature = returns_signature;
if (sub->name)
VTABLE_push_string(interp, ns_array, sub->name);
Modified: trunk/src/thread.c
==============================================================================
--- trunk/src/thread.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/thread.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -501,7 +501,7 @@
PMC * volatile sub_pmc;
PMC *sub_arg;
PMC * const self = (PMC*) arg;
- PMC *ret_val = NULL;
+ PMC *ret_val = PMCNULL;
Parrot_Interp interp =
(Parrot_Interp)((Parrot_ParrotInterpreter_attributes *)PMC_data(self))->interp;
@@ -524,15 +524,13 @@
VTABLE_get_string(interp, exception),
VTABLE_get_integer_keyed_str(interp, exception,
Parrot_str_new_constant(interp, "type"))); */
-
- ret_val = PMCNULL;
}
else {
/* run normally */
Parrot_ex_add_c_handler(interp, &jump_point);
Parrot_unblock_GC_mark(interp);
Parrot_unblock_GC_sweep(interp);
- ret_val = Parrot_runops_fromc_args(interp, sub_pmc, "PF", sub_arg);
+ Parrot_pcc_invoke_sub_from_c_args(interp, sub_pmc, "Pf->P", sub_arg, &ret_val);
}
/* thread is finito */
Modified: trunk/src/utils.c
==============================================================================
--- trunk/src/utils.c Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/src/utils.c Wed Oct 21 16:54:18 2009 (r41972)
@@ -906,6 +906,7 @@
COMPARE(PARROT_INTERP, ARGIN(void *a), ARGIN(void *b), ARGIN(PMC *cmp))
{
ASSERT_ARGS(COMPARE)
+ INTVAL result = 0;
if (PMC_IS_NULL(cmp))
return VTABLE_cmp(interp, (PMC *)a, (PMC *)b);
@@ -914,7 +915,8 @@
return f(interp, a, b);
}
- return Parrot_runops_fromc_args_reti(interp, cmp, "IPP", a, b);
+ Parrot_pcc_invoke_sub_from_c_args(interp, cmp, "PP->I", a, b, &result);
+ return result;
}
/*
Modified: trunk/t/codingstd/c_function_docs.t
==============================================================================
--- trunk/t/codingstd/c_function_docs.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/codingstd/c_function_docs.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -71,7 +71,12 @@
$missing = 'missing';
}
if ($missing) {
- push @missing_docs, "$path ($missing)\n$function_decl\nWant:\n$escaped_decl\n";
+ if ($missing eq 'boilerplate only') {
+ push @missing_docs, "$path ($missing)\nIn:\n$escaped_decl\n";
+ }
+ else {
+ push @missing_docs, "$path ($missing)\n$function_decl\nWant:\n$escaped_decl\n";
+ }
}
}
Modified: trunk/t/codingstd/c_parens.t
==============================================================================
--- trunk/t/codingstd/c_parens.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/codingstd/c_parens.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -90,7 +90,8 @@
my @lines = split( /\n/, $buf );
for my $line (@lines) {
- next if $line =~ m{#\s*define}; # skip #defines
+ # skip #defines and typedefs
+ next if $line =~ m{(?:(#\s*define|^\s*typedef))};
if ( $line =~ m{ ( (?<!\w) (?:$keywords) (?: \( | \ \s+ \( ) ) }xo ) {
my $paren = $1;
Modified: trunk/t/oo/metamodel.t
==============================================================================
--- trunk/t/oo/metamodel.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/oo/metamodel.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -92,6 +92,11 @@
.end
+.sub fail
+ .param string desc
+ 'ok'(0, desc)
+.end
+
.namespace['Dog']
.sub _accessor :method
Modified: trunk/t/op/annotate.t
==============================================================================
--- trunk/t/op/annotate.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/op/annotate.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -36,8 +36,8 @@
failed:
.local pmc exception
- .get_results (exception)
pop_eh
+ .get_results (exception)
$P0 = exception.'annotations'()
isa_ok ($P0, 'Hash', 'annotations gives back hash')
$I0 = elements $P0
@@ -59,8 +59,8 @@
failed:
.local pmc exception
- .get_results (exception)
pop_eh
+ .get_results (exception)
$P0 = exception.'annotations'('file')
is ($P0, 'foo.p6', "file annotation got OK")
@@ -108,8 +108,8 @@
failed:
.local pmc exception, bt, frame, ann
- .get_results (exception)
pop_eh
+ .get_results (exception)
bt = exception.'backtrace'()
$I0 = elements bt
$I0 = $I0 > 3
Modified: trunk/t/op/calling.t
==============================================================================
--- trunk/t/op/calling.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/op/calling.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -7,7 +7,7 @@
use lib qw( . lib ../lib ../../lib );
use Test::More;
-use Parrot::Test tests => 94;
+use Parrot::Test tests => 95;
=head1 NAME
@@ -447,7 +447,7 @@
print $P0
.end
CODE
-/too few arguments passed/
+/too few positional arguments/
OUTPUT
pir_output_like(
@@ -478,7 +478,7 @@
print "nada"
.end
CODE
-/too many arguments passed/
+/too many positional arguments/
OUTPUT
pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many" );
@@ -496,7 +496,7 @@
print $P0
.end
CODE
-/too many arguments passed/
+/too many positional arguments/
OUTPUT
pir_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many - catch exception" );
@@ -524,7 +524,7 @@
# print $S1
.end
CODE
-/^caught: too many arguments passed/
+/^caught: too many positional arguments/
OUTPUT
pir_output_is( <<'CODE', <<'OUTPUT', "argc mismatch, optional" );
@@ -571,7 +571,7 @@
.param int got_k :opt_flag
.end
CODE
-/too many arguments passed/
+/too many positional arguments/
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "get_param later" );
@@ -1210,7 +1210,7 @@
$P35 = _fn1(1, $P34 :flat)
.end
CODE
-/too many arguments passed \(5\) - 4 params expected/
+/too many positional arguments: 5 passed, 4 expected/
OUTPUT
pir_error_output_like( <<'CODE', <<'OUTPUT', "too few args via :flat" );
@@ -1242,7 +1242,7 @@
$P35 = _fn1(1, $P34 :flat)
.end
CODE
-/too few arguments passed \(3\) - 4 params expected/
+/too few positional arguments: 3 passed, 4 \(or more\) expected/
OUTPUT
pir_output_is( <<'CODE', <<'OUTPUT', "tailcall to NCI" );
@@ -1751,6 +1751,36 @@
ok
OUTPUT
+pir_output_is( <<'CODE', <<'OUTPUT', "named - 3 slurpy hash PIR" );
+.sub main :main
+ foo('a' => 10 , 'b' => 20, 'c' => 30)
+ print "ok\n"
+ end
+.end
+.sub foo
+ .param int a :named('a')
+ .param pmc bar :slurpy :named
+ print a
+ print ' '
+ elements $I1, bar
+ print $I1
+ print ' '
+ typeof $S0, bar
+ print $S0
+ print ' '
+ set $I2, bar['b']
+ print $I2
+ print ' '
+ set $I2, bar['c']
+ print $I2
+ print "\n"
+.end
+
+CODE
+10 2 Hash 20 30
+ok
+OUTPUT
+
pasm_output_is( <<'CODE', <<'OUTPUT', "named - 3 slurpy hash" );
.pcc_sub main:
set_args "0x200, 0, 0x200, 0,0x200, 0", "a", 10, "b", 20, 'c', 30
@@ -1954,7 +1984,7 @@
.param int b
.end
CODE
-/many named arguments/
+/too few positional/
OUTPUT
pir_output_is( <<'CODE', <<'OUTPUT', "named optional - set" );
@@ -2088,7 +2118,7 @@
1120
OUTPUT
-pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch - missing named" );
+pir_error_output_like( <<'CODE', qr/too few named arguments/, "argc mismatch - missing named" );
.sub main :main
.include "errors.pasm"
errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
@@ -2105,10 +2135,8 @@
print "\n"
.end
CODE
-/too few arguments/
-OUTPUT
-pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch - missing named" );
+pir_error_output_like( <<'CODE', qr/too few named arguments/, "argc mismatch - missing named" );
.sub main :main
.include "errors.pasm"
errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
@@ -2125,8 +2153,6 @@
print "\n"
.end
CODE
-/too few arguments/
-OUTPUT
pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch - too many named" );
.sub main :main
@@ -2261,7 +2287,7 @@
.param pmc args :slurpy :named
.end
CODE
-/positional inside named args at position 2/
+/too many positional arguments/
OUTPUT
pir_error_output_like( <<'CODE', <<'OUTPUT', "unexpected positional arg" );
@@ -2274,7 +2300,7 @@
.param pmc args :slurpy :named
.end
CODE
-/positional inside named args at position 3/
+/named arguments must follow all positional arguments/
OUTPUT
pir_output_is( <<'CODE', <<'OUTPUT', "RT #40490 - flat/slurpy named arguments" );
Modified: trunk/t/op/cc_params.t
==============================================================================
--- trunk/t/op/cc_params.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/op/cc_params.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -184,7 +184,7 @@
$self->{CHECK_RESULTS} =
( ( $c_args == $c_params ) and ( $c_results == $c_returns ) )
? 'ok'
- : 'too (many|few) arguments passed .*';
+ : 'too (many|few) ((positional|named) (arguments|returns)).*';
}
sub initialize {
Modified: trunk/t/op/cc_state.t
==============================================================================
--- trunk/t/op/cc_state.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/op/cc_state.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -53,7 +53,7 @@
## G
pcc_error_like(
{ params => ".param pmc abc" },
- '/too few arguments passed \(0\) - 1 param expected/',
+ '/too few positional arguments: 0 passed, 1 \(or more\) expected/',
'G1: argument underflow: required param',
);
@@ -71,13 +71,13 @@
pcc_error_like(
{ params => ".param pmc abc :named('x')" },
- '/too few arguments passed - missing required named arg \'x\'/',
+ '/too few named arguments: no argument for required parameter \'x\'/',
'G5: argument underflow: named required param',
);
pcc_error_like(
{ params => ".param pmc abc :named('x') :slurpy" },
- '/too few arguments passed - missing required named arg \'x\'/',
+ '/too few named arguments: no argument for required parameter \'x\'/',
'G6: argument underflow: named required slurpy param',
);
Modified: trunk/t/op/gc.t
==============================================================================
--- trunk/t/op/gc.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/op/gc.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -50,7 +50,7 @@
sweep 1
$I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
$I3 = $I2 - $I1
- is($I3,1)
+ is($I3,1, "sweep_1")
.end
@@ -59,7 +59,7 @@
sweep 0
$I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be same
$I3 = $I2 - $I1
- is($I3,0)
+ is($I3,0, "sweep_0")
.end
@@ -71,7 +71,7 @@
sweep 0
$I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
$I3 = $I2 - $I1
- is($I3,1)
+ is($I3,1, "sweep_0_need_destroy_obj")
.end
@@ -87,8 +87,8 @@
sweep 0
$I4 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be same as last
$I5 = $I4 - $I2
- is($I3,1)
- is($I5,0)
+ is($I3,1, "sweep_0_need_destroy_destroy_obj")
+ is($I5,0, "sweep_0_need_destroy_destroy_obj")
.end
@@ -97,7 +97,7 @@
collect
$I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS # Should be one more now
$I3 = $I2 - $I1
- is($I3,1)
+ is($I3,1, "collect_count")
.end
@@ -107,13 +107,13 @@
collect
$I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
$I3 = $I2 - $I1
- is($I3,0)
+ is($I3,0, "collect_toggle")
collecton
collect
$I4 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
$I6 = $I4 - $I2
- is($I6,1)
+ is($I6,1, "collect_toggle")
.end
@@ -125,13 +125,13 @@
collect # This shouldn't do anything... #'
$I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
$I3 = $I2 - $I1
- is($I3,0)
+ is($I3,0, "collect_toggle_nested")
collecton
collect # ... but this should
$I4 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
$I6 = $I4 - $I2
- is($I6,1)
+ is($I6,1, "collect_toggle_nested")
.end
@@ -152,7 +152,7 @@
.sub _rand
$P16 = new 'Env'
$P5 = $P16['Foo']
- is($P5, 'bar')
+ is($P5, 'bar', "_rand")
if $P5 != 'bar' goto err
.return()
err:
@@ -192,7 +192,7 @@
.local pmc o, cl
cl = newclass 'Foo'
o = new 'Foo'
- ok(1)
+ ok(1, "end vanishing_return_continuation")
.end
# END: vanishing_return_continuation
@@ -252,8 +252,8 @@
$P1 = new 'Integer'
$P1 = 0
n = $P0."b11"($P1)
- ok(1)
- is(n,8)
+ ok(1, "recursion_and_exceptions")
+ is(n,8, "recursion_and_exceptions")
.end
.namespace ["b"]
.sub b11 :method
@@ -321,7 +321,7 @@
lt $I0, $I1, lp2
inc $I2
lt $I2, $I3, lp3
- ok(1)
+ ok(1, "leaving write_barrier_1")
.end
@@ -376,7 +376,7 @@
lt $I0, $I1, lp2
inc $I2
lt $I2, $I3, lp3
- ok(1)
+ ok(1, "leaving write_barrier_2")
.end
@@ -427,16 +427,16 @@
a = new 'String'
b = new 'String'
$I0 = elements reg
- is($I0, 0)
+ is($I0, 0, "addr_registry_2_int")
reg[a] = nil
$I0 = elements reg
- is($I0, 1)
+ is($I0, 1, "addr_registry_2_int")
reg[a] = nil
$I0 = elements reg
- is($I0, 1)
+ is($I0, 1, "addr_registry_2_int")
reg[b] = nil
$I0 = elements reg
- is($I0, 2)
+ is($I0, 2, "addr_registry_2_int")
.end
Modified: trunk/t/pmc/callsignature.t
==============================================================================
--- trunk/t/pmc/callsignature.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/callsignature.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -1,5 +1,5 @@
#! parrot
-# Copyright (C) 2006-2008, Parrot Foundation.
+# Copyright (C) 2006-2009, Parrot Foundation.
# $Id$
=head1 NAME
@@ -16,20 +16,273 @@
=cut
-.sub main :main
+.sub 'main' :main
.include 'test_more.pir'
- plan(1)
+ plan(65)
- instantiate()
+ test_instantiate()
+ test_get_set_attrs()
+ test_push_pop_indexed_access()
+ test_shift_unshift_indexed_access()
+ test_indexed_access()
+ test_indexed_boxing()
+ test_keyed_access()
+ test_exists()
.end
-
-.sub instantiate
-
+.sub 'test_instantiate'
$P0 = new ['CallSignature']
ok(1, 'Instantiated CallSignature')
+.end
+
+.sub 'test_get_set_attrs'
+ $P0 = new ['CallSignature']
+ $P5 = new 'String'
+
+ $P5 = 'foobar'
+ setattribute $P0, 'returns', $P5
+ ok(1, 'set returns attribute')
+ getattribute $P1, $P0, 'returns'
+ is($P1,'foobar', 'got returns attribute')
+
+ $P5 = 'moonbomb'
+ setattribute $P0, 'return_flags', $P5
+ ok(1, 'set return_flags attribute')
+ getattribute $P1, $P0, 'return_flags'
+ is($P5,'moonbomb', 'got return_flags attribute')
+
+ $P5 = 'cheese'
+ setattribute $P0, 'arg_flags', $P5
+ ok(1, 'set arg_flags attribute')
+ getattribute $P1, $P0, 'arg_flags'
+ is($P5,'cheese', 'got arg_flags attribute')
+.end
+
+.sub 'test_push_pop_indexed_access'
+ $P0 = new [ 'CallSignature' ]
+ $P1 = new [ 'Integer' ]
+ $P1 = 100
+
+ push $P0, $P1
+ $I0 = elements $P0
+ is( $I0, 1, 'elements after push' )
+
+ $P2 = $P0[0]
+ is( $P2, 100, 'push_pmc/get_pmc_keyed_int pair' )
+ $P2 = pop $P0
+ is( $P2, 100, 'push_pmc/pop_pmc pair' )
+
+ $I0 = elements $P0
+ is( $I0, 0, 'elements after pop' )
+
+ push $P0, 200
+ $I0 = $P0[0]
+ is( $I0, 200, 'push_integer/get_integer_keyed_int pair' )
+ $I0 = pop $P0
+ is( $I0, 200, 'push_integer/pop_integer pair' )
+
+ push $P0, 3.03
+ $N0 = $P0[0]
+ is( $N0, 3.03, 'push_number/get_number_keyed_int pair' )
+ $N0 = pop $P0
+ is( $N0, 3.03, 'push_number/pop_number pair' )
+
+ push $P0, 'hello'
+ $S0 = $P0[0]
+ is( $S0, 'hello', 'push_string/get_string_keyed_int pair' )
+ $S0 = pop $P0
+ is( $S0, 'hello', 'push_string/pop_string pair' )
+
+ $I0 = elements $P0
+ is( $I0, 0, 'elements after push/pop' )
+.end
+
+.sub 'test_shift_unshift_indexed_access'
+ $P0 = new [ 'CallSignature' ]
+ $P1 = new [ 'Integer' ]
+ $P1 = 100
+
+ unshift $P0, $P1
+
+ $I0 = elements $P0
+ is( $I0, 1, 'elements after unshift' )
+
+ $P2 = $P0[0]
+ is( $P2, 100, 'unshift_pmc/get_pmc_keyed_int pair' )
+ $P2 = shift $P0
+ is( $P2, 100, 'unshift_pmc/shift_pmc pair' )
+
+ $I0 = elements $P0
+ is( $I0, 0, 'elements after unshift/shift' )
+
+ unshift $P0, 200
+ $I0 = $P0[0]
+ is( $I0, 200, 'unshift_integer/get_integer_keyed_int pair' )
+ $I0 = shift $P0
+ is( $I0, 200, 'unshift_integer/shift_integer pair' )
+
+ unshift $P0, 3.03
+ $N0 = $P0[0]
+ is( $N0, 3.03, 'unshift_number/get_number_keyed_int pair' )
+ $N0 = shift $P0
+ is( $N0, 3.03, 'unshift_number/shift_number pair' )
+
+ unshift $P0, 'hello'
+ $S0 = $P0[0]
+ is( $S0, 'hello', 'unshift_string/get_string_keyed_int pair' )
+ $S0 = shift $P0
+ is( $S0, 'hello', 'unshift_string/shift_string pair' )
+
+ $I0 = elements $P0
+ is( $I0, 0, 'elements after unshift/shift' )
+.end
+
+.sub 'test_indexed_access'
+ $P0 = new [ 'CallSignature' ]
+ $P0[0] = 100
+
+ $I0 = elements $P0
+ is( $I0, 1, 'elements after set_*_indexed' )
+
+ $P0[1] = 1.11
+
+ $I0 = elements $P0
+ is( $I0, 2, 'elements after set_*_indexed' )
+
+ $S0 = '2.22'
+ $P0[2] = $S0
+
+ $I0 = elements $P0
+ is( $I0, 3, 'elements after set_*_indexed' )
+
+ $P1 = new [ 'Float' ]
+ $P1 = 3.33
+ $P0[3] = $P1
+
+ $I0 = elements $P0
+ is( $I0, 4, 'elements after set_*_indexed' )
+
+ $I1 = $P0[0]
+ is( $I1, 100, 'set_integer_keyed_int/get_integer_keyed_int pair' )
+
+ $N1 = $P0[1]
+ is( $N1, 1.11, 'set_number_keyed_int/get_number_keyed_int pair' )
+
+ $S1 = $P0[2]
+ is( $S1, '2.22', 'set_string_keyed_int/get_string_keyed_int pair' )
+
+ $P1 = $P0[3]
+ is( $P1, 3.33, 'set_pmc_keyed_int/get_pmc_keyed_int pair' )
+
+ $I1 = shift $P0
+ is( $I1, 100, 'set_integer_keyed_int/shift_integer pair' )
+
+ $N1 = $P0[0]
+ is( $N1, 1.11, 'shift_* should remove elements from array' )
+
+ $N1 = shift $P0
+ is( $N1, 1.11, 'set_number_keyed_int/shift_number pair' )
+
+ $S1 = $P0[0]
+ is( $S1, '2.22', 'shift_* should remove elements from array' )
+
+ $S1 = shift $P0
+ is( $S1, '2.22', 'set_string_keyed_int/shift_string pair' )
+
+ $P1 = $P0[0]
+ is( $P1, 3.33, 'shift_* should remove elements from array' )
+
+ $P1 = shift $P0
+ is( $P1, 3.33, 'set_pmc_keyed_int/shift_pmc pair' )
+.end
+
+.sub 'test_indexed_boxing'
+ $P0 = new [ 'CallSignature' ]
+ $P0[0] = 100
+ $P0[1] = 1.11
+
+ $S0 = '2.22'
+ $P0[2] = $S0
+
+ $P1 = new [ 'Float' ]
+ $P1 = 3.33
+ $P0[3] = $P1
+
+ $I0 = $P0[1]
+ is( $I0, 1, 'indexed float converted to int on get_integer_keyed_int' )
+ $I0 = $P0[2]
+ is( $I0, 2, 'indexed string converted to int on get_integer_keyed_int' )
+ $I0 = $P0[3]
+ is( $I0, 3, 'indexed PMC converted to int on get_integer_keyed_int' )
+
+ $N0 = $P0[0]
+ is( $N0, 100.0, 'indexed integer converted to num on get_number_keyed_int' )
+ $N0 = $P0[2]
+ is( $N0, 2.22, 'indexed string converted to num on get_number_keyed_int' )
+ $N0 = $P0[3]
+ is( $N0, 3.33, 'indexed PMC converted to int num get_number_keyed_int' )
+
+ $S0 = $P0[0]
+ is( $S0, '100', 'indexed int converted to string on get_string_keyed_int' )
+ $S0 = $P0[1]
+ is( $S0, '1.11', 'indexed num converted to string on get_string_keyed_int' )
+ $S0 = $P0[3]
+ is( $S0, '3.33', 'indexed PMC converted to string get_string_keyed_int' )
+
+ $P1 = $P0[0]
+ is( $P1, 100, 'indexed int converted to PMC on get_pmc_keyed_int' )
+ $P1 = $P0[1]
+ is( $P1, 1.11, 'indexed float converted to PMC on get_pmc_keyed_int' )
+ $P1 = $P0[2]
+ is( $P1, 2.22, 'indexed string converted to PMC on get_pmc_keyed_int' )
+.end
+
+.sub 'test_keyed_access'
+ $P0 = new [ 'CallSignature' ]
+
+ $P0['foo'] = 100
+ $P0['bar'] = 1.11
+ $P0['baz'] = '2.22'
+ $P1 = new [ 'Float' ]
+ $P1 = 3.33
+
+ $P0['qux'] = $P1
+
+ $I0 = $P0['foo']
+ is( $I0, 100, 'set/get_intval_keyed_str' )
+
+ $N0 = $P0['bar']
+ is( $N0, 1.11, 'set/get_number_keyed_str' )
+
+ $S0 = $P0['baz']
+ is( $S0, '2.22', 'set/get_string_keyed_str' )
+
+ $P2 = $P0['qux']
+ is( $P2, 3.33, 'set/get_pmc_keyed_str' )
+
+ $P1 = getattribute $P0, 'named'
+ $I0 = elements $P1
+ is( $I0, 4, 'elements after set_*_keyed' )
+.end
+
+.sub 'test_exists'
+ $P0 = new [ 'CallSignature' ]
+
+ $P0[0] = 111
+ $P0['foo'] = 100
+
+ $I0 = exists $P0[0]
+ ok( $I0, 'exists_keyed_int' )
+
+ $I0 = exists $P0['foo']
+ ok( $I0, 'exists_keyed_str' )
+
+ $I0 = exists $P0[100]
+ nok( $I0, 'exists_keyed_int -- non-existant' )
+ $I0 = exists $P0['bar']
+ nok( $I0, 'exists_keyed_str -- non-existant' )
.end
# Local Variables:
Modified: trunk/t/pmc/capture.t
==============================================================================
--- trunk/t/pmc/capture.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/capture.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -226,6 +226,7 @@
.return ()
test_get_integer_catch:
+ pop_eh
.local pmc exception
.local string message
.get_results (exception)
Modified: trunk/t/pmc/fixedbooleanarray.t
==============================================================================
--- trunk/t/pmc/fixedbooleanarray.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/fixedbooleanarray.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -62,9 +62,8 @@
.return()
resizing_not_allowed_handler:
- .get_results($P0)
- $S0 = $P0
- like($S0, ":s FixedBooleanArray\\: Can\\'t resize\\!", 'Resetting array size (and getting an exception)')
+ pop_eh
+ ok(1, 'resizing does not work on a fixed-size array')
.end
.sub 'setting_first_element'
@@ -112,9 +111,8 @@
.return()
setting_out_of_bounds_handler:
- .get_results($P0)
- $S0 = $P0
- like($S0, ":s FixedBooleanArray\\: index out of bounds\\!", "Setting out-of-bounds elements")
+ pop_eh
+ ok(1, "Setting out-of-bounds element did not succeed")
.end
.sub 'getting_out_of_bounds'
@@ -128,9 +126,8 @@
.return()
getting_out_of_bounds_handler:
- .get_results($P0)
- $S0 = $P0
- like($S0, ":s FixedBooleanArray\\: index out of bounds\\!", "Getting out-of-bounds elements")
+ pop_eh
+ ok(1, "Getting out-of-bounds element does not succeed")
.end
.sub 'set_pmc_access_int'
Modified: trunk/t/pmc/fixedpmcarray.t
==============================================================================
--- trunk/t/pmc/fixedpmcarray.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/fixedpmcarray.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -310,7 +310,7 @@
concat s, aux
aux = get_repr_fpa_n(3)
concat s, aux
- like(s,'\(\)\(0\)\(0\,\s*1\)\(0\,\s*1\,\s*2\)','get_repr')
+ substring(s,'()(0)(0, 1)(0, 1, 2)','get_repr')
.end
.sub get_repr_fpa_n
@@ -333,7 +333,7 @@
.end
.sub test_splice_oob
- throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds','splice oob, offset 0')
+ throws_substring(<<'CODE','FixedPMCArray: index out of bounds','splice oob, offset 0')
.sub main
.local pmc fpa
fpa = new ['FixedPMCArray']
@@ -345,7 +345,7 @@
splice fpa, nil, 0, 6
.end
CODE
- throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds','splice oob, big offset')
+ throws_substring(<<'CODE','FixedPMCArray: index out of bounds','splice oob, big offset')
.sub main
.local pmc fpa
fpa = new ['FixedPMCArray']
@@ -390,7 +390,7 @@
.end
.sub test_get_uninitialized
- throws_like(<<'CODE',':s Null PMC access in name','get uninitialized')
+ throws_substring(<<'CODE','Null PMC access in name','get uninitialized')
.sub main
.local pmc arr1
arr1 = new ['FixedPMCArray']
@@ -469,14 +469,14 @@
.end
.sub test_oob_elem
- throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds\!','set out-of-bounds index')
+ throws_substring(<<'CODE','FixedPMCArray: index out of bounds!','set out-of-bounds index')
.sub main
new $P0, ['FixedPMCArray']
set $P0, 1
set $P0[1], -7
.end
CODE
- throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds\!','set out-of-bounds index')
+ throws_substring(<<'CODE','FixedPMCArray: index out of bounds!','set out-of-bounds index')
.sub main
new $P0, ['FixedPMCArray']
set $P0, 1
@@ -487,14 +487,14 @@
.end
.sub test_negative_index
- throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds\!','set negative index')
+ throws_substring(<<'CODE','FixedPMCArray: index out of bounds!','set negative index')
.sub main
new $P0, ['FixedPMCArray']
set $P0, 1
set $P0[-1], -7
.end
CODE
- throws_like(<<'CODE',':s FixedPMCArray\: index out of bounds\!','get negative index')
+ throws_substring(<<'CODE','FixedPMCArray: index out of bounds!','get negative index')
.sub main
new $P0, ['FixedPMCArray']
set $P0, 1
@@ -547,7 +547,7 @@
.end
.sub test_tt991
- throws_like(<<'CODE',':s FixedPMCArray\: Cannot set array size to a negative number','cannot create a negative length array')
+ throws_substring(<<'CODE','FixedPMCArray: Cannot set array size to a negative number','cannot create a negative length array')
.sub main
new $P0, ['FixedPMCArray']
set $P0, -1
@@ -556,7 +556,7 @@
.end
.sub test_resize_exception
- throws_like(<<'CODE',':s FixedPMCArray\: Can.t resize','cannot resize FixedPMCArray')
+ throws_substring(<<'CODE',"FixedPMCArray: Can't resize",'cannot resize FixedPMCArray')
.sub main
new $P0, ['FixedPMCArray']
set $I0,$P0
@@ -565,14 +565,14 @@
.end
CODE
- throws_like(<<'CODE',":s set_number_native.* not implemented in class .*FixedPMCArray", 'cannot use float as length to FixedPMCArray')
+ throws_substring(<<'CODE',"set_number_native() not implemented in class 'FixedPMCArray'", 'cannot use float as length to FixedPMCArray')
.sub main
new $P0, ['FixedPMCArray']
set $P0, 42.0
.end
CODE
- throws_like(<<'CODE',":s set_string_native.* not implemented in class .*FixedPMCArray", 'cannot use string as length to FixedPMCArray')
+ throws_substring(<<'CODE',"set_string_native() not implemented in class 'FixedPMCArray'", 'cannot use string as length to FixedPMCArray')
.sub main
new $P0, ['FixedPMCArray']
set $P0,"GIGO"
@@ -581,7 +581,7 @@
.end
.sub test_assign_non_array
- throws_like(<<'CODE', ':s Can.t set self from this type','assign from non-array')
+ throws_substring(<<'CODE', "Can't set self from this type",'assign from non-array')
.sub main
.local pmc arr, other
.local int n
Modified: trunk/t/pmc/fixedstringarray.t
==============================================================================
--- trunk/t/pmc/fixedstringarray.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/fixedstringarray.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -110,6 +110,7 @@
$I0 = 0
handle_set:
ok($I0, "Can't set out-of-bounds element")
+ pop_eh
$I0 = 1
push_eh handle_set_negative
@@ -117,6 +118,7 @@
$I0 = 0
handle_set_negative:
ok($I0, "Can't set element on negative index")
+ pop_eh
$I0 = 1
push_eh handle_get
@@ -124,6 +126,7 @@
$I0 = 0
handle_get:
ok($I0, "Can't get out-of-bounds element")
+ pop_eh
$I0 = 1
push_eh handle_get_negative
@@ -131,6 +134,7 @@
$I0 = 0
handle_get_negative:
ok($I0, "Can't get element with negative index")
+ pop_eh
.end
@@ -172,7 +176,7 @@
$P0[1023] = $P1
$P2 = new ['Key']
-
+
$P2 = 25
$I0 = $P0[$P2]
is($I0, 125, "Get INTVAL via Key works")
@@ -235,7 +239,7 @@
clone_1:
pop_eh
ok($I0, "Resize of uninitialized clone successful")
-
+
$I1 = 1
push_eh clone_2
$P2 = clone $P0
@@ -243,6 +247,7 @@
$I0 = 0
clone_2:
ok($I0, "Resize of initialization not successful")
+ pop_eh
.end
@@ -336,7 +341,7 @@
i = iseq a1, other
is(i, 0, "Not equal to other type")
-
+
a1 = 3
isnt(a1, a2, "Different size arrays aren't equal")
@@ -349,7 +354,7 @@
a1[1] = "bar"
a2[1] = "BAR"
isnt(a1, a2, "Not equal when second element differ")
-
+
a2[1] = "bar"
is(a1, a2, "Equal when second element same")
Modified: trunk/t/pmc/float.t
==============================================================================
--- trunk/t/pmc/float.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/float.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -168,10 +168,7 @@
.return ()
divide_by_zero_handler:
- .get_results ($P1)
- $S1 = $P1
- say $S1
- like($S1, ':s division by zero', 'divide by zero')
+ ok(1, "divide by zero throws exception")
.end
.sub 'truth_positive_float'
@@ -346,11 +343,12 @@
neg $P0
$S0 = $P0
- like($S0, '^\-0', 'negative zero')
+ is($S0, "-0")
.return ()
negative_zero_todoed:
todo(1, '-0.0 not implemented, TT#313')
+ pop_eh
.end
.sub 'equality'
Modified: trunk/t/pmc/integer.t
==============================================================================
--- trunk/t/pmc/integer.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/integer.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -51,7 +51,7 @@
.end
.sub test_get_as_base_bounds_check
- throws_like(<<'CODE', ':s get_as_base\: base out of bounds', 'get_as_base lower bound check')
+ throws_substring(<<'CODE', 'get_as_base: base out of bounds', 'get_as_base lower bound check')
.sub main
$P0 = new ['Integer']
$P0 = 42
@@ -59,7 +59,7 @@
say $S0
.end
CODE
- throws_like(<<'CODE', ':s get_as_base\: base out of bounds', 'get_as_base upper bound check')
+ throws_substring(<<'CODE', 'get_as_base: base out of bounds', 'get_as_base upper bound check')
.sub main
$P0 = new ['Integer']
$P0 = 42
Modified: trunk/t/pmc/multidispatch.t
==============================================================================
--- trunk/t/pmc/multidispatch.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/multidispatch.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -998,7 +998,7 @@
nothing
OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "use a core func for an object", todo => 'RT #59628' );
+pir_output_is( <<'CODE', <<'OUTPUT', "use a core func for an object");
.sub main :main
.local pmc d, l, r, cl
cl = newclass "AInt"
Modified: trunk/t/pmc/namespace.t
==============================================================================
--- trunk/t/pmc/namespace.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/namespace.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -203,7 +203,7 @@
pop_eh
test4:
- throws_like( <<'CODE', 'Null\ PMC\ access\ in\ invoke', 'Invoking a non-existent sub')
+ throws_substring( <<'CODE', 'Null PMC access in invoke', 'Invoking a non-existent sub')
.sub main
$P0 = get_global ["Foo"], "SUB_THAT_DOES_NOT_EXIST"
$P0()
@@ -212,7 +212,7 @@
test5:
# this used to behave differently from the previous case.
- throws_like( <<'CODE', 'Null\ PMC\ access\ in\ invoke', 'Invoking a non-existent sub')
+ throws_substring( <<'CODE', 'Null PMC access in invoke', 'Invoking a non-existent sub')
.sub main
$P0 = get_global ["Foo";"Bar"], "SUB_THAT_DOES_NOT_EXIST"
$P0()
@@ -552,9 +552,9 @@
.sub 'export_to_method'
.local string errormsg, description
- errormsg = ":s destination namespace not specified"
+ errormsg = "destination namespace not specified"
description = "export_to() Null NameSpace"
- throws_like(<<"CODE", errormsg, description)
+ throws_substring(<<"CODE", errormsg, description)
.sub 'test' :main
.local pmc nsa, nsb, ar
@@ -566,9 +566,9 @@
.end
CODE
- errormsg = ":s exporting default object set not yet implemented"
+ errormsg = "exporting default object set not yet implemented"
description = 'export_to() with null exports default object set !!!UNSPECIFIED!!!'
- throws_like(<<'CODE', errormsg, description)
+ throws_substring(<<'CODE', errormsg, description)
.sub 'test' :main
.local pmc nsa, nsb, ar
@@ -580,9 +580,9 @@
CODE
- errormsg = ":s exporting default object set not yet implemented"
+ errormsg = "exporting default object set not yet implemented"
description = 'export_to() with empty array exports default object set !!!UNSPECIFIED!!!'
- throws_like(<<'CODE', errormsg, description)
+ throws_substring(<<'CODE', errormsg, description)
.sub 'test' :main
.local pmc nsa, nsb, ar
@@ -593,9 +593,9 @@
.end
CODE
- errormsg = ":s exporting default object set not yet implemented"
+ errormsg = "exporting default object set not yet implemented"
description = 'export_to() with empty hash exports default object set !!!UNSPECIFIED!!!'
- throws_like(<<'CODE', errormsg, description)
+ throws_substring(<<'CODE', errormsg, description)
.sub 'test' :main
.local pmc nsa, nsb, ar
Modified: trunk/t/pmc/parrotobject.t
==============================================================================
--- trunk/t/pmc/parrotobject.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/parrotobject.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -247,7 +247,7 @@
$P1()
.end
CODE
-/2 params expected/
+/too few positional arguments/
OUT
# '
Modified: trunk/t/pmc/resizablefloatarray.t
==============================================================================
--- trunk/t/pmc/resizablefloatarray.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/resizablefloatarray.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -90,9 +90,8 @@
.return()
negative_size_handler:
- .get_results ($P1)
- $S1 = $P1
- like($S1, ":s ResizableFloatArray\\: Can\\'t resize to negative value\\!", 'setting negative array size')
+ pop_eh
+ ok(1, "cannot set negative array size")
.end
.sub 'setting_first_element'
@@ -331,9 +330,8 @@
.return()
pop_empty_handler:
- .get_results($P0)
- $S0 = $P0
- like($S0, ":s ResizableFloatArray\\: Can\\'t pop from an empty array\\!", 'pop from empty array')
+ pop_eh
+ ok(1, "cannot pop from empty array")
.end
.sub 'shift_empty'
@@ -346,9 +344,8 @@
.return()
shift_empty_handler:
- .get_results($P0)
- $S0 = $P0
- like($S0, ":s ResizableFloatArray\\: Can\\'t shift from an empty array\\!", 'shift from empty array')
+ pop_eh
+ ok(1, "cannot shift from empty array")
.end
.sub 'check_interface'
Modified: trunk/t/pmc/resizablestringarray.t
==============================================================================
--- trunk/t/pmc/resizablestringarray.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/resizablestringarray.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -1374,6 +1374,7 @@
.local pmc exception
.local string message
bad_type:
+ pop_eh
.get_results (exception)
message = exception
still_ok:
Modified: trunk/t/pmc/sub.t
==============================================================================
--- trunk/t/pmc/sub.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/sub.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -648,7 +648,7 @@
.param int op2
.end
CODE
-/too few arguments passed \(1\) - 2 params expected/
+/too few positional arguments: 1 passed, 2 \(or more\) expected/
OUTPUT
pir_error_output_like( <<'CODE', <<'OUTPUT', "explicit :main with wrong # args." );
@@ -657,7 +657,7 @@
.param int op2
.end
CODE
-/too few arguments passed \(1\) - 2 params expected/
+/too few positional arguments: 1 passed, 2 \(or more\) expected/
OUTPUT
($TEMP, $temp_pasm) = create_tempfile(UNLINK => 1);
Modified: trunk/t/pmc/threads.t
==============================================================================
--- trunk/t/pmc/threads.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/pmc/threads.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -1,5 +1,5 @@
#! perl
-# Copyright (C) 2001-2008, Parrot Foundation.
+# Copyright (C) 2001-2009, Parrot Foundation.
# $Id$
use strict;
@@ -168,8 +168,9 @@
.param pmc passed
inc $I5
$S5 = " thread\n"
- passed = 'hello from'
- print passed
+ .local pmc salutation
+ salutation = box 'hello from'
+ print salutation
# print I5 # not done because register initialization is not guaranteed
print $S5
$P0 = getinterp
@@ -686,31 +687,38 @@
push @todo, ( todo => 'Broken with JIT' ) if $ENV{TEST_PROG_ARGS} =~ /--runcore=jit/;
push @todo, ( todo => 'Broken with switch core' ) if $ENV{TEST_PROG_ARGS} =~ /--runcore=switch/;
}
+# Direct constant access to sub objects commented out, see TT #1120.
pir_output_unlike( <<'CODE', qr/not/, "globals + constant table subs issue", @todo );
.namespace [ 'Foo' ]
.include 'interpinfo.pasm'
.sub 'is'
- .param pmc what
- .param pmc expect
+ .param pmc what
+ .param pmc expect
+ .param string desc :optional
+ .param int have_desc :opt_flag
+
+ unless have_desc goto diagnose
+ desc = ' - ' . desc
+
+ diagnose:
.local pmc number
number = get_global 'test_num'
if what == expect goto okay
print "# got: "
- print what
- print "\n"
+ say what
print "# expected: "
- print expect
- print "\nnot ok "
+ say expect
+ print "not ok "
print number
- print "\n"
+ say desc
+ inc number
$P0 = interpinfo .INTERPINFO_CURRENT_CONT
loop:
$I0 = defined $P0
if $I0 == 0 goto done
print " "
- print $P0
- print "\n"
+ say $P0
$P0 = $P0.'continuation'()
branch loop
done:
@@ -719,7 +727,7 @@
print "ok "
print number
inc number
- print "\n"
+ say desc
.end
.sub setup
@@ -729,9 +737,10 @@
.end
.sub _check_sanity
+ .param string desc
$P0 = get_global 'foo'
$P1 = get_hll_global [ 'Foo' ], 'foo'
- is($P0, $P1)
+ is($P0, $P1, desc)
.end
.sub mutate
@@ -741,11 +750,11 @@
.end
.sub check_sanity
- _check_sanity()
+# _check_sanity( 'direct call' )
$P0 = get_global '_check_sanity'
- $P0()
+ $P0( 'call from get_global' )
$P0 = get_hll_global [ 'Foo' ], '_check_sanity'
- $P0()
+ $P0( 'call from get_hll_global' )
.end
.sub _check_value
@@ -756,7 +765,7 @@
.sub check_value
.param int value
- _check_value(value)
+# _check_value(value)
$P0 = get_global '_check_value'
$P0(value)
$P0 = get_hll_global [ 'Foo' ], '_check_value'
@@ -764,10 +773,19 @@
.end
.sub full_check
- .const 'Sub' c_setup = 'setup'
- .const 'Sub' c_sanity = 'check_sanity'
- .const 'Sub' c_mutate = 'mutate'
- .const 'Sub' c_value = 'check_value'
+# .const 'Sub' c_setup = 'setup'
+# .const 'Sub' c_sanity = 'check_sanity'
+# .const 'Sub' c_mutate = 'mutate'
+# .const 'Sub' c_value = 'check_value'
+
+ .local pmc c_setup
+ c_setup = get_global 'setup'
+ .local pmc c_sanity
+ c_sanity = get_global 'check_sanity'
+ .local pmc c_mutate
+ c_mutate = get_global 'mutate'
+ .local pmc c_value
+ c_value = get_global 'check_value'
.local pmc g_setup
g_setup = get_hll_global [ 'Foo' ], 'setup'
Modified: trunk/t/src/extend.t
==============================================================================
--- trunk/t/src/extend.t Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/t/src/extend.t Wed Oct 21 16:54:18 2009 (r41972)
@@ -1,5 +1,5 @@
#!perl
-# Copyright (C) 2001-2008, Parrot Foundation.
+# Copyright (C) 2001-2009, Parrot Foundation.
# $Id$
use strict;
@@ -663,7 +663,7 @@
Hello from foo!
OUTPUT
-c_output_is( <<"CODE", <<'OUTPUT', 'call multi sub from C - #41511', todo => 'RT #41511' );
+c_output_is( <<"CODE", <<'OUTPUT', 'call multi sub from C - #41511' );
#include <parrot/parrot.h>
#include <parrot/embed.h>
#include <parrot/extend.h>
@@ -685,7 +685,7 @@
Parrot_pbc_load( interp, pf );
sub = Parrot_find_global_cur( interp, Parrot_str_new_constant( interp, "add" ) );
- result = Parrot_call_sub( interp, sub, "III", 100, 200 );
+ result = Parrot_call_sub_ret_int( interp, sub, "III", 100, 200 );
printf( "Result is %d.\\n", result );
Parrot_exit(interp, 0);
Modified: trunk/tools/build/nativecall.pl
==============================================================================
--- trunk/tools/build/nativecall.pl Wed Oct 21 16:54:07 2009 (r41971)
+++ trunk/tools/build/nativecall.pl Wed Oct 21 16:54:18 2009 (r41972)
@@ -43,7 +43,7 @@
as_proto => "void *",
other_decl => "PMC * const final_destination = pmc_new(interp, enum_class_UnManagedStruct);",
sig_char => "P",
- ret_assign => "VTABLE_set_pointer(interp, final_destination, return_data); set_nci_P(interp, &st, final_destination);",
+ ret_assign => "VTABLE_set_pointer(interp, final_destination, return_data);\n Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"P\", final_destination);",
},
i => { as_proto => "int", sig_char => "I" },
l => { as_proto => "long", sig_char => "I" },
@@ -53,7 +53,7 @@
d => { as_proto => "double", sig_char => "N" },
t => { as_proto => "char *",
other_decl => "STRING *final_destination;",
- ret_assign => "final_destination = Parrot_str_new(interp, return_data, 0);\n set_nci_S(interp, &st, final_destination);",
+ ret_assign => "final_destination = Parrot_str_new(interp, return_data, 0);\n Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"S\", final_destination);",
sig_char => "S" },
v => { as_proto => "void",
return_type => "void *",
@@ -62,7 +62,7 @@
func_call_assign => ""
},
P => { as_proto => "PMC *", sig_char => "P" },
- O => { as_proto => "PMC *", returns => "", sig_char => "P" },
+ O => { as_proto => "PMC *", returns => "", sig_char => "Pi" },
J => { as_proto => "PARROT_INTERP", returns => "", sig_char => "" },
S => { as_proto => "STRING *", sig_char => "S" },
I => { as_proto => "INTVAL", sig_char => "I" },
@@ -71,15 +71,15 @@
B => { as_proto => "char **", as_return => "", sig_char => "S" },
# These should be replaced by modifiers in the future
2 => { as_proto => "short *", sig_char => "P", return_type => "short",
- ret_assign => "set_nci_I(interp, &st, *return_data);" },
+ ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' },
3 => { as_proto => "int *", sig_char => "P", return_type => "int",
- ret_assign => "set_nci_I(interp, &st, *return_data);" },
+ ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' },
4 => { as_proto => "long *", sig_char => "P", return_type => "long",
- ret_assign => "set_nci_I(interp, &st, *return_data);" },
+ ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' },
L => { as_proto => "long *", as_return => "" },
T => { as_proto => "char **", as_return => "" },
V => { as_proto => "void **", as_return => "", sig_char => "P" },
- '@' => { as_proto => "PMC *", as_return => "", cname => "xAT_", sig_char => '@' },
+ '@' => { as_proto => "PMC *", as_return => "", cname => "xAT_", sig_char => 'Ps' },
);
for (values %sig_table) {
@@ -87,7 +87,8 @@
if (not exists $_->{return_type}) { $_->{return_type} = $_->{as_proto} }
if (not exists $_->{return_type_decl}) { $_->{return_type_decl} = $_->{return_type} }
if (not exists $_->{ret_assign} and exists $_->{sig_char}) {
- $_->{ret_assign} = "set_nci_".$_->{sig_char}."(interp, &st, return_data);";
+ $_->{ret_assign} = 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "'
+ . $_->{sig_char} . '", return_data);';
}
if (not exists $_->{func_call_assign}) {
$_->{func_call_assign} = "return_data = "
@@ -120,6 +121,7 @@
next;
}
+ my @fill_params;
my @extra_preamble;
my @extra_postamble;
my @temps;
@@ -132,8 +134,8 @@
die "Invalid argument signature char '$_' on line $. of $ARGV"
unless exists $sig_table{$_}{sig_char};
push @arg,
- make_arg( $_, $reg_num++, \$temp_cnt, \@temps, \@extra_preamble,
- \@extra_postamble );
+ make_arg( $_, $reg_num++, \$temp_cnt, \@temps, \@fill_params,
+ \@extra_preamble, \@extra_postamble );
$sig .= $sig_table{$_}{sig_char};
$_ eq 'J' && $reg_num--;
}
@@ -148,7 +150,7 @@
$ret_sig->{as_return}, $ret_sig->{return_type_decl},
$ret_sig->{func_call_assign}, $ret_sig->{other_decl},
$ret_sig->{ret_assign}, \@temps,
- \@extra_preamble, \@extra_postamble,
+ \@fill_params, \@extra_preamble, \@extra_postamble,
\@put_pointer_nci_too,
);
}
@@ -159,7 +161,7 @@
$ret_sig->{as_return}, $ret_sig->{return_type_decl},
$ret_sig->{func_call_assign}, $ret_sig->{other_decl},
$ret_sig->{ret_assign}, \@temps,
- \@extra_preamble, \@extra_postamble,
+ \@fill_params, \@extra_preamble, \@extra_postamble,
\@put_pointer,
);
}
@@ -201,7 +203,7 @@
*/
/* nci.c
- * Copyright (C) 2001-2007, Parrot Foundation.
+ * Copyright (C) 2001-2009, Parrot Foundation.
* SVN Info
* \$Id\$
* Overview:
@@ -246,64 +248,85 @@
# we have to fetch all to temps, so that the call code
# can operate in sequence
#
- my ( $argtype, $reg_num, $temp_cnt_ref, $temps_ref, $extra_preamble_ref, $extra_postamble_ref )
+ my ( $argtype, $reg_num, $temp_cnt_ref, $temps_ref, $fill_params_ref, $extra_preamble_ref, $extra_postamble_ref )
= @_;
local $_ = $argtype;
my $temp_num = ${$temp_cnt_ref}++;
/p/ && do {
- push @{$temps_ref}, "void *t_$temp_num;";
- push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_p($reg_num);";
- return "t_$temp_num";
+ push @{$temps_ref}, "PMC *t_$temp_num;";
+ push @{$fill_params_ref}, "&t_$temp_num";
+ return "VTABLE_get_pointer(interp, t_$temp_num)";
};
/V/ && do {
push @{$temps_ref}, "PMC *t_$temp_num;";
push @{$temps_ref}, "void *v_$temp_num;";
- push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_P($reg_num);";
+ push @{$fill_params_ref}, "&t_$temp_num";
push @{$extra_preamble_ref}, "v_$temp_num = VTABLE_get_pointer(interp, t_$temp_num);";
push @{$extra_postamble_ref}, "VTABLE_set_pointer(interp, t_$temp_num, v_$temp_num);";
return "&v_$temp_num";
};
- /[ilIscfdNS]/ && do {
+ /[INS]/ && do {
+ my $ret_type = $sig_table{$_}{return_type};
+ push @{$temps_ref}, "$ret_type t_$temp_num;";
+ push @{$fill_params_ref}, "&t_$temp_num";
+ return "t_$temp_num";
+ };
+ /[ilcs]/ && do {
+ my $ret_type = $sig_table{$_}{return_type};
+ push @{$temps_ref}, "$ret_type t_$temp_num;";
+ push @{$temps_ref}, "INTVAL ti_$temp_num;";
+ push @{$fill_params_ref}, "&ti_$temp_num";
+ push @{$extra_preamble_ref}, "t_$temp_num = ($ret_type)ti_$temp_num;";
+ return "t_$temp_num";
+ };
+ /[fd]/ && do {
my $ret_type = $sig_table{$_}{return_type};
push @{$temps_ref}, "$ret_type t_$temp_num;";
- push @{$extra_preamble_ref}, "t_$temp_num = ($ret_type)GET_NCI_$sig_table{$_}{sig_char}($reg_num);";
+ push @{$temps_ref}, "FLOATVAL tf_$temp_num;";
+ push @{$fill_params_ref}, "&tf_$temp_num";
+ push @{$extra_preamble_ref}, "t_$temp_num = ($ret_type)tf_$temp_num;";
return "t_$temp_num";
};
/[234]/ && do {
my $ret_type = $sig_table{$_}{return_type};
push @{$temps_ref}, "PMC *t_$temp_num;";
push @{$temps_ref}, "$ret_type i_$temp_num;";
- push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_P($reg_num);";
+ push @{$fill_params_ref}, "&t_$temp_num";
push @{$extra_preamble_ref}, "i_$temp_num = ($ret_type) VTABLE_get_integer(interp, t_$temp_num);";
push @{$extra_postamble_ref}, "VTABLE_set_integer_native(interp, t_$temp_num, i_$temp_num);";
return "&i_$temp_num";
};
/t/ && do {
- push @{$temps_ref}, "char *t_$temp_num;";
+ push @{$temps_ref}, "char *t_$temp_num;";
+ push @{$temps_ref}, "STRING *ts_$temp_num;";
+ push @{$fill_params_ref}, "&ts_$temp_num";
push @{$extra_preamble_ref},
- "{STRING * s= GET_NCI_S($reg_num); t_$temp_num = s ? Parrot_str_to_cstring(interp, s) : (char *) NULL;}";
+ "t_$temp_num = ts_$temp_num ? Parrot_str_to_cstring(interp, ts_$temp_num) : (char *) NULL;";
push @{$extra_postamble_ref}, "do { if (t_$temp_num) Parrot_str_free_cstring(t_$temp_num); } while (0);";
return "t_$temp_num";
};
/b/ && do {
push @{$temps_ref}, "STRING *t_$temp_num;";
- push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_S($reg_num);";
+ push @{$fill_params_ref}, "&t_$temp_num";
return "Buffer_bufstart(t_$temp_num)";
};
/B/ && do {
- push @{$temps_ref}, "char *s_$temp_num;\n char *t_$temp_num;\n char** v_$temp_num = &t_$temp_num;";
+ push @{$temps_ref}, "char *t_$temp_num;";
+ push @{$temps_ref}, "char** v_$temp_num = &t_$temp_num;";
+ push @{$temps_ref}, "STRING *ts_$temp_num;";
+ push @{$fill_params_ref}, "&ts_$temp_num";
push @{$extra_preamble_ref},
- "{STRING * s= GET_NCI_S($reg_num); t_$temp_num = s ? Parrot_str_to_cstring(interp, s) : (char *) NULL; s_$temp_num = t_$temp_num;}";
- push @{$extra_postamble_ref}, "do { if (s_$temp_num) Parrot_str_free_cstring(s_$temp_num); } while (0);";
+ "t_$temp_num = ts_$temp_num ? Parrot_str_to_cstring(interp, ts_$temp_num) : (char *) NULL;";
+ push @{$extra_postamble_ref}, "do { if (t_$temp_num) Parrot_str_free_cstring(t_$temp_num); } while (0);";
return "v_$temp_num";
};
/J/ && do {
return "interp";
};
/[OP\@]/ && do {
- push @{$temps_ref}, "PMC *t_$temp_num;";
- push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_P($reg_num);";
+ push @{$temps_ref}, "PMC *t_$temp_num;";
+ push @{$fill_params_ref}, "&t_$temp_num";
return "t_$temp_num";
};
return;
@@ -311,10 +334,10 @@
sub create_function {
my (
- $sig, $return, $params, $args,
- $ret_type, $ret_type_decl, $return_assign, $other_decl,
- $final_assign, $temps_ref, $extra_preamble_ref, $extra_postamble_ref,
- $put_pointer_ref,
+ $sig, $return, $params, $args,
+ $ret_type, $ret_type_decl, $return_assign, $other_decl,
+ $final_assign, $temps_ref, $fill_params_ref, $extra_preamble_ref,
+ $extra_postamble_ref, $put_pointer_ref,
) = @_;
my $func = '';
@@ -322,10 +345,13 @@
$other_decl ||= "";
$other_decl .= join( "\n ", @{$temps_ref} );
- my $call_state = 'call_state st;';
- my $extra_preamble = join( "\n ", @{$extra_preamble_ref} );
- my $extra_postamble = join( "\n ", @{$extra_postamble_ref} );
- my $return_data =
+ my $call_object_decl = <<"CALLOBJECT";
+ PMC *ctx = CURRENT_CONTEXT(interp);
+ PMC *call_object = Parrot_pcc_get_signature(interp, ctx);
+CALLOBJECT
+ my $extra_preamble = join( "\n ", @{$extra_preamble_ref} );
+ my $extra_postamble = join( "\n ", @{$extra_postamble_ref} );
+ my $return_data_decl =
"$return_assign $final_assign" =~ /return_data/
? qq{$ret_type_decl return_data;}
: q{};
@@ -335,6 +361,8 @@
my $proto = join ', ', map { $sig_table{$_}{as_proto} } split( m//, $params );
my $call_params = join( ",", @$args );
+ my $fill_params = join( ", ", @$fill_params_ref );
+ $fill_params = ", " . $fill_params if($fill_params);
$func = <<"HEADER";
static void
@@ -343,10 +371,10 @@
typedef $ret_type (*func_t)($proto);
func_t pointer;
void *orig_func;
- $call_state
- $return_data
+ $call_object_decl
+ $return_data_decl
$other_decl
- Parrot_init_arg_nci(interp, &st, \"$sig\");
+ Parrot_pcc_fill_params_from_c_args(interp, call_object, \"$sig\"$fill_params);
$extra_preamble
GETATTR_NCI_orig_func(interp, self, orig_func);
@@ -360,17 +388,15 @@
else {
# Things are more simple, when there are no params
- # call state var not needed if there are no params and a void return
- $call_state = '' if 'v' eq $return;
$func = <<"HEADER";
static void
pcf_${return}_(PARROT_INTERP, PMC *self)
{
$ret_type (*pointer)(void);
void *orig_func;
- $return_data
+ $return_data_decl
$other_decl
- $call_state
+ $call_object_decl
$extra_preamble
GETATTR_NCI_orig_func(interp, self, orig_func);
More information about the parrot-commits
mailing list