updates to compiler modules

	Message-ID: <19990303072725.779.qmail@hotmail.com>
	Subject: PATCH 5.005_56 + Test procedure

p4raw-id: //depot/perl@3066

3 files changed, 60 insertions, 14 deletions

diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index 67b20b965a..759b9cd8a7 100644
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -1301,12 +1301,6 @@ sub descend_marked_unused {
     }
 }
 
-sub descend_marked_unused {
-    foreach my $pack (keys %unused_sub_packages)
-    {
-    	mark_package($pack);
-    }
-}
  
 sub save_main {
     warn "Starting compile\n";
diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index 08429cb0a7..d44a119222 100644
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -8,10 +8,10 @@
 package B::CC;
 use strict;
 use B qw(main_start main_root class comppadlist peekop svref_2object
-	timing_info init_av  
+	timing_info init_av  sv_undef
 	OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
 	OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
-	OPpDEREF OPpFLIP_LINENUM G_ARRAY     
+	OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR    
 	CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
 	);
 use B::C qw(save_unused_subs objsym init_sections mark_unused
@@ -444,7 +444,7 @@ sub doop {
 sub gimme {
     my $op = shift;
     my $flags = $op->flags;
-    return (($flags & OPf_WANT) ? ($flags & OPf_WANT_LIST) : "dowantarray()");
+    return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
 }
 
 #
@@ -459,10 +459,12 @@ sub pp_null {
 sub pp_stub {
     my $op = shift;
     my $gimme = gimme($op);
-    if ($gimme != 1) {
+    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);");
+	#write_back_stack();
+	#runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
     }
     return $op->next;
 }
@@ -921,7 +923,7 @@ sub pp_list {
     my $op = shift;
     write_back_stack();
     my $gimme = gimme($op);
-    if ($gimme == 1) { # sic
+    if ($gimme == G_ARRAY) { # sic
 	runtime("POPMARK;"); # need this even though not a "full" pp_list
     } else {
 	runtime("PP_LIST($gimme);");
@@ -941,6 +943,20 @@ sub pp_entersub {
     invalidate_lexicals(REGISTER|TEMPORARY);
     return $op->next;
 }
+sub pp_formline {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    write_label($op);
+    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 != ($sym)->op_next && PL_op != (OP*)0 ){");
+    runtime( sprintf("goto %s;",label($op)));
+    runtime("}");
+    return $op->next;
+}
 
 sub pp_goto{
 
@@ -996,12 +1012,19 @@ sub pp_entertry {
     write_back_stack();
     my $sym = doop($op);
     my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
-    declare("Sigjmp_buf", $jmpbuf);
+    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) {
diff --git a/ext/B/B/Stash.pm b/ext/B/B/Stash.pm
new file mode 100644
index 0000000000..42c8bc0fd3
--- /dev/null
+++ b/ext/B/B/Stash.pm
@@ -0,0 +1,29 @@
+# Stash.pm -- show what stashes are loaded
+# vishalb@hotmail.com 
+package B::Stash;
+
+BEGIN { %Seen = %INC }
+
+END {
+	my @arr=scan($main::{"main::"});
+	@arr=map{s/\:\:$//;$_;}  @arr;
+	print "-umain,-u", join (",-u",@arr) ,"\n";
+}
+sub scan{
+	my $start=shift;
+	my @return;
+	foreach my $key ( keys %{$start}){
+		if ($key =~ /::$/){
+			unless ($start  eq ${$start}{$key} or $key eq "B::" ){
+		 		push @return, $key ;
+				foreach my $subscan ( scan(${$start}{$key})){
+		 			push @return, "$key".$subscan; 	
+				}
+			}
+		}
+	}
+	return @return;
+}
+1;
+
+