From: Vishal Bhatia <vishal@deja.com>
Date: Wed, 9 Dec 1998 22:16:50 +0000 (-0800)
Subject: 1. Fixes the bug  reported by  Robin Barker <rmb1@cise.npl.co.uk>
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a9b6343a0cbd709bfa038c43a178314fd9eb0af2;p=p5sagit%2Fp5-mst-13.2.git

1. Fixes the bug  reported by  Robin Barker <rmb1@cise.npl.co.uk>
2. Fixes the bug  regarding return value of c-functions generated out
of perl subs. ( Just includes the patch I sent earlier)
3. Incorporates the other changes that need to be done to get CC.pm
use ISA search for packages and methods on the same lines as C.pm

Vishal would appreciate comments about B::Stackobj changes from
someone knowing that module well.

p4raw-id: //depot/perl@2461
---

diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index 40583bd..58d8859 100644
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -1244,6 +1244,7 @@ sub walkpackages
 sub save_unused_subs 
 {
  no strict qw(refs);
+ &descend_marked_unused;
  warn "Prescan\n";
  walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
  warn "Saving methods\n";
@@ -1263,12 +1264,15 @@ sub save_context
                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
 }
 
+sub descend_marked_unused {
+    foreach my $pack (keys %unused_sub_packages)
+    {
+    	mark_package($pack);
+    }
+}
+
 sub save_main {
     warn "Starting compile\n";
-    foreach my $pack (keys %unused_sub_packages)
-     {
-      mark_package($pack);
-     }
     warn "Walking tree\n";
     walkoptree(main_root, "save");
     warn "done main optree, walking symtable for extras\n" if $debug_cv;
diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index e6c21bc..efb17a1 100644
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -73,10 +73,6 @@ BEGIN {
     }
 }
 
-my @unused_sub_packages; # list of packages (given by -u options) to search
-			 # explicitly and save every sub we find there, even
-			 # if apparently unused (could be only referenced from
-			 # an eval "" or from a $SIG{FOO} = "bar").
 
 my ($module_name);
 my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
@@ -200,7 +196,7 @@ sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
-sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" }
+sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
 
 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
@@ -208,7 +204,7 @@ sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
 sub pop_bool {
     if (@stack) {
-	return ((pop @stack)->as_numeric);
+	return ((pop @stack)->as_bool);
     } else {
 	# Careful: POPs has an auto-decrement and SvTRUE evaluates
 	# its argument more than once.
@@ -1063,7 +1059,7 @@ sub pp_return {
     write_back_lexicals(REGISTER|TEMPORARY);
     write_back_stack();
     doop($op);
-    runtime("PUTBACK;", "return (PL_op)?PL_op->op_next:0;");
+    runtime("PUTBACK;", "return PL_op;");
     $know_op = 0;
     return $op->next;
 }
@@ -1356,7 +1352,7 @@ sub cc {
 	    $need_freetmps = 0;
 	}
 	if (!$$op) {
-	    runtime("PUTBACK;","return (PL_op)?PL_op->op_next:0;");
+	    runtime("PUTBACK;","return PL_op;");
 	} elsif ($done{$$op}) {
 	    runtime(sprintf("goto %s;", label($op)));
 	}
@@ -1493,7 +1489,7 @@ sub compile {
 	} elsif ($opt eq "m") {
 	    $arg ||= shift @options;
 	    $module = $arg;
-	    push(@unused_sub_packages, $arg);
+	    mark_unused($arg,undef);
 	} elsif ($opt eq "p") {
 	    $arg ||= shift @options;
 	    $patchlevel = $arg;
diff --git a/ext/B/B/Stackobj.pm b/ext/B/B/Stackobj.pm
index eea966c..7760006 100644
--- a/ext/B/B/Stackobj.pm
+++ b/ext/B/B/Stackobj.pm
@@ -81,6 +81,16 @@ sub as_numeric {
     return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
 }
 
+sub as_bool {
+	my $obj=shift;
+	if ($obj->{flags} & VALID_INT ){
+		return $obj->{iv}; 
+	}
+	if ($obj->{flags} & VALID_DOUBLE ){
+		return $obj->{nv}; 
+	}
+	return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
+}
 #
 # Debugging methods
 #