?? cc.pm
字號:
my $src = pop @stack;
my $type = $src->{type};
runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
if ($type == T_INT) {
runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
} elsif ($type == T_DOUBLE) {
runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
} else {
runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
}
runtime("SvSETMAGIC(TOPs);");
} else {
my $dst = pop @stack;
my $type = $dst->{type};
runtime("sv = POPs;");
runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
if ($type == T_INT) {
$dst->set_int("SvIV(sv)");
} elsif ($type == T_DOUBLE) {
$dst->set_double("SvNV(sv)");
} else {
runtime("SvSetSV($dst->{sv}, sv);");
$dst->invalidate;
}
}
} else {
if ($backwards) {
runtime("src = POPs; dst = TOPs;");
} else {
runtime("dst = POPs; src = TOPs;");
}
runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
"SvSetSV(dst, src);",
"SvSETMAGIC(dst);",
"SETs(dst);");
}
return $op->next;
}
sub pp_preinc {
my $op = shift;
if (@stack >= 1) {
my $obj = $stack[-1];
my $type = $obj->{type};
if ($type == T_INT || $type == T_DOUBLE) {
$obj->set_int($obj->as_int . " + 1");
} else {
runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
$obj->invalidate();
}
} else {
runtime sprintf("PP_PREINC(TOPs);");
}
return $op->next;
}
sub pp_pushmark {
my $op = shift;
write_back_stack();
runtime("PUSHMARK(sp);");
return $op->next;
}
sub pp_list {
my $op = shift;
write_back_stack();
my $gimme = gimme($op);
if ($gimme == 1) { # sic
runtime("POPMARK;"); # need this even though not a "full" pp_list
} else {
runtime("PP_LIST($gimme);");
}
return $op->next;
}
sub pp_entersub {
my $op = shift;
write_back_lexicals(REGISTER|TEMPORARY);
write_back_stack();
my $sym = doop($op);
runtime("if (PL_op != ($sym)->op_next) PL_op = (*PL_op->op_ppaddr)(ARGS);");
runtime("SPAGAIN;");
$know_op = 0;
invalidate_lexicals(REGISTER|TEMPORARY);
return $op->next;
}
sub pp_enterwrite {
my $op = shift;
pp_entersub($op);
}
sub pp_leavewrite {
my $op = shift;
write_back_lexicals(REGISTER|TEMPORARY);
write_back_stack();
my $sym = doop($op);
# XXX Is this the right way to distinguish between it returning
# CvSTART(cv) (via doform) and pop_return()?
runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
runtime("SPAGAIN;");
$know_op = 0;
invalidate_lexicals(REGISTER|TEMPORARY);
return $op->next;
}
sub doeval {
my $op = shift;
$curcop->write_back;
write_back_lexicals(REGISTER|TEMPORARY);
write_back_stack();
my $sym = loadop($op);
my $ppaddr = $op->ppaddr;
runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
$know_op = 1;
invalidate_lexicals(REGISTER|TEMPORARY);
return $op->next;
}
sub pp_entereval { doeval(@_) }
sub pp_require { doeval(@_) }
sub pp_dofile { doeval(@_) }
sub pp_entertry {
my $op = shift;
$curcop->write_back;
write_back_lexicals(REGISTER|TEMPORARY);
write_back_stack();
my $sym = doop($op);
my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
declare("Sigjmp_buf", $jmpbuf);
runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
invalidate_lexicals(REGISTER|TEMPORARY);
return $op->next;
}
sub pp_grepstart {
my $op = shift;
if ($need_freetmps && $freetmps_each_loop) {
runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
$need_freetmps = 0;
}
write_back_stack();
doop($op);
return $op->next->other;
}
sub pp_mapstart {
my $op = shift;
if ($need_freetmps && $freetmps_each_loop) {
runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
$need_freetmps = 0;
}
write_back_stack();
doop($op);
return $op->next->other;
}
sub pp_grepwhile {
my $op = shift;
my $next = $op->next;
unshift(@bblock_todo, $next);
write_back_lexicals();
write_back_stack();
my $sym = doop($op);
# pp_grepwhile can return either op_next or op_other and we need to
# be able to distinguish the two at runtime. Since it's possible for
# both ops to be "inlined", the fields could both be zero. To get
# around that, we hack op_next to be our own op (purely because we
# know it's a non-NULL pointer and can't be the same as op_other).
$init->add("((LOGOP*)$sym)->op_next = $sym;");
runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
$know_op = 0;
return $op->other;
}
sub pp_mapwhile {
pp_grepwhile(@_);
}
sub pp_return {
my $op = shift;
write_back_lexicals(REGISTER|TEMPORARY);
write_back_stack();
doop($op);
runtime("PUTBACK;", "return 0;");
$know_op = 0;
return $op->next;
}
sub nyi {
my $op = shift;
warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
return default_pp($op);
}
sub pp_range {
my $op = shift;
my $flags = $op->flags;
if (!($flags & OPf_KNOW)) {
error("context of range unknown at compile-time");
}
write_back_lexicals();
write_back_stack();
if (!($flags & OPf_LIST)) {
# We need to save our UNOP structure since pp_flop uses
# it to find and adjust out targ. We don't need it ourselves.
$op->save;
runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
$op->targ, label($op->false));
unshift(@bblock_todo, $op->false);
}
return $op->true;
}
sub pp_flip {
my $op = shift;
my $flags = $op->flags;
if (!($flags & OPf_KNOW)) {
error("context of flip unknown at compile-time");
}
if ($flags & OPf_LIST) {
return $op->first->false;
}
write_back_lexicals();
write_back_stack();
# We need to save our UNOP structure since pp_flop uses
# it to find and adjust out targ. We don't need it ourselves.
$op->save;
my $ix = $op->targ;
my $rangeix = $op->first->targ;
runtime(($op->private & OPpFLIP_LINENUM) ?
"if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
: "if (SvTRUE(TOPs)) {");
runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
if ($op->flags & OPf_SPECIAL) {
runtime("sv_setiv(PL_curpad[$ix], 1);");
} else {
runtime("\tsv_setiv(PL_curpad[$ix], 0);",
"\tsp--;",
sprintf("\tgoto %s;", label($op->first->false)));
}
runtime("}",
qq{sv_setpv(PL_curpad[$ix], "");},
"SETs(PL_curpad[$ix]);");
$know_op = 0;
return $op->next;
}
sub pp_flop {
my $op = shift;
default_pp($op);
$know_op = 0;
return $op->next;
}
sub enterloop {
my $op = shift;
my $nextop = $op->nextop;
my $lastop = $op->lastop;
my $redoop = $op->redoop;
$curcop->write_back;
debug "enterloop: pushing on cxstack" if $debug_cxstack;
push(@cxstack, {
type => CXt_LOOP,
op => $op,
"label" => $curcop->[0]->label,
nextop => $nextop,
lastop => $lastop,
redoop => $redoop
});
$nextop->save;
$lastop->save;
$redoop->save;
return default_pp($op);
}
sub pp_enterloop { enterloop(@_) }
sub pp_enteriter { enterloop(@_) }
sub pp_leaveloop {
my $op = shift;
if (!@cxstack) {
die "panic: leaveloop";
}
debug "leaveloop: popping from cxstack" if $debug_cxstack;
pop(@cxstack);
return default_pp($op);
}
sub pp_next {
my $op = shift;
my $cxix;
if ($op->flags & OPf_SPECIAL) {
$cxix = dopoptoloop();
if ($cxix < 0) {
error('"next" used outside loop');
return $op->next; # ignore the op
}
} else {
$cxix = dopoptolabel($op->pv);
if ($cxix < 0) {
error('Label not found at compile time for "next %s"', $op->pv);
return $op->next; # ignore the op
}
}
default_pp($op);
my $nextop = $cxstack[$cxix]->{nextop};
push(@bblock_todo, $nextop);
runtime(sprintf("goto %s;", label($nextop)));
return $op->next;
}
sub pp_redo {
my $op = shift;
my $cxix;
if ($op->flags & OPf_SPECIAL) {
$cxix = dopoptoloop();
if ($cxix < 0) {
error('"redo" used outside loop');
return $op->next; # ignore the op
}
} else {
$cxix = dopoptolabel($op->pv);
if ($cxix < 0) {
error('Label not found at compile time for "redo %s"', $op->pv);
return $op->next; # ignore the op
}
}
default_pp($op);
my $redoop = $cxstack[$cxix]->{redoop};
push(@bblock_todo, $redoop);
runtime(sprintf("goto %s;", label($redoop)));
return $op->next;
}
sub pp_last {
my $op = shift;
my $cxix;
if ($op->flags & OPf_SPECIAL) {
$cxix = dopoptoloop();
if ($cxix < 0) {
error('"last" used outside loop');
return $op->next; # ignore the op
}
} else {
$cxix = dopoptolabel($op->pv);
if ($cxix < 0) {
error('Label not found at compile time for "last %s"', $op->pv);
return $op->next; # ignore the op
}
# XXX Add support for "last" to leave non-loop blocks
if ($cxstack[$cxix]->{type} != CXt_LOOP) {
error('Use of "last" for non-loop blocks is not yet implemented');
return $op->next; # ignore the op
}
}
default_pp($op);
my $lastop = $cxstack[$cxix]->{lastop}->next;
push(@bblock_todo, $lastop);
runtime(sprintf("goto %s;", label($lastop)));
return $op->next;
}
sub pp_subst {
my $op = shift;
write_back_lexicals();
write_back_stack();
my $sym = doop($op);
my $replroot = $op->pmreplroot;
if ($$replroot) {
runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
$sym, label($replroot));
$op->pmreplstart->save;
push(@bblock_todo, $replroot);
}
invalidate_lexicals();
return $op->next;
}
sub pp_substcont {
my $op = shift;
write_back_lexicals();
write_back_stack();
doop($op);
my $pmop = $op->other;
warn sprintf("substcont: op = %s, pmop = %s\n",
peekop($op), peekop($pmop));#debug
# my $pmopsym = objsym($pmop);
my $pmopsym = $pmop->save; # XXX can this recurse?
warn "pmopsym = $pmopsym\n";#debug
runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
$pmopsym, label($pmop->pmreplstart));
invalidate_lexicals();
return $pmop->next;
}
sub default_pp {
my $op = shift;
my $ppname = $op->ppaddr;
write_back_lexicals() unless $skip_lexicals{$ppname};
write_back_stack() unless $skip_stack{$ppname};
doop($op);
# XXX If the only way that ops can write to a TEMPORARY lexical is
# when it's named in $op->targ then we could call
# invalidate_lexicals(TEMPORARY) and avoid having to write back all
# the temporaries. For now, we'll play it safe and write back the lot.
invalidate_lexicals() unless $skip_invalidate{$ppname};
return $op->next;
}
sub compile_op {
my $op = shift;
my $ppname = $op->ppaddr;
if (exists $ignore_op{$ppname}) {
return $op->next;
}
debug peek_stack() if $debug_stack;
if ($debug_op) {
debug sprintf("%s [%s]\n",
peekop($op),
$op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
}
no strict 'refs';
if (defined(&$ppname)) {
$know_op = 0;
return &$ppname($op);
} else {
return default_pp($op);
}
}
sub compile_bblock {
my $op = shift;
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -