cc.pm

Altera recommends the following system configuration: * Pentium II 400 with 512-MB system memory (fa

sub pp_stub {
    my $op = shift;
    my $gimme = gimme($op);
    if ($gimme != G_ARRAY) {
	my $obj= new B::Stackobj::Const(sv_undef);
    	push(@stack, $obj);
	# 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();
        save_or_restore_lexical_state($$next);
	runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
    } else {
        save_or_restore_lexical_state($$next);
	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 $bool = pop_bool @stack;
	write_back_stack();
        save_or_restore_lexical_state($$next);
	runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
			$bool, label($next)));
    } else {
        save_or_restore_lexical_state($$next);
	runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
		"*sp--;");
    }
    return $op->other;
}
	    
sub pp_cond_expr {
    my $op = shift;
    my $false = $op->next;
    unshift(@bblock_todo, $false);
    reload_lexicals();
    my $bool = pop_bool();
    write_back_stack();
    save_or_restore_lexical_state($$false);
    runtime(sprintf("if (!$bool) goto %s;", label($false)));
    return $op->other;
}

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;
    # constant could be in the pad (under useithreads)
    if ($$sv) {
	$obj = $constobj{$$sv};
	if (!defined($obj)) {
	    $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
	}
    }
    else {
	$obj = $pad[$op->targ];
    }
    push(@stack, $obj);
    return $op->next;
}

sub pp_nextstate {
    my $op = shift;
    $curcop->load($op);
    @stack = ();
    debug(sprintf("%s:%d\n", $op->file, $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);
}

#default_pp will handle this:
#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_caller { $curcop->write_back; default_pp(@_) }
#sub pp_reset { $curcop->write_back; default_pp(@_) }

sub pp_rv2gv{
    my $op =shift;
    $curcop->write_back;
    write_back_lexicals() unless $skip_lexicals{$ppname};
    write_back_stack() unless $skip_stack{$ppname};
    my $sym=doop($op);
    if ($op->private & OPpDEREF) {
        $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));	
        $init->add(sprintf("((UNOP *)$sym)->op_type = %d;", 
		$op->first->type));	
    }
    return $op->next;
}
sub pp_sort {
    my $op = shift;
    my $ppname = $op->ppaddr;
    if ( $op->flags & OPf_SPECIAL && $op->flags  & OPf_STACKED){   
        #this indicates the sort BLOCK Array case
        #ugly surgery required.
        my $root=$op->first->sibling->first;
        my $start=$root->first;
	$op->first->save;
	$op->first->sibling->save;
	$root->save;
	my $sym=$start->save;
        my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
	$init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
    }
    $curcop->write_back;
    write_back_lexicals();
    write_back_stack();
    doop($op);
    return $op->next;
}

sub pp_gv {
    my $op = shift;
    my $gvsym;
    if ($Config{useithreads}) {
	$gvsym = $pad[$op->padix]->as_sv;
    }
    else {
	$gvsym = $op->gv->save;
    }
    write_back_stack();
    runtime("XPUSHs((SV*)$gvsym);");
    return $op->next;
}

sub pp_gvsv {
    my $op = shift;
    my $gvsym;
    if ($Config{useithreads}) {
	$gvsym = $pad[$op->padix]->as_sv;
    }
    else {
	$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;
    if ($Config{useithreads}) {
	$gvsym = $pad[$op->padix]->as_sv;
    }
    else {
	$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) {
	        my $rightruntime = new B::Pseudoreg ("IV", "riv");
	    	runtime(sprintf("$$rightruntime = %s;",$right));
		runtime(sprintf("sv_setiv(TOPs, %s);",
				&$operator("TOPi", $$rightruntime)));
	    } else {
	    	my $rightruntime = new B::Pseudoreg ("double", "rnv");
	    	runtime(sprintf("$$rightruntime = %s;",$right));
		runtime(sprintf("sv_setnv(TOPs, %s);",
				&$operator("TOPn",$$rightruntime)));
	    }
	}
    } 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 pp_ncmp {
    my ($op) = @_;
    if ($op->flags & OPf_STACKED) {
	my $right = pop_numeric();
	if (@stack >= 1) {
	    my $left = top_numeric();
	    runtime sprintf("if (%s > %s){",$left,$right);
		$stack[-1]->set_int(1);
	    $stack[-1]->write_back();
	    runtime sprintf("}else if (%s < %s ) {",$left,$right);
		$stack[-1]->set_int(-1);
	    $stack[-1]->write_back();
	    runtime sprintf("}else if (%s == %s) {",$left,$right);
		$stack[-1]->set_int(0);
	    $stack[-1]->write_back();
	    runtime sprintf("}else {"); 
		$stack[-1]->set_sv("&PL_sv_undef");
	    runtime "}";
	} else {
	    my $rightruntime = new B::Pseudoreg ("double", "rnv");
	    runtime(sprintf("$$rightruntime = %s;",$right));
	    runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
	    runtime sprintf("sv_setiv(TOPs,1);");
	    runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
	    runtime sprintf("sv_setiv(TOPs,-1);");
	    runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
	    runtime sprintf("sv_setiv(TOPs,0);");
	    runtime sprintf(qq/}else {/); 
	    runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
	    runtime "}";
	}
    } else {
       	my $targ = $pad[$op->targ];
	 my $right = new B::Pseudoreg ("double", "rnv");
	 my $left = new B::Pseudoreg ("double", "lnv");
	 runtime(sprintf("$$right = %s; $$left = %s;",
			    pop_numeric(), pop_numeric));
	runtime sprintf("if (%s > %s){",$$left,$$right);
		$targ->set_int(1);
		$targ->write_back();
	runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
		$targ->set_int(-1);
		$targ->write_back();
	runtime sprintf("}else if (%s == %s) {",$$left,$$right);
		$targ->set_int(0);
		$targ->write_back();
	runtime sprintf("}else {"); 
		$targ->set_sv("&PL_sv_undef");
	runtime "}";
	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 $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) }
    sub pp_subtract { numeric_binop($_[0], $minus_op) }
    sub pp_multiply { numeric_binop($_[0], $multiply_op) }
    sub pp_divide { numeric_binop($_[0], $divide_op) }
    sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's

    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) {