cc.pm

perl 解释器

    my $op = shift;
    # XXX Preserve original label name for "real" labels?
    return sprintf("lab_%x", $$op);
}

sub write_label {
    my $op = shift;
    push_runtime(sprintf("  %s:", label($op)));
}

sub loadop {
    my $op = shift;
    my $opsym = $op->save;
    runtime("PL_op = $opsym;") unless $know_op;
    return $opsym;
}

sub doop {
    my $op = shift;
    my $ppname = $op->ppaddr;
    my $sym = loadop($op);
    runtime("DOOP($ppname);");
    $know_op = 1;
    return $sym;
}

sub gimme {
    my $op = shift;
    my $flags = $op->flags;
    return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
}

#
# Code generation for PP code
#

sub pp_null {
    my $op = shift;
    return $op->next;
}

sub pp_stub {
    my $op = shift;
    my $gimme = gimme($op);
    if ($gimme != 1) {
	# XXX Change to push a constant sv_undef Stackobj onto @stack
	write_back_stack();
	runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
    }
    return $op->next;
}

sub pp_unstack {
    my $op = shift;
    @stack = ();
    runtime("PP_UNSTACK;");
    return $op->next;
}

sub pp_and {
    my $op = shift;
    my $next = $op->next;
    reload_lexicals();
    unshift(@bblock_todo, $next);
    if (@stack >= 1) {
	my $bool = pop_bool();
	write_back_stack();
	runtime(sprintf("if (!$bool) goto %s;", label($next)));
    } else {
	runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
		"*sp--;");
    }
    return $op->other;
}
	    
sub pp_or {
    my $op = shift;
    my $next = $op->next;
    reload_lexicals();
    unshift(@bblock_todo, $next);
    if (@stack >= 1) {
	my $obj = pop @stack;
	write_back_stack();
	runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }",
			$obj->as_numeric, $obj->as_sv, label($next)));
    } else {
	runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
		"*sp--;");
    }
    return $op->other;
}
	    
sub pp_cond_expr {
    my $op = shift;
    my $false = $op->false;
    unshift(@bblock_todo, $false);
    reload_lexicals();
    my $bool = pop_bool();
    write_back_stack();
    runtime(sprintf("if (!$bool) goto %s;", label($false)));
    return $op->true;
}

sub pp_padsv {
    my $op = shift;
    my $ix = $op->targ;
    push(@stack, $pad[$ix]);
    if ($op->flags & OPf_MOD) {
	my $private = $op->private;
	if ($private & OPpLVAL_INTRO) {
	    runtime("SAVECLEARSV(PL_curpad[$ix]);");
	} elsif ($private & OPpDEREF) {
	    runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
			    $ix, $private & OPpDEREF));
	    $pad[$ix]->invalidate;
	}
    }
    return $op->next;
}

sub pp_const {
    my $op = shift;
    my $sv = $op->sv;
    my $obj = $constobj{$$sv};
    if (!defined($obj)) {
	$obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
    }
    push(@stack, $obj);
    return $op->next;
}

sub pp_nextstate {
    my $op = shift;
    $curcop->load($op);
    @stack = ();
    debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
    runtime("TAINT_NOT;") unless $omit_taint;
    runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
    if ($freetmps_each_bblock || $freetmps_each_loop) {
	$need_freetmps = 1;
    } else {
	runtime("FREETMPS;");
    }
    return $op->next;
}

sub pp_dbstate {
    my $op = shift;
    $curcop->invalidate; # XXX?
    return default_pp($op);
}

sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
sub pp_bless { $curcop->write_back; default_pp(@_) }
sub pp_repeat { $curcop->write_back; default_pp(@_) }
# The following subs need $curcop->write_back if we decide to support arybase:
# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
sub pp_sort { $curcop->write_back; default_pp(@_) }
sub pp_caller { $curcop->write_back; default_pp(@_) }
sub pp_reset { $curcop->write_back; default_pp(@_) }

sub pp_gv {
    my $op = shift;
    my $gvsym = $op->gv->save;
    write_back_stack();
    runtime("XPUSHs((SV*)$gvsym);");
    return $op->next;
}

