2 Copyright (C) 2001-2010, Parrot Foundation.
7 src/sub.c - Subroutines
11 Subroutines, continuations, co-routines and other fun stuff...
21 #include "parrot/parrot.h"
22 #include "parrot/oplib/ops.h"
24 #include "pmc/pmc_sub.h"
25 #include "pmc/pmc_continuation.h"
27 /* HEADERIZER HFILE: include/parrot/sub.h */
32 =item C<void mark_context_start(void)>
34 Indicate that a new round of context marking is about to take place.
40 static int context_gc_mark
= 0;
43 mark_context_start(void)
45 ASSERT_ARGS(mark_context_start
)
46 if (++context_gc_mark
== 0) context_gc_mark
= 1;
52 =item C<STRING* Parrot_full_sub_name(PARROT_INTERP, PMC* sub_pmc)>
54 Return namespace, name, and location of subroutine.
61 PARROT_CAN_RETURN_NULL
62 PARROT_WARN_UNUSED_RESULT
64 Parrot_full_sub_name(PARROT_INTERP
, ARGIN_NULLOK(PMC
* sub_pmc
))
66 ASSERT_ARGS(Parrot_full_sub_name
)
67 if (sub_pmc
&& VTABLE_defined(interp
, sub_pmc
)) {
68 Parrot_Sub_attributes
*sub
;
70 PMC_get_sub(interp
, sub_pmc
, sub
);
72 if (PMC_IS_NULL(sub
->namespace_stash
)) {
77 STRING
* const semicolon
= CONST_STRING(interp
, ";");
81 * When running with -t4, the invoke done in
82 * Parrot_ns_get_name stomps on settings in interp; we
83 * have to save these and restore them to avoid affecting
84 * the running program.
86 PMC
* const saved_ccont
= interp
->current_cont
;
88 Parrot_block_GC_mark(interp
);
90 ns_array
= Parrot_ns_get_name(interp
, sub
->namespace_stash
);
92 /* Restore stuff that might have got overwritten */
93 interp
->current_cont
= saved_ccont
;
96 VTABLE_push_string(interp
, ns_array
, sub
->name
);
98 res
= Parrot_str_join(interp
, semicolon
, ns_array
);
99 Parrot_unblock_GC_mark(interp
);
108 =item C<int Parrot_Context_get_info(PARROT_INTERP, PMC *ctx, Parrot_Context_info
111 Takes pointers to a context and its information table.
112 Populates the table and returns 0 or 1. XXX needs explanation
113 Used by Parrot_Context_infostr.
121 Parrot_Context_get_info(PARROT_INTERP
, ARGIN(PMC
*ctx
),
122 ARGOUT(Parrot_Context_info
*info
))
124 ASSERT_ARGS(Parrot_Context_get_info
)
126 Parrot_Sub_attributes
*sub
;
129 /* set file/line/pc defaults */
130 info
->file
= CONST_STRING(interp
, "(unknown file)");
134 info
->subname
= NULL
;
135 info
->fullname
= NULL
;
137 subpmc
= Parrot_pcc_get_sub(interp
, ctx
);
139 /* is the current sub of the specified context valid? */
140 if (PMC_IS_NULL(subpmc
)) {
141 info
->subname
= Parrot_str_new(interp
, "???", 3);
142 info
->nsname
= info
->subname
;
143 info
->fullname
= Parrot_str_new(interp
, "??? :: ???", 10);
148 /* fetch Parrot_sub of the current sub in the given context */
149 if (!VTABLE_isa(interp
, subpmc
, CONST_STRING(interp
, "Sub")))
152 PMC_get_sub(interp
, subpmc
, sub
);
153 /* set the sub name */
154 info
->subname
= sub
->name
;
156 /* set the namespace name and fullname of the sub */
157 if (PMC_IS_NULL(sub
->namespace_name
)) {
158 info
->nsname
= CONST_STRING(interp
, "");
159 info
->fullname
= info
->subname
;
162 info
->nsname
= VTABLE_get_string(interp
, sub
->namespace_name
);
163 info
->fullname
= Parrot_full_sub_name(interp
, subpmc
);
166 pc
= Parrot_pcc_get_pc(interp
, ctx
);
168 /* return here if there is no current pc */
172 /* calculate the current pc */
173 info
->pc
= pc
- sub
->seg
->base
.data
;
175 /* determine the current source file/line */
177 const size_t offs
= info
->pc
;
179 opcode_t
*pc
= sub
->seg
->base
.data
;
180 PackFile_Debug
* const debug
= sub
->seg
->debugs
;
184 for (i
= n
= 0; n
< sub
->seg
->base
.size
; i
++) {
185 op_info_t
* const op_info
= &interp
->op_info_table
[*pc
];
186 opcode_t var_args
= 0;
188 if (i
>= debug
->base
.size
)
191 /* set source line and file */
192 info
->line
= debug
->base
.data
[i
];
193 info
->file
= Parrot_debug_pc_to_filename(interp
, debug
, i
);
196 ADD_OP_VAR_PART(interp
, sub
->seg
, pc
, var_args
);
197 n
+= op_info
->op_count
+ var_args
;
198 pc
+= op_info
->op_count
+ var_args
;
208 =item C<INTVAL Parrot_Sub_get_line_from_pc(PARROT_INTERP, PMC *subpmc, opcode_t
211 Given a PMC sub and the current opcode, returns the corresponding PIR line
219 Parrot_Sub_get_line_from_pc(PARROT_INTERP
, ARGIN_NULLOK(PMC
*subpmc
), ARGIN_NULLOK(opcode_t
*pc
))
221 ASSERT_ARGS(Parrot_Sub_get_line_from_pc
)
222 Parrot_Sub_attributes
*sub
;
223 opcode_t
*base_pc
, *debug_ops
;
224 size_t i
, op
, current_annotation
, debug_size
;
229 PMC_get_sub(interp
, subpmc
, sub
);
231 debug_ops
= sub
->seg
->debugs
->base
.data
;
232 debug_size
= sub
->seg
->debugs
->base
.size
;
233 base_pc
= sub
->seg
->base
.data
;
234 current_annotation
= pc
- base_pc
;
236 for (i
= op
= 0; op
< debug_size
; i
++) {
237 op_info_t
* const op_info
= &interp
->op_info_table
[*base_pc
];
238 opcode_t var_args
= 0;
243 if (op
>= current_annotation
)
246 ADD_OP_VAR_PART(interp
, sub
->seg
, base_pc
, var_args
);
247 op
+= op_info
->op_count
+ var_args
;
248 base_pc
+= op_info
->op_count
+ var_args
;
257 =item C<STRING * Parrot_Sub_get_filename_from_pc(PARROT_INTERP, PMC *subpmc,
260 Given a PMC sub and the current opcode, returns the corresponding PIR file
267 PARROT_CANNOT_RETURN_NULL
269 Parrot_Sub_get_filename_from_pc(PARROT_INTERP
, ARGIN_NULLOK(PMC
*subpmc
),
270 ARGIN_NULLOK(opcode_t
*pc
))
272 ASSERT_ARGS(Parrot_Sub_get_filename_from_pc
)
273 Parrot_Sub_attributes
*sub
;
274 PackFile_Debug
*debug
;
278 return CONST_STRING(interp
, "unknown file");
280 PMC_get_sub(interp
, subpmc
, sub
);
282 debug
= sub
->seg
->debugs
;
283 position
= pc
- sub
->seg
->base
.data
;
285 return Parrot_debug_pc_to_filename(interp
, debug
, position
);
290 =item C<STRING* Parrot_Context_infostr(PARROT_INTERP, PMC *ctx)>
292 Formats context information for display. Takes a context pointer and
293 returns a pointer to the text. Used in debug.c and warnings.c
300 PARROT_CAN_RETURN_NULL
301 PARROT_WARN_UNUSED_RESULT
303 Parrot_Context_infostr(PARROT_INTERP
, ARGIN(PMC
*ctx
))
305 ASSERT_ARGS(Parrot_Context_infostr
)
306 Parrot_Context_info info
;
308 const char * const msg
= (CURRENT_CONTEXT(interp
) == ctx
)
312 Parrot_block_GC_mark(interp
);
313 if (Parrot_Context_get_info(interp
, ctx
, &info
)) {
315 res
= Parrot_sprintf_c(interp
,
316 "%s '%Ss' pc %d (%Ss:%d)", msg
,
317 info
.fullname
, info
.pc
, info
.file
, info
.line
);
320 Parrot_unblock_GC_mark(interp
);
326 =item C<PMC* Parrot_find_pad(PARROT_INTERP, STRING *lex_name, PMC *ctx)>
328 Locate the LexPad containing the given name. Return NULL on failure.
334 PARROT_CAN_RETURN_NULL
335 PARROT_WARN_UNUSED_RESULT
337 Parrot_find_pad(PARROT_INTERP
, ARGIN(STRING
*lex_name
), ARGIN(PMC
*ctx
))
339 ASSERT_ARGS(Parrot_find_pad
)
341 PMC
* const lex_pad
= Parrot_pcc_get_lex_pad(interp
, ctx
);
342 PMC
* outer
= Parrot_pcc_get_outer_ctx(interp
, ctx
);
344 if (PMC_IS_NULL(outer
))
347 if (!PMC_IS_NULL(lex_pad
))
348 if (VTABLE_exists_keyed_str(interp
, lex_pad
, lex_name
))
358 =item C<PMC* Parrot_find_dynamic_pad(PARROT_INTERP, STRING *lex_name, PMC *ctx)>
360 Locate the LexPad containing the given C<lex_name> in C<ctx> and
361 its caller pads. Return PMCNULL on failure.
367 PARROT_CAN_RETURN_NULL
368 PARROT_WARN_UNUSED_RESULT
370 Parrot_find_dynamic_pad(PARROT_INTERP
, ARGIN(STRING
*lex_name
), ARGIN(PMC
*ctx
))
372 ASSERT_ARGS(Parrot_find_dynamic_pad
)
374 PMC
* const lex_pad
= Parrot_pcc_get_lex_pad(interp
, ctx
);
375 PMC
* caller
= Parrot_pcc_get_caller_ctx(interp
, ctx
);
377 if (PMC_IS_NULL(caller
))
380 if (!PMC_IS_NULL(lex_pad
))
381 if (VTABLE_exists_keyed_str(interp
, lex_pad
, lex_name
))
391 =item C<void Parrot_capture_lex(PARROT_INTERP, PMC *sub_pmc)>
393 Capture the current lexical environment of a sub.
401 Parrot_capture_lex(PARROT_INTERP
, ARGMOD(PMC
*sub_pmc
))
403 ASSERT_ARGS(Parrot_capture_lex
)
404 PMC
* const ctx
= CURRENT_CONTEXT(interp
);
405 Parrot_Sub_attributes
*current_sub
;
406 Parrot_Sub_attributes
*sub
;
408 PMC_get_sub(interp
, Parrot_pcc_get_sub(interp
, ctx
), current_sub
);
410 /* MultiSub gets special treatment */
411 if (VTABLE_isa(interp
, sub_pmc
, CONST_STRING(interp
, "MultiSub"))) {
413 PMC
* const iter
= VTABLE_get_iter(interp
, sub_pmc
);
415 while (VTABLE_get_bool(interp
, iter
)) {
417 PMC
* const child_pmc
= VTABLE_shift_pmc(interp
, iter
);
418 Parrot_Sub_attributes
*child_sub
, *child_outer_sub
;
420 PMC_get_sub(interp
, child_pmc
, child_sub
);
422 if (!PMC_IS_NULL(child_sub
->outer_sub
)) {
423 PMC_get_sub(interp
, child_sub
->outer_sub
, child_outer_sub
);
424 if (Parrot_str_equal(interp
, current_sub
->subid
,
425 child_outer_sub
->subid
)) {
426 child_sub
->outer_ctx
= ctx
;
433 /* the sub_pmc has to have an outer_sub that is the caller */
434 PMC_get_sub(interp
, sub_pmc
, sub
);
435 if (PMC_IS_NULL(sub
->outer_sub
))
439 /* verify that the current sub is sub_pmc's :outer */
440 PMC_get_sub(interp
, sub
->outer_sub
, outer_sub
);
441 if (Parrot_str_not_equal(interp
, current_sub
->subid
,
443 Parrot_ex_throw_from_c_args(interp
, NULL
,
444 EXCEPTION_INVALID_OPERATION
, "'%Ss' isn't the :outer of '%Ss'",
445 current_sub
->name
, sub
->name
);
450 /* set the sub's outer context to the current context */
451 sub
->outer_ctx
= ctx
;
457 =item C<PMC* parrot_new_closure(PARROT_INTERP, PMC *sub_pmc)>
461 Creates a new closure, saving the context information. Takes a pointer
464 Returns a pointer to the closure, (or throws exceptions if invalid).
471 PARROT_CANNOT_RETURN_NULL
472 PARROT_WARN_UNUSED_RESULT
474 parrot_new_closure(PARROT_INTERP
, ARGIN(PMC
*sub_pmc
))
476 ASSERT_ARGS(parrot_new_closure
)
477 PMC
* const clos_pmc
= VTABLE_clone(interp
, sub_pmc
);
478 Parrot_capture_lex(interp
, clos_pmc
);
485 =item C<void Parrot_continuation_check(PARROT_INTERP, const PMC *pmc)>
487 Verifies that the provided continuation is sane.
494 Parrot_continuation_check(PARROT_INTERP
, ARGIN(const PMC
*pmc
))
496 ASSERT_ARGS(Parrot_continuation_check
)
497 PMC
* const to_ctx
= PARROT_CONTINUATION(pmc
)->to_ctx
;
498 if (PMC_IS_NULL(to_ctx
))
499 Parrot_ex_throw_from_c_args(interp
, NULL
, EXCEPTION_INVALID_OPERATION
,
500 "Continuation invoked after deactivation.");
505 =item C<void Parrot_continuation_rewind_environment(PARROT_INTERP, PMC *pmc)>
507 Restores the appropriate context for the continuation.
514 Parrot_continuation_rewind_environment(PARROT_INTERP
, ARGIN(PMC
*pmc
))
516 ASSERT_ARGS(Parrot_continuation_rewind_environment
)
518 PMC
* const to_ctx
= PARROT_CONTINUATION(pmc
)->to_ctx
;
519 PMC
* const sig
= Parrot_pcc_get_signature(interp
, CURRENT_CONTEXT(interp
));
521 /* debug print before context is switched */
522 if (Interp_trace_TEST(interp
, PARROT_TRACE_SUB_CALL_FLAG
)) {
523 PMC
* const sub
= Parrot_pcc_get_sub(interp
, to_ctx
);
525 Parrot_io_eprintf(interp
, "# Back in sub '%Ss', env %p\n",
526 Parrot_full_sub_name(interp
, sub
),
527 interp
->dynamic_env
);
531 CURRENT_CONTEXT(interp
) = to_ctx
;
532 Parrot_pcc_set_signature(interp
, to_ctx
, sig
);
538 =item C<void * Parrot_get_sub_pmc_from_subclass(PARROT_INTERP, PMC *subclass)>
540 Gets a Parrot_sub structure from something that isn't a Sub PMC, but rather a
548 PARROT_CANNOT_RETURN_NULL
550 Parrot_get_sub_pmc_from_subclass(PARROT_INTERP
, ARGIN(PMC
*subclass
)) {
551 ASSERT_ARGS(Parrot_get_sub_pmc_from_subclass
)
554 /* Ensure we really do have a subclass of sub. */
555 if (VTABLE_isa(interp
, subclass
, CONST_STRING(interp
, "Sub"))) {
556 /* If it's actually a PMC still, probably does the same structure
558 if (!PObj_is_object_TEST(subclass
)) {
559 return PARROT_SUB(subclass
);
562 /* Get the Sub PMC itself. */
563 key
= Parrot_pmc_new(interp
, enum_class_String
);
564 VTABLE_set_string_native(interp
, key
, CONST_STRING(interp
, "Sub"));
565 sub_pmc
= VTABLE_get_attr_keyed(interp
, subclass
, key
, CONST_STRING(interp
, "proxy"));
566 if (sub_pmc
->vtable
->base_type
== enum_class_Sub
) {
567 return PARROT_SUB(sub_pmc
);
570 Parrot_ex_throw_from_c_args(interp
, NULL
, EXCEPTION_INVALID_OPERATION
,
571 "Attempting to do sub operation on non-Sub.");
580 F<include/parrot/sub.h>.
589 * c-file-style: "parrot"
591 * vim: expandtab shiftwidth=4: