Integrate with mainperl.

p4raw-id: //depot/cfgperl@3598

5 files changed, 69 insertions, 51 deletions

diff --git a/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm
index ba6293b1ff..df2a64214e 100644
--- a/ext/B/B/Bblock.pm
+++ b/ext/B/B/Bblock.pm
@@ -4,7 +4,9 @@ use Exporter ();
 @EXPORT_OK = qw(find_leaders);
 
 use B qw(peekop walkoptree walkoptree_exec
-	 main_root main_start svref_2object OPf_SPECIAL OPf_STACKED);
+	 main_root main_start svref_2object
+         OPf_SPECIAL OPf_STACKED );
+
 use B::Terse;
 use strict;
 
@@ -17,19 +19,19 @@ sub mark_leader {
 	$bblock->{$$op} = $op;
     }
 }
-sub remove_sortblocks{
-    foreach (keys %$bblock) {
-        my $leader = $$bblock{$_};
-	delete  $$bblock{$_} if ( $leader == 0);
+
+sub remove_sortblock{
+    foreach (keys %$bblock){
+        my $leader=$$bblock{$_};	
+	delete $$bblock{$_} if( $leader == 0);   
     }
 }
-
 sub find_leaders {
     my ($root, $start) = @_;
     $bblock = {};
     mark_leader($start) if ( ref $start ne "B::NULL" );
     walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
-    remove_sortblocks();
+    remove_sortblock();
     return $bblock;
 }
 
@@ -104,18 +106,19 @@ sub B::CONDOP::mark_if_leader {
     mark_leader($op->false);
 }
 
+
 sub B::LISTOP::mark_if_leader {
     my $op = shift;
     my $first=$op->first;
-    $first=$first->next	while ($first->ppaddr eq "pp_null"); #remove optimed
+    $first=$first->next while ($first->ppaddr eq "pp_null");
     mark_leader($op->first) unless (exists( $bblock->{$$first}));
     mark_leader($op->next);
-    if ($op->ppaddr eq "pp_sort" && $op->flags
-	& OPf_SPECIAL && $op->flags & OPf_STACKED){	
-         my $root=$op->first->sibling->first;
-         my $leader=$root->first;
-         $bblock->{$$leader} = 0;
-}
+    if ($op->ppaddr eq "pp_sort" and $op->flags & OPf_SPECIAL
+	and $op->flags & OPf_STACKED){
+        my $root=$op->first->sibling->first;
+        my $leader=$root->first;
+        $bblock->{$$leader} = 0;
+    }
 }
 
 sub B::PMOP::mark_if_leader {
diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index 7f2954354b..0385452ffc 100644
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -551,7 +551,7 @@ sub B::PVMG::save_magic {
 	if ($len == HEf_SVKEY){
 		#The pointer is an SV*
 		$ptrsv=svref_2object($ptr)->save;
-		$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
+		$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
 			   $$sv, $$obj, cchar($type),$ptrsv,$len));
 	}else{
 		$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
@@ -1330,7 +1330,7 @@ sub save_main {
     my $init_av = init_av->save;
     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
 	       sprintf("PL_main_start = s\\_%x;", ${main_start()}),
-	       "PL_initav = $init_av;");
+              "PL_initav = (AV *) $init_av;");                                
     save_context();
     warn "Writing output\n";
     output_boilerplate();
diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index 059491d354..5a143bc307 100644
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -92,9 +92,10 @@ sub init_hash { map { $_ => 1 } @_ }
 #
 %skip_lexicals = init_hash qw(pp_enter pp_enterloop);
 %skip_invalidate = init_hash qw(pp_enter pp_enterloop);
-%need_curcop = init_hash qw(pp_rv2gv  pp_bless pp_repeat pp_sort
-	 pp_caller pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
-	 pp_entertry pp_enterloop pp_enteriter pp_entersub pp_enter);
+%need_curcop = init_hash qw(pp_rv2gv  pp_bless pp_repeat pp_sort pp_caller
+			pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
+			pp_entertry pp_enterloop pp_enteriter pp_entersub
+			pp_enter);
 
 sub debug {
     if ($debug_runtime) {
@@ -582,7 +583,6 @@ sub pp_dbstate {
 }
 
 #default_pp will handle this:
-#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:
@@ -590,41 +590,40 @@ sub pp_dbstate {
 #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 optree surgery required.
-	my $root=$op->first->sibling->first;
-	my $start=$root->first;
+    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;
-	$start->save;
-	my $sym=objsym($start);
-	my $fakeop=cc_queue("pp_sort".$$op,$root,$start);	
-	$init->add(sprintf("($sym)->op_next=%s;",$fakeop));
-    } 
+	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_leavesub{
-    my $op = shift;
-    my $ppname = $op->ppaddr;
-    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("}");
+    write_back_lexicals();
+    write_back_stack();
     doop($op);
     return $op->next;
-}
-
+}              
 sub pp_gv {
     my $op = shift;
     my $gvsym = $op->gv->save;
@@ -1071,7 +1070,16 @@ 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);
@@ -1535,7 +1543,7 @@ sub cc_main {
 	$init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
 		   "PL_main_start = $start;",
 		   "PL_curpad = AvARRAY($curpad_sym);",
-		   "PL_initav = $init_av;",
+		   "PL_initav = (AV *) $init_av;",
 		   "GvHV(PL_incgv) = $inc_hv;",
 		   "GvAV(PL_incgv) = $inc_av;",
 		   "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
diff --git a/ext/B/B/Stackobj.pm b/ext/B/B/Stackobj.pm
index c6aa1ba925..123b2fcc5c 100644
--- a/ext/B/B/Stackobj.pm
+++ b/ext/B/B/Stackobj.pm
@@ -264,13 +264,21 @@ sub B::Stackobj::Const::write_back {
 
 sub B::Stackobj::Const::load_int {
     my $obj = shift;
-    $obj->{iv} = int($obj->{sv}->PV);
+    if (ref($obj->{sv}) eq "B::RV"){
+       $obj->{iv} = int($obj->{sv}->RV->PV);
+    }else{
+       $obj->{iv} = int($obj->{sv}->PV);
+    }
     $obj->{flags} |= VALID_INT;
 }
 
 sub B::Stackobj::Const::load_double {
     my $obj = shift;
-    $obj->{nv} = $obj->{sv}->PV + 0.0;
+    if (ref($obj->{sv}) eq "B::RV"){
+        $obj->{nv} = $obj->{sv}->RV->PV + 0.0;
+    }else{
+        $obj->{nv} = $obj->{sv}->PV + 0.0;
+    }
     $obj->{flags} |= VALID_DOUBLE;
 }
 
diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs
index 9cd71ce786..db28891b79 100644
--- a/ext/GDBM_File/GDBM_File.xs
+++ b/ext/GDBM_File/GDBM_File.xs
@@ -256,7 +256,6 @@ gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
 		croak("No write permission to gdbm file");
 	    croak("gdbm store returned %d, errno %d, key \"%.*s\"",
 			RETVAL,errno,key.dsize,key.dptr);
-	    gdbm_clearerr(db);
 	}
 
 #define gdbm_DELETE(db,key)			gdbm_delete(db->dbp,key)