From e38b4cbc221107aa093622b98846ce199aed8688 Mon Sep 17 00:00:00 2001 From: Gerhard R Date: Wed, 20 Feb 2013 12:42:55 +0100 Subject: [PATCH] Remove Eval PMC --- MANIFEST | 3 - include/parrot/sub.h | 3 +- src/call/pcc.c | 1 - src/pmc/eval.pmc | 463 ---------------------------- src/pmc/imccompiler.pmc | 33 -- t/compilers/imcc/syn/eval.t | 161 ---------- t/pmc/eval.t | 590 ------------------------------------ t/pmc/namespace-old.t | 5 - 8 files changed, 1 insertion(+), 1258 deletions(-) delete mode 100644 src/pmc/eval.pmc delete mode 100644 t/compilers/imcc/syn/eval.t delete mode 100644 t/pmc/eval.t diff --git a/MANIFEST b/MANIFEST index 67547c18db..cc14c18785 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1377,7 +1377,6 @@ src/pmc/continuation.pmc [] src/pmc/coroutine.pmc [] src/pmc/default.pmc [] src/pmc/env.pmc [] -src/pmc/eval.pmc [] src/pmc/eventhandler.pmc [] src/pmc/exception.pmc [] src/pmc/exceptionhandler.pmc [] @@ -1536,7 +1535,6 @@ t/compilers/imcc/reg/spill_old.t [test] t/compilers/imcc/syn/clash.t [test] t/compilers/imcc/syn/const.t [test] t/compilers/imcc/syn/errors.t [test] -t/compilers/imcc/syn/eval.t [test] t/compilers/imcc/syn/file.t [test] t/compilers/imcc/syn/hll.t [test] t/compilers/imcc/syn/keyed.t [test] @@ -1896,7 +1894,6 @@ t/pmc/continuation.t [test] t/pmc/coroutine.t [test] t/pmc/default.t [test] t/pmc/env.t [test] -t/pmc/eval.t [test] t/pmc/eventhandler.t [test] t/pmc/exception-old.t [test] t/pmc/exception.t [test] diff --git a/include/parrot/sub.h b/include/parrot/sub.h index 479a973193..84a4da00a2 100644 --- a/include/parrot/sub.h +++ b/include/parrot/sub.h @@ -125,8 +125,7 @@ typedef struct Parrot_sub_arginfo { do { \ const INTVAL type = (pmc)->vtable->base_type; \ if (type == enum_class_Sub || \ - type == enum_class_Coroutine || \ - type == enum_class_Eval) \ + type == enum_class_Coroutine) \ {\ (sub) = PARROT_SUB((pmc)); \ } \ diff --git a/src/call/pcc.c b/src/call/pcc.c index 66cdd2452b..6884564af8 100644 --- a/src/call/pcc.c +++ b/src/call/pcc.c @@ -268,7 +268,6 @@ do_run_ops(PARROT_INTERP, ARGIN(PMC *sub_obj)) switch (sub_obj->vtable->base_type) { case enum_class_Sub: case enum_class_MultiSub: - case enum_class_Eval: case enum_class_Continuation: return 1; case enum_class_Object: diff --git a/src/pmc/eval.pmc b/src/pmc/eval.pmc deleted file mode 100644 index 399b8a019d..0000000000 --- a/src/pmc/eval.pmc +++ /dev/null @@ -1,463 +0,0 @@ -/* -Copyright (C) 2001-2011, Parrot Foundation. - -=head1 NAME - -src/pmc/eval.pmc - Dynamic code evaluation - -=head1 DESCRIPTION - -C extends C to provide C-like dynamic code -evaluation and execution. - -=cut - -*/ - -#include "pmc/pmc_sub.h" - -/* HEADERIZER HFILE: none */ -/* HEADERIZER BEGIN: static */ -/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ - -PARROT_WARN_UNUSED_RESULT -PARROT_CAN_RETURN_NULL -static PMC* get_sub(PARROT_INTERP, ARGIN(PMC *self), int idx) - __attribute__nonnull__(1) - __attribute__nonnull__(2); - -static void mark_ct(PARROT_INTERP, ARGIN(PMC *self)) - __attribute__nonnull__(1) - __attribute__nonnull__(2); - -#define ASSERT_ARGS_get_sub __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ - PARROT_ASSERT_ARG(interp) \ - , PARROT_ASSERT_ARG(self)) -#define ASSERT_ARGS_mark_ct __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ - PARROT_ASSERT_ARG(interp) \ - , PARROT_ASSERT_ARG(self)) -/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ -/* HEADERIZER END: static */ - -pmclass Eval extends Sub provides invokable auto_attrs { - -/* - -=head2 Vtable functions - -=over 4 - -=item C - -Initializes a new empty Eval. - -=item C - -Destroy the Eval and its associated bytecode. - -=item C - -Mark this Eval. - -=cut - -*/ - - VTABLE void init() { - Parrot_Sub_attributes *sub_data; - SUPER(); - - PMC_get_sub(INTERP, SELF, sub_data); - sub_data->seg = NULL; - PObj_custom_mark_destroy_SETALL(SELF); - } - - VTABLE void destroy() { - /* - * If the compiled code contained any .sub (or .pcc.sub) - * subroutines, these subs got installed in the globals - * during compiling this bytecode segment. - * - * These globals still exist, calling them will segfault - * as the segment is destroyed now. - * - * TT # 1230: - * Walk the fixups, locate globals and nullify the Sub PMC - * This probably needs a pointer into the globals. - * - * OTOH - if the global exists - this eval pmc ought - * to be alive and destroy isn't called. - */ - PackFile_ByteCode *cur_cs; - Parrot_Sub_attributes *sub_data; - - PMC_get_sub(INTERP, SELF, sub_data); - - if (!sub_data) { - SUPER(); - return; - } - - cur_cs = sub_data->seg; - - if (!cur_cs) { - SUPER(); - return; - } - - /* XXX Quick and dirty fix for TT #995 */ - #if 0 - if ((struct PackFile *)cur_cs == INTERP->initial_pf - || cur_cs == INTERP->code) { - SUPER(); - return; - } - #endif - - #if 0 - seg = (PackFile_Segment *)cur_cs->const_table; - if (seg) { - PackFile_Segment_destroy(INTERP, seg); - cur_cs->const_table = NULL; - } - - seg = (PackFile_Segment *)cur_cs->debugs; - if (seg) { - PackFile_Segment_destroy(INTERP, seg); - cur_cs->debugs = NULL; - } - - seg = (PackFile_Segment *)cur_cs; - if (seg) - PackFile_Segment_destroy(INTERP, seg); - - #endif - sub_data->seg = NULL; - - SUPER(); - } - - VTABLE void mark() { - SUPER(); - mark_ct(INTERP, SELF); - } - -/* - -=item C - -Returns the address of the associated packfile. - -=cut - -*/ - - VTABLE void *get_pointer() { - Parrot_Sub_attributes *sub; - PMC_get_sub(INTERP, SELF, sub); - if (sub) { - const PackFile_ByteCode * const seg = sub->seg; - if (seg) - return seg->base.pf; - } - return NULL; - } - -/* - -=item C - -Invokes the first subroutine in the eval code. - -=cut - -*/ - - VTABLE opcode_t *invoke(void *next) { - PMC * const sub = SELF.get_pmc_keyed_int(0); - return VTABLE_invoke(INTERP, sub, next); - } - -/* - -=item C - -Get a STRING representing the bytecode for this code segment, suitable -for writing to disc and later loading via C. - -=cut - -*/ - - VTABLE STRING *get_string() { - Parrot_Sub_attributes *sub; - PackFile *pf = PackFile_new(INTERP, 0); - PackFile_ByteCode *seg; - STRING *res; - size_t size, aligned_size; - - PMC_get_sub(INTERP, SELF, sub); - seg = sub->seg; - - PackFile_add_segment(INTERP, &pf->directory, (PackFile_Segment *)seg); - - if (seg->const_table) - PackFile_add_segment(INTERP, &pf->directory, - (PackFile_Segment *)seg->const_table); - - if (seg->debugs) - PackFile_add_segment(INTERP, &pf->directory, - (PackFile_Segment *)seg->debugs); - - size = PackFile_pack_size(INTERP, pf) * sizeof (opcode_t); - - /* - * work around packfile bug: - * as far as I have checked it the story is: - * - PackFile_pack_size() assumes 16 byte alignment but doesn't - * have the actual start of the code (packed) - * - PackFile_pack() uses 16 bye alignment relative to the start - * of the code, which isn't really the same - * Therefore align code at 16, which should give the desired - * effect - */ - aligned_size = size + 15; - res = Parrot_str_new_init(INTERP, NULL, aligned_size, - Parrot_binary_encoding_ptr, 0); - res->strlen = res->bufused = size; - - if ((size_t)(res->strstart) & 0xf) { - char *adr = res->strstart; - adr += 16 - ((size_t)adr & 0xf); - res->strstart = adr; - } - - /* We block GC while doing the packing, since GC run during a pack - has been observed to cause problems. There may be a Better Fix. - See http://rt.perl.org/rt3/Ticket/Display.html?id=40410 - for example of the problem (note on line that - segfaults, it is *cursor that is pointing to dealloced memory). */ - Parrot_block_GC_mark(INTERP); - PackFile_pack(INTERP, pf, (opcode_t *)res->strstart); - Parrot_unblock_GC_mark(INTERP); - - /* now remove all segments from directory again and destroy - * the packfile */ - pf->directory.num_segments = 0; - PackFile_destroy(INTERP, pf); - - return res; - } - -/* - -=item C - -Returns the Sub PMC of the element at index C or PMCNULL. - -=cut - -*/ - - VTABLE PMC *get_pmc_keyed_int(INTVAL key) { - return get_sub(INTERP, SELF, key); - } - -/* - -=item C - -Archives the evaled code - -=item C - -Unarchives the code. - -=cut - -*/ - - VTABLE void freeze(PMC *info) { - STRING * const packed = SELF.get_string(); - VTABLE_push_string(INTERP, info, packed); - - SUPER(info); - } - - VTABLE void thaw(PMC *info) { - STRING * const packed = VTABLE_shift_string(INTERP, info); - PackFile *pf; - PMC *pfpmc; - Parrot_Sub_attributes *sub; - size_t i; - - SUPER(info); - pf = PackFile_new(INTERP, 0); - pfpmc = Parrot_pf_get_packfile_pmc(INTERP, pf, STRINGNULL); - - if (!PackFile_unpack(INTERP, pf, (opcode_t *)packed->strstart, - packed->strlen)) - Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_EXTERNAL_ERROR, - "couldn't unpack packfile"); - - for (i = 0; i < pf->directory.num_segments; ++i) { - PackFile_Segment * const seg = pf->directory.segments[i]; - - if (seg->type == PF_BYTEC_SEG) { - PMC_get_sub(INTERP, SELF, sub); - sub->seg = (PackFile_ByteCode *)seg; - break; - } - } - - pf->directory.num_segments = 0; - - /* - * TT #1292 this isn't ok - it seems that the packfile - * gets attached to INTERP->code and is - * destroyed again during interpreter destruction - */ - /* PackFile_destroy(INTERP, pf); */ - } - - VTABLE INTVAL elements() { - INTVAL n = 0; - Parrot_Sub_attributes *sub; - PackFile_ByteCode *seg; - - PMC_get_sub(INTERP, SELF, sub); - seg = sub->seg; - - if (seg) { - const PackFile_ConstTable * const ct = seg->const_table; - if (ct) { - INTVAL i; - STRING * const SUB = CONST_STRING(interp, "Sub"); - for (i = 0; i < ct->pmc.const_count; ++i) { - PMC * const x = ct->pmc.constants[i]; - if (VTABLE_isa(interp, x, SUB)) - ++n; - } - } - } - - return n; - } - -/* - -=back - -=head2 Methods - -=over 4 - -=item C - -Return the main sub, if any, null PMC otherwise. - -=cut - -*/ - - METHOD get_main() - { - PMC * const mainsub = Parrot_pf_get_packfile_main_sub(INTERP, SELF); - RETURN(PMC * mainsub); - } - -} - -/* - -=back - -=head2 Auxiliar functions - -=over 4 - -=item C - -Get the Cth Sub PMC from the constants table. - -=cut - -*/ - -PARROT_WARN_UNUSED_RESULT -PARROT_CAN_RETURN_NULL -static PMC* -get_sub(PARROT_INTERP, ARGIN(PMC *self), int idx) -{ - ASSERT_ARGS(get_sub) - - Parrot_Sub_attributes *sub; - PackFile_ByteCode *seg; - - PMC_get_sub(interp, self, sub); - seg = sub->seg; - - if (seg) { - const PackFile_ConstTable * const ct = seg->const_table; - if (ct) { - INTVAL i; - for (i = 0; i < ct->pmc.const_count; ++i) { - STRING * const SUB = CONST_STRING(interp, "Sub"); - PMC * const x = ct->pmc.constants[i]; - if (VTABLE_isa(interp, x, SUB)) - if (!idx--) - return x; - } - } - } - - return PMCNULL; -} - -/* - -=item C - -Mark the bytecode segment pointed to by this Eval for GC. - -=cut - -*/ - -static void -mark_ct(PARROT_INTERP, ARGIN(PMC *self)) -{ - ASSERT_ARGS(mark_ct) - - Parrot_Sub_attributes *sub; - PackFile_ByteCode *seg; - - PMC_get_sub(interp, self, sub); - seg = sub->seg; - - if (seg) { - const PackFile_ConstTable * const ct = seg->const_table; - if (ct) { - INTVAL i; - for (i = 0; i < ct->pmc.const_count; ++i) { - PMC * const csub = ct->pmc.constants[i]; - Parrot_gc_mark_PMC_alive(interp, csub); - } - } - } -} - -/* - -=back - -=cut - -*/ - -/* - * Local variables: - * c-file-style: "parrot" - * End: - * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : - */ diff --git a/src/pmc/imccompiler.pmc b/src/pmc/imccompiler.pmc index e4981121a1..ad3e7f0194 100644 --- a/src/pmc/imccompiler.pmc +++ b/src/pmc/imccompiler.pmc @@ -56,39 +56,6 @@ static PMC * get_packfile_eval_pmc(PARROT_INTERP, Parrot_unblock_GC_mark((i)); \ (i)->code = __old_bc; \ -/* - -=over 4 - -=item C - -get eval_pmc info from packfile - -=cut - -*/ - -PARROT_CANNOT_RETURN_NULL -PARROT_WARN_UNUSED_RESULT -static PMC * -get_packfile_eval_pmc(PARROT_INTERP, ARGIN(PMC *pf_pmc), INTVAL current_eval) -{ - ASSERT_ARGS(get_packfile_eval_pmc) - - PackFile * const pf = (PackFile*)VTABLE_get_pointer(interp, pf_pmc); - PMC * const eval_pmc = Parrot_pmc_new(interp, enum_class_Eval); - Parrot_Sub_attributes *sub_data; - - PMC_get_sub(interp, eval_pmc, sub_data); - sub_data->seg = pf->cur_cs; - sub_data->start_offs = 0; - sub_data->end_offs = pf->cur_cs->base.size; - sub_data->name = Parrot_sprintf_c(interp, "EVAL_%d", current_eval); - Parrot_pf_prepare_packfile_init(interp, eval_pmc); - return eval_pmc; -} - /* HEADERIZER HFILE: none */ pmclass IMCCompiler auto_attrs provides HLLCompiler provide invokable { diff --git a/t/compilers/imcc/syn/eval.t b/t/compilers/imcc/syn/eval.t deleted file mode 100644 index a5cff9ea02..0000000000 --- a/t/compilers/imcc/syn/eval.t +++ /dev/null @@ -1,161 +0,0 @@ -#!perl -# Copyright (C) 2001-2005, Parrot Foundation. - -use strict; -use warnings; -use lib qw( . lib ../lib ../../lib ); -use Test::More; -use Parrot::Config; -use Parrot::Test tests => 7; - -SKIP: { - skip( "changed eval semantics - see t/pmc/eval.t", 7 ); - -############################## - pir_output_is( <<'CODE', <<'OUT', "eval pasm" ); -.sub test :main - $S0 = 'set S1, "in eval\n"' - concat $S0, "\n" - concat $S0, "print S1\nend\n" - compreg $P0, "PASM" - compile P0, $P0, $S0 - invoke - print "back\n" - end -.end -CODE -in eval -back -OUT - - pir_output_is( <<'CODE', <<'OUT', "eval pir" ); -.sub test :main - $S1 = ".sub _foo\n" - concat $S1, '$S1 = "42\n"' - concat $S1, "\nprint $S1\nend\n" - concat $S1, "\n.end\n" - compreg $P0, "PIR" - compile P0, $P0, $S1 - invoke - print "back\n" - end -.end -CODE -42 -back -OUT - - pir_output_is( <<'CODE', <<'OUT', "intersegment branch" ); -# #! perl -w -# my $i= 5; -# LAB: -# $i++; -# eval("goto LAB if ($i==6)"); -# print "$i\n"; -# -# 7 -##### - -.sub test :main - I1 = 5 - $S0 = ".sub _e\nif I1 == 6 goto LAB\nend\n.end\n" - compreg P2, "PIR" - compile P0, P2, $S0 -LAB: - inc I1 - invoke - print I1 - print "\n" - end -.end -CODE -7 -OUT - - pir_output_is( <<'CODE', <<'OUT', "intersegment branch 2" ); -.sub test :main - I1 = 4 - $S0 = ".sub _e\nif I1 <= 6 goto LAB\nend\n.end\n" - compreg P2, "PIR" - compile P0, P2, $S0 -LAB: - inc I1 - invoke - print I1 - print "\n" - end -.end -CODE -7 -OUT - - pir_output_is( <<'CODE', <<'OUT', "intersegment branch 3" ); -.sub test :main - I1 = 4 - compreg P2, "PIR" - $S0 = ".sub _e\nif I1 <= 5 goto LAB\nend\n.end\n" - compile P0, P2, $S0 - $S0 = ".sub _e\nif I1 <= 6 goto LAB\nend\n.end\n" - compile P1, P2, $S0 -LAB: - inc I1 - invoke - set P0, P1 - invoke - print I1 - print "\n" - end -.end -CODE -7 -OUT - - pir_output_is( <<'CODE', <<'OUT', "intersegment branch 4" ); -.sub test :main - I1 = 4 - compreg P2, "PIR" - $S0 = ".sub _e\nif I1 <= 5 goto LAB\nend\n.end\n" - compile P0, P2, $S0 - $S0 = ".sub _e\nif I1 <= 6 goto LAB\nend\n.end\n" - compile P1, P2, $S0 -LAB: - inc I1 - invoke - set P0, P1 - invoke - if I1 <= 7 goto LAB - print I1 - print "\n" - end -.end -CODE -8 -OUT - - pir_output_is( <<'CODE', <<'OUT', "eval - same constants" ); -.sub test :main - print "hello" - print "\n" - $S0 = 'print "hello"' - concat $S0, "\n" - concat $S0, 'print "\n"' - concat $S0, "\nend\n" - compreg $P0, "PASM" - compile P0, $P0, $S0 - invoke - print "back\n" - end -.end -CODE -hello -hello -back -OUT -} - -# Local Variables: -# mode: cperl -# cperl-indent-level: 4 -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4: diff --git a/t/pmc/eval.t b/t/pmc/eval.t deleted file mode 100644 index 25156c313e..0000000000 --- a/t/pmc/eval.t +++ /dev/null @@ -1,590 +0,0 @@ -#! perl -# Copyright (C) 2001-2009, Parrot Foundation. - -use strict; -use warnings; -use lib qw( . lib ../lib ../../lib ); - -use Test::More; -use Parrot::Test::Util 'create_tempfile'; - -use Parrot::Test tests => 18; - -=head1 NAME - -t/pmc/eval.t - Dynamic Code Evaluation - -=head1 SYNOPSIS - - % prove t/pmc/eval.t - -=head1 DESCRIPTION - -Tests on-the-fly PASM, PIR and PAST compilation and invocation. - -=cut - -pasm_output_is( <<'CODE', <<'OUTPUT', "eval_sc" ); -.pcc_sub :main main: - compreg P1, "PASM" # get compiler - set_args "0", "print \"in eval\\n\"\nset_returns \"()\"\nreturncc\n" - invokecc P1 # compile - get_results "0", P0 - invokecc P0 # eval code P0 - print "back again\n" - end -CODE -in eval -back again -OUTPUT - -pasm_output_is( <<'CODE', <<'OUTPUT', "call subs in evaled code " ); -.pcc_sub :main main: - set S5, ".pcc_sub _foo:\n" - concat S5, S5, "print \"foo\\n\"\n" - concat S5, S5, "set_returns \"()\"\n" - concat S5, S5, "returncc\n" - compreg P1, "PASM" - set_args "0", S5 - invokecc P1 - get_results "0", P2 - elements I0, P2 - say I0 - get_global P0, "_foo" - invokecc P0 - print "back\n" - end -CODE -1 -foo -back -OUTPUT - -pasm_output_is( <<'CODE', <<'OUTPUT', "call 2 subs in evaled code " ); -.pcc_sub :main main: - set S5, ".pcc_sub _foo:\n" - concat S5, S5, "print \"foo\\n\"\n" - concat S5, S5, "set_returns \"()\"\n" - concat S5, S5, "returncc\n" - concat S5, S5, ".pcc_sub _bar:\n" - concat S5, S5, "print \"bar\\n\"\n" - concat S5, S5, "set_returns \"()\"\n" - concat S5, S5, "returncc\n" - compreg P1, "PASM" - set_args "0", S5 - invokecc P1 - get_results "0", P6 - get_global P2, "_foo" - invokecc P2 - print "back\n" - get_global P2, "_bar" - invokecc P2 - print "fin\n" - end -CODE -foo -back -bar -fin -OUTPUT - -pir_output_is( <<'CODE', <<'OUTPUT', "PIR compiler sub" ); - -.sub test :main - .local pmc compiler - get_global compiler, "xcompile" - compreg "XPASM", compiler - .local pmc my_compiler - my_compiler = compreg "XPASM" - .local pmc the_sub - .local string code - code = "print \"ok\\n\"\n" - code .= "set_returns \"()\"\n" - code .= "returncc\n" - the_sub = my_compiler("_foo", code) - the_sub() - the_sub = get_global "_foo" - the_sub() -.end - -.sub xcompile - .param string sub_name - .param string code - $S0 = ".pcc_sub " - $S0 .= sub_name - $S0 .= ":\n" - $S0 .= code - .local pmc pasm_compiler - pasm_compiler = compreg "PASM" - # print $S0 - $P0 = pasm_compiler($S0) - .return($P0) -.end -CODE -ok -ok -OUTPUT - -pir_output_is( <<'CODE', <<'OUTPUT', "bug #31467" ); - - .sub main :main - $P1 = new ['Hash'] - $P0 = find_name "_builtin" - $P1['builtin'] = $P0 - - $P2 = compreg "PIR" - $S0 = ".sub main\nprint \"dynamic\\n\"\n.end\n" - $P0 = $P2($S0) - $P1['dynamic'] = $P0 - - set_global "funcs", $P1 - - $S0 = ".sub main\n$P1 = get_global\"funcs\"\n" - $S0 .= "$P0 = $P1['dynamic']\n$P0()\n" - $S0 .= "$P0 = $P1['builtin']\n$P0()\n" - $S0 .= ".end\n" - - $P2 = compreg "PIR" - $P0 = $P2($S0) - $P0() - end - .end - - .sub _builtin - print "builtin\n" - .end -CODE -dynamic -builtin -OUTPUT - -pir_output_is( <<'CODE', <<'OUTPUT', "PIR compiler sub PASM" ); -.sub main :main - register_compiler() - - .local pmc compiler, invokable - compiler = compreg "PUTS" - - invokable = compiler("ok 1") - invokable() - -.end - -.sub register_compiler - $P0 = get_global "puts" - compreg "PUTS", $P0 -.end - -.sub puts - .param string printme - - .local pmc pasm_compiler, retval - pasm_compiler = compreg "PASM" - - .local string code - - code = "print \"" - code .= printme - code .= "\\n\"\n" - code .= "set_returns \"()\"\n" - code .= "returncc\n" - - retval = pasm_compiler( code ) - - .return (retval) -.end -CODE -ok 1 -OUTPUT - -pir_output_is( <<'CODE', <<'OUTPUT', "PIR compiler sub PIR" ); -.sub main :main - register_compiler() - - .local pmc compiler, invokable - compiler = compreg "PUTS" - - invokable = compiler( "ok 1" ) - invokable() - -.end - -.sub register_compiler - .local pmc counter - counter = new ['Integer'] - counter = 0 - set_global "counter", counter - - $P0 = get_global "_puts" - compreg "PUTS", $P0 -.end - -.sub _puts - .param string printme - - .local pmc pir_compiler, retval - pir_compiler = compreg "PIR" - - .local pmc counter - counter = get_global "counter" - inc counter - - .local string code - code = ".sub anonymous" - $S0 = counter - code .= $S0 - code .= " :anon\n" - code .= "print \"" - code .= printme - code .= "\\n\"\n" - code .=".end\n" - - retval = pir_compiler( code ) - - .return (retval) -.end -CODE -ok 1 -OUTPUT - -my (undef, $temp_pbc) = create_tempfile( SUFFIX => '.pbc', UNLINK => 1 ); -my (undef, $temp2_pbc) = create_tempfile( SUFFIX => '.pbc', UNLINK => 1 ); - -pir_output_is( <<"CODE", <<'OUTPUT', "eval.get_string" ); -.sub main :main - - .local pmc f1, f2 - .local pmc io - f1 = compi("foo_1", "hello from foo_1") - \$S0 = f1 - io = new ['FileHandle'] - io.'open'("$temp_pbc", 'w') - print io, \$S0 - io.'close'() - load_bytecode "$temp_pbc" - f2 = compi("foo_2", "hello from foo_2") - io.'open'("$temp2_pbc", 'w') - print io, f2 - io.'close'() - load_bytecode "$temp2_pbc" -.end - -.sub compi - .param string name - .param string printme - .local string code - .local pmc pir_compiler, retval - pir_compiler = compreg "PIR" - code = ".sub " - code .= name - code .= " :load\\n" - code .= "print \\"" - code .= printme - code .= "\\\\n\\"\\n" - code .= ".end\\n" - - retval = pir_compiler(code) - .return (retval) -.end -CODE -hello from foo_1 -hello from foo_2 -OUTPUT - -(my $temp_name = $temp_pbc) =~ s/\.pbc$//; -(my $temp2_name = $temp2_pbc) =~ s/\.pbc$//; - -pir_output_is( <<"CODE", <<'OUTPUT', "check loaded lib hash" ); -.sub main :main - load_bytecode "$temp_pbc" - load_bytecode "$temp2_pbc" - .local pmc pbc_hash, interp - .include 'iglobals.pasm' - interp = getinterp - pbc_hash = interp[.IGLOBALS_PBC_LIBS] - \$I0 = elements pbc_hash - print \$I0 - print ' ' - \$I1 = exists pbc_hash['$temp_name'] - print \$I1 - print ' ' - \$I2 = exists pbc_hash['$temp2_name'] - print \$I2 - print ' ' - \$S0 = pbc_hash['$temp2_name'] - # print \$S0 not portable - \$I3 = index \$S0, '$temp2_name' - \$I4 = isgt \$I3, -1 - say \$I4 -.end -CODE -hello from foo_1 -hello from foo_2 -2 1 1 1 -OUTPUT - -(my $fh, $temp_pbc) = create_tempfile( SUFFIX => '.pbc', UNLINK => 1 ); -close $fh; - -pir_output_is( <<"CODE", <<'OUTPUT', "eval.get_string - same file" ); -.sub main :main - .local pmc f1, f2 - .local pmc io, os - f1 = compi("foo_1", "hello from foo_1") - \$S0 = f1 - io = new ['FileHandle'] - io.'open'("$temp_pbc", 'w') - print io, \$S0 - io.'close'() - load_bytecode "$temp_pbc" - f2 = compi("foo_2", "hello from foo_2") - io.'open'("$temp_pbc", 'w') - print io, f2 - io.'close'() - load_bytecode "$temp_pbc" -.end - -.sub compi - .param string name - .param string printme - .local string code - .local pmc pir_compiler, retval - pir_compiler = compreg "PIR" - code = ".sub " - code .= name - code .= " :load\\n" - code .= "print \\"" - code .= printme - code .= "\\\\n\\"\\n" - code .= ".end\\n" - - retval = pir_compiler(code) - .return (retval) -.end -CODE -hello from foo_1 -OUTPUT - -my (undef, $temp_file) = create_tempfile( UNLINK => 1 ); - -pir_output_is( <<"CODE", <<'OUTPUT', "eval.freeze" ); -.sub main :main - .local pmc f, e - .local pmc io - f = compi("foo_1", "hello from foo_1") - \$S0 = freeze f - io = new ['FileHandle'] - io.'open'("$temp_file", 'w') - print io, \$S0 - io.'close'() - say "written" -.end - -.sub compi - .param string name - .param string printme - .local string code - .local pmc pir_compiler, retval - pir_compiler = compreg "PIR" - code = ".sub " - code .= name - code .= "\\n" - code .= "print \\"" - code .= printme - code .= "\\\\n\\"\\n" - code .= ".end\\n" - - retval = pir_compiler(code) - .return (retval) -.end -CODE -written -OUTPUT - -pir_output_is( <<"CODE", <<'OUTPUT', "eval.thaw"); -.sub main :main - .local pmc io, e - .local string file - .local int size - file = "$temp_file" - io = new ['FileHandle'] - io.'open'(file, 'rb') - \$S0 = io.'readall'() - io.'close'() - e = thaw \$S0 - sweep 1 # ensure all of the object survives GC - e() - e = get_global "foo_1" - e() -.end -CODE -hello from foo_1 -hello from foo_1 -OUTPUT - -pir_output_is( <<"CODE", <<'OUTPUT', "eval.freeze+thaw" ); -.sub main :main - .local pmc f, e - .local pmc io - f = compi("foo_1", "hello from foo_1") - \$S0 = freeze f - io = new ['FileHandle'] - io.'open'("$temp_file", 'wb') - print io, \$S0 - io.'close'() - say "written" - "read"() -.end - -.sub compi - .param string name - .param string printme - .local string code - .local pmc pir_compiler, retval - pir_compiler = compreg "PIR" - code = ".sub " - code .= name - code .= "\\n" - code .= <<"MORE" - noop - noop - noop - noop -MORE - code .= "print \\"" - code .= printme - code .= "\\\\n\\"\\n" - code .= ".end\\n" - - retval = pir_compiler(code) - .return (retval) -.end - -.sub "read" - .local pmc io, e - .local string file - .local int size - file = "$temp_file" - io = new ['FileHandle'] - io.'open'(file, 'rb') - \$S0 = io.'readall'() - io.'close'() - e = thaw \$S0 - e() - e = get_global "foo_1" - e() -.end -CODE -written -hello from foo_1 -hello from foo_1 -OUTPUT - -pir_output_is( <<'CODE', <<'OUTPUT', "get_pmc_keyed_int" ); -.sub main :main - .local string code - .local pmc e, s, compi - code = <<"EOC" - .sub foo - noop - .end - .sub bar - noop - .end -EOC - compi = compreg "PIR" - e = compi(code) - s = e[0] - print s - print "\n" - s = e[1] - print s - print "\n" -.end -CODE -foo -bar -OUTPUT - -pir_output_is( <<'CODE', <<'OUTPUT', "get_main method" ); -.sub main :main - .local string code - .local pmc compi, e, smain - code = <<"EOC" - .sub notmain - say "NOOOO" - .end - .sub main - say "My name is main but I'm not main" - .end - .sub thisismain :main - .param pmc args :optional - say "This is main" - .end -EOC - compi = compreg "PIR" - e = compi(code) - smain = e.'get_main'() - smain() -.end -CODE -This is main -OUTPUT - -pir_output_is( <<'CODE', <<'OUTPUT', "catch compile err" ); -.sub main :main - push_eh handler - $P2 = compreg "PIR" - $S0 = <<"EPIR" - .sub foo - print a typo - .end -EPIR - $P0 = $P2($S0) - $P0() - end -handler: - print "ok\n" -.end -CODE -ok -OUTPUT - -my ($TEMP, $filename) = create_tempfile( SUFFIX => '.pir', UNLINK => 1 ); - -print $TEMP <