sub pp_gvsv {
    my $op = shift;
    my $gvsym = $op->gv->save;
    write_back_stack();
    if ($op->private & OPpLVAL_INTRO) {
	runtime("XPUSHs(save_scalar($gvsym));");
    } else {
	runtime("XPUSHs(GvSV($gvsym));");
    }
    return $op->next;
}

sub pp_aelemfast {
    my $op = shift;
    my $gvsym = $op->gv->save;
    my $ix = $op->private;
    my $flag = $op->flags & OPf_MOD;
    write_back_stack();
    runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
	    "PUSHs(svp ? *svp : &PL_sv_undef);");
    return $op->next;
}

sub int_binop {
    my ($op, $operator) = @_;
    if ($op->flags & OPf_STACKED) {
	my $right = pop_int();
	if (@stack >= 1) {
	    my $left = top_int();
	    $stack[-1]->set_int(&$operator($left, $right));
	} else {
	    runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
	}
    } else {
	my $targ = $pad[$op->targ];
	my $right = new B::Pseudoreg ("IV", "riv");
	my $left = new B::Pseudoreg ("IV", "liv");
	runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
	$targ->set_int(&$operator($$left, $$right));
	push(@stack, $targ);
    }
    return $op->next;
}

sub INTS_CLOSED () { 0x1 }
sub INT_RESULT () { 0x2 }
sub NUMERIC_RESULT () { 0x4 }

sub numeric_binop {
    my ($op, $operator, $flags) = @_;
    my $force_int = 0;
    $force_int ||= ($flags & INT_RESULT);
    $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
		    && valid_int($stack[-2]) && valid_int($stack[-1]));
    if ($op->flags & OPf_STACKED) {
	my $right = pop_numeric();
	if (@stack >= 1) {
	    my $left = top_numeric();
	    if ($force_int) {
		$stack[-1]->set_int(&$operator($left, $right));
	    } else {
		$stack[-1]->set_numeric(&$operator($left, $right));
	    }
	} else {
	    if ($force_int) {
		runtime(sprintf("sv_setiv(TOPs, %s);",
				&$operator("TOPi", $right)));
	    } else {
		runtime(sprintf("sv_setnv(TOPs, %s);",
				&$operator("TOPn", $right)));
	    }
	}
    } else {
	my $targ = $pad[$op->targ];
	$force_int ||= ($targ->{type} == T_INT);
	if ($force_int) {
	    my $right = new B::Pseudoreg ("IV", "riv");
	    my $left = new B::Pseudoreg ("IV", "liv");
	    runtime(sprintf("$$right = %s; $$left = %s;",
			    pop_numeric(), pop_numeric));
	    $targ->set_int(&$operator($$left, $$right));
	} else {
	    my $right = new B::Pseudoreg ("double", "rnv");
	    my $left = new B::Pseudoreg ("double", "lnv");
	    runtime(sprintf("$$right = %s; $$left = %s;",
			    pop_numeric(), pop_numeric));
	    $targ->set_numeric(&$operator($$left, $$right));
	}
	push(@stack, $targ);
    }
    return $op->next;
}

sub sv_binop {
    my ($op, $operator, $flags) = @_;
    if ($op->flags & OPf_STACKED) {
	my $right = pop_sv();
	if (@stack >= 1) {
	    my $left = top_sv();
	    if ($flags & INT_RESULT) {
		$stack[-1]->set_int(&$operator($left, $right));
	    } elsif ($flags & NUMERIC_RESULT) {
		$stack[-1]->set_numeric(&$operator($left, $right));
	    } else {
		# XXX Does this work?
		runtime(sprintf("sv_setsv($left, %s);",
				&$operator($left, $right)));
		$stack[-1]->invalidate;
	    }
	} else {
	    my $f;
	    if ($flags & INT_RESULT) {
		$f = "sv_setiv";
	    } elsif ($flags & NUMERIC_RESULT) {
		$f = "sv_setnv";
	    } else {
		$f = "sv_setsv";
	    }
	    runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
	}
    } else {
	my $targ = $pad[$op->targ];
	runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
	if ($flags & INT_RESULT) {
	    $targ->set_int(&$operator("left", "right"));
	} elsif ($flags & NUMERIC_RESULT) {
	    $targ->set_numeric(&$operator("left", "right"));
	} else {
	    # XXX Does this work?
	    runtime(sprintf("sv_setsv(%s, %s);",
			    $targ->as_sv, &$operator("left", "right")));
	    $targ->invalidate;
	}
	push(@stack, $targ);
    }
    return $op->next;
}
    
