cc.pm

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

	$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,$src->{flags} & VALID_UNSIGNED);
	} 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) {
	    my $src = pop @stack;
	    my $type = $src->{type};
	    runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
	    if ($type == T_INT) {
                if ($src->{flags} & VALID_UNSIGNED){ 
                     runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
                }else{
                    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 = $stack[-1];
	    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("SvSetMagicSV($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 == G_ARRAY) { # 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;
    $curcop->write_back;
    write_back_lexicals(REGISTER|TEMPORARY);
    write_back_stack();
    my $sym = doop($op);
    runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
    runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
    runtime("SPAGAIN;}");
    $know_op = 0;
    invalidate_lexicals(REGISTER|TEMPORARY);
    return $op->next;
}
sub pp_formline {
    my $op = shift;
    my $ppname = $op->ppaddr;
    write_back_lexicals() unless $skip_lexicals{$ppname};
    write_back_stack() unless $skip_stack{$ppname};
    my $sym=doop($op);
    # See comment in pp_grepwhile to see why!
    $init->add("((LISTOP*)$sym)->op_first = $sym;");    
    runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
    save_or_restore_lexical_state(${$op->first});
    runtime( sprintf("goto %s;",label($op->first)));
    runtime("}");
    return $op->next;
}

sub pp_goto{

    my $op = shift;
    my $ppname = $op->ppaddr;
    write_back_lexicals() unless $skip_lexicals{$ppname};
    write_back_stack() unless $skip_stack{$ppname};
    my $sym=doop($op);
    runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
    invalidate_lexicals() unless $skip_invalidate{$ppname};
    return $op->next;
}
sub pp_enterwrite {
    my $op = shift;
    pp_entersub($op);
}
sub pp_leavesub{
    my $op = shift;
    write_back_lexicals() unless $skip_lexicals{$ppname};
    write_back_stack() unless $skip_stack{$ppname};
    runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");   
    runtime("\tPUTBACK;return 0;");
    runtime("}");
    doop($op);
    return $op->next;
}
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)(aTHX);");
    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(qq/printf("$ppaddr type eval\n");/);
    runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
    $know_op = 1;
    invalidate_lexicals(REGISTER|TEMPORARY);
    return $op->next;
}

sub pp_entereval { doeval(@_) }
sub pp_dofile { doeval(@_) }

#pp_require is protected by pp_entertry, so no protection for it.
sub pp_require {
    my $op = shift;
    $curcop->write_back;
    write_back_lexicals(REGISTER|TEMPORARY);
    write_back_stack();
    my $sym = doop($op);
    runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
    runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
    runtime("SPAGAIN;}");
    $know_op = 1;
    invalidate_lexicals(REGISTER|TEMPORARY);
    return $op->next;
}


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("JMPENV", $jmpbuf);
    runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
    invalidate_lexicals(REGISTER|TEMPORARY);
    return $op->next;
}

sub pp_leavetry{
	my $op=shift;
	default_pp($op);
	runtime("PP_LEAVETRY;");
    	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();
    my $sym= doop($op);
    my $next=$op->next;
    $next->save;
    my $nexttonext=$next->next;
    $nexttonext->save;
    save_or_restore_lexical_state($$nexttonext);
    runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
		    label($nexttonext)));
    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();
    # pp_mapstart can return either op_next->op_next or op_next->op_other and
    # we need to be able to distinguish the two at runtime. 
    my $sym= doop($op);
    my $next=$op->next;
    $next->save;
    my $nexttonext=$next->next;
    $nexttonext->save;
    save_or_restore_lexical_state($$nexttonext);
    runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
		    label($nexttonext)));
    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;");
    save_or_restore_lexical_state($$next);
    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 PL_op;");
    $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_WANT)) {
	error("context of range unknown at compile-time");
    }
    write_back_lexicals();
    write_back_stack();
    unless (($flags & OPf_WANT)== OPf_WANT_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;
        save_or_restore_lexical_state(${$op->other});
	runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
			$op->targ, label($op->other));
	unshift(@bblock_todo, $op->other);
    }
    return $op->next;
}

sub pp_flip {
    my $op = shift;
    my $flags = $op->flags;
    if (!($flags & OPf_WANT)) {
	error("context of flip unknown at compile-time");
    }
    if (($flags & OPf_WANT)==OPf_WANT_LIST) {
	return $op->first->other;
    }
    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 {
    	save_or_restore_lexical_state(${$op->first->other});
	runtime("\tsv_setiv(PL_curpad[$ix], 0);",
		"\tsp--;",
		sprintf("\tgoto %s;", label($op->first->other)));
    }
    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);
    save_or_restore_lexical_state($$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);
    save_or_restore_lexical_state($$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);
    save_or_restore_lexical_state($$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) {
        save_or_restore_lexical_state($$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
    save_or_restore_lexical_state(${$pmop->pmreplstart});
    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;