cc.pm

perl 解释器

	    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;