sub bool_int_binop {
    my ($op, $operator) = @_;
    my $right = new B::Pseudoreg ("IV", "riv");
    my $left = new B::Pseudoreg ("IV", "liv");
    runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
    my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
    $bool->set_int(&$operator($$left, $$right));
    push(@stack, $bool);
    return $op->next;
}

sub bool_numeric_binop {
    my ($op, $operator) = @_;
    my $right = new B::Pseudoreg ("double", "rnv");
    my $left = new B::Pseudoreg ("double", "lnv");
    runtime(sprintf("$$right = %s; $$left = %s;",
		    pop_numeric(), pop_numeric()));
    my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
    $bool->set_numeric(&$operator($$left, $$right));
    push(@stack, $bool);
    return $op->next;
}

sub bool_sv_binop {
    my ($op, $operator) = @_;
    runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
    my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
    $bool->set_numeric(&$operator("left", "right"));
    push(@stack, $bool);
    return $op->next;
}

sub infix_op {
    my $opname = shift;
    return sub { "$_[0] $opname $_[1]" }
}

sub prefix_op {
    my $opname = shift;
    return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
}

BEGIN {
    my $plus_op = infix_op("+");
    my $minus_op = infix_op("-");
    my $multiply_op = infix_op("*");
    my $divide_op = infix_op("/");
    my $modulo_op = infix_op("%");
    my $lshift_op = infix_op("<<");
    my $rshift_op = infix_op(">>");
    my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
    my $scmp_op = prefix_op("sv_cmp");
    my $seq_op = prefix_op("sv_eq");
    my $sne_op = prefix_op("!sv_eq");
    my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
    my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
    my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
    my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
    my $eq_op = infix_op("==");
    my $ne_op = infix_op("!=");
    my $lt_op = infix_op("<");
    my $gt_op = infix_op(">");
    my $le_op = infix_op("<=");
    my $ge_op = infix_op(">=");

    #
    # XXX The standard perl PP code has extra handling for
    # some special case arguments of these operators.
    #
    sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
    sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
    sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
    sub pp_divide { numeric_binop($_[0], $divide_op) }
    sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
    sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }

    sub pp_left_shift { int_binop($_[0], $lshift_op) }
    sub pp_right_shift { int_binop($_[0], $rshift_op) }
    sub pp_i_add { int_binop($_[0], $plus_op) }
    sub pp_i_subtract { int_binop($_[0], $minus_op) }
    sub pp_i_multiply { int_binop($_[0], $multiply_op) }
    sub pp_i_divide { int_binop($_[0], $divide_op) }
    sub pp_i_modulo { int_binop($_[0], $modulo_op) }

    sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
    sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
    sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
    sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
    sub pp_le { bool_numeric_binop($_[0], $le_op) }
    sub pp_ge { bool_numeric_binop($_[0], $ge_op) }

    sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
    sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
    sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
    sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
    sub pp_i_le { bool_int_binop($_[0], $le_op) }
    sub pp_i_ge { bool_int_binop($_[0], $ge_op) }

    sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
    sub pp_slt { bool_sv_binop($_[0], $slt_op) }
    sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
    sub pp_sle { bool_sv_binop($_[0], $sle_op) }
    sub pp_sge { bool_sv_binop($_[0], $sge_op) }
    sub pp_seq { bool_sv_binop($_[0], $seq_op) }
    sub pp_sne { bool_sv_binop($_[0], $sne_op) }
}


sub pp_sassign {
    my $op = shift;
    my $backwards = $op->private & OPpASSIGN_BACKWARDS;
    my ($dst, $src);
    if (@stack >= 2) {
	$dst = pop @stack;
	$src = pop @stack;
	($src, $dst) = ($dst, $src) if $backwards;
	my $type = $src->{type};
	if ($type == T_INT) {
	    $dst->set_int($src->as_int);
	} elsif ($type == T_DOUBLE) {
	    $dst->set_numeric($src->as_numeric);
	} else {
	    $dst->set_sv($src->as_sv);
	}
	push(@stack, $dst);
    } elsif (@stack == 1) {
	if ($backwards) {