<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#      Stackobj.pm
#
#      Copyright (c) 1996 Malcolm Beattie
#
#      You may distribute under the terms of either the GNU General Public
#      License or the Artistic License, as specified in the README file.
#
package B::Stackobj;  
use Exporter ();
@ISA = qw(Exporter);
@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
		VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
%EXPORT_TAGS = (types =&gt; [qw(T_UNKNOWN T_DOUBLE T_INT)],
		flags =&gt; [qw(VALID_INT VALID_DOUBLE VALID_SV
			     VALID_UNSIGNED REGISTER TEMPORARY)]);

use Carp qw(confess);
use strict;
use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);

# Types
sub T_UNKNOWN () { 0 }
sub T_DOUBLE ()  { 1 }
sub T_INT ()     { 2 }
sub T_SPECIAL () { 3 }

# Flags
sub VALID_INT ()	{ 0x01 }
sub VALID_UNSIGNED ()	{ 0x02 }
sub VALID_DOUBLE ()	{ 0x04 }
sub VALID_SV ()		{ 0x08 }
sub REGISTER ()		{ 0x10 } # no implicit write-back when calling subs
sub TEMPORARY ()	{ 0x20 } # no implicit write-back needed at all
sub SAVE_INT () 	{ 0x40 } #if int part needs to be saved at all
sub SAVE_DOUBLE () 	{ 0x80 } #if double part needs to be saved at all


#
# Callback for runtime code generation
#
my $runtime_callback = sub { confess "set_callback not yet called" };
sub set_callback (&amp;) { $runtime_callback = shift }
sub runtime { &amp;$runtime_callback(@_) }

#
# Methods
#

sub write_back { confess "stack object does not implement write_back" }

sub invalidate { shift-&gt;{flags} &amp;= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }

sub as_sv {
    my $obj = shift;
    if (!($obj-&gt;{flags} &amp; VALID_SV)) {
	$obj-&gt;write_back;
	$obj-&gt;{flags} |= VALID_SV;
    }
    return $obj-&gt;{sv};
}

sub as_int {
    my $obj = shift;
    if (!($obj-&gt;{flags} &amp; VALID_INT)) {
	$obj-&gt;load_int;
	$obj-&gt;{flags} |= VALID_INT|SAVE_INT;
    }
    return $obj-&gt;{iv};
}

sub as_double {
    my $obj = shift;
    if (!($obj-&gt;{flags} &amp; VALID_DOUBLE)) {
	$obj-&gt;load_double;
	$obj-&gt;{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
    }
    return $obj-&gt;{nv};
}

sub as_numeric {
    my $obj = shift;
    return $obj-&gt;{type} == T_INT ? $obj-&gt;as_int : $obj-&gt;as_double;
}

sub as_bool {
	my $obj=shift;
	if ($obj-&gt;{flags} &amp; VALID_INT ){
		return $obj-&gt;{iv}; 
	}
	if ($obj-&gt;{flags} &amp; VALID_DOUBLE ){
		return $obj-&gt;{nv}; 
	}
	return sprintf("(SvTRUE(%s))", $obj-&gt;as_sv) ;
}

#
# Debugging methods
#
sub peek {
    my $obj = shift;
    my $type = $obj-&gt;{type};
    my $flags = $obj-&gt;{flags};
    my @flags;
    if ($type == T_UNKNOWN) {
	$type = "T_UNKNOWN";
    } elsif ($type == T_INT) {
	$type = "T_INT";
    } elsif ($type == T_DOUBLE) {
	$type = "T_DOUBLE";
    } else {
	$type = "(illegal type $type)";
    }
    push(@flags, "VALID_INT") if $flags &amp; VALID_INT;
    push(@flags, "VALID_DOUBLE") if $flags &amp; VALID_DOUBLE;
    push(@flags, "VALID_SV") if $flags &amp; VALID_SV;
    push(@flags, "REGISTER") if $flags &amp; REGISTER;
    push(@flags, "TEMPORARY") if $flags &amp; TEMPORARY;
    @flags = ("none") unless @flags;
    return sprintf("%s type=$type flags=%s sv=$obj-&gt;{sv}",
		   class($obj), join("|", @flags));
}

sub minipeek {
    my $obj = shift;
    my $type = $obj-&gt;{type};
    my $flags = $obj-&gt;{flags};
    if ($type == T_INT || $flags &amp; VALID_INT) {
	return $obj-&gt;{iv};
    } elsif ($type == T_DOUBLE || $flags &amp; VALID_DOUBLE) {
	return $obj-&gt;{nv};
    } else {
	return $obj-&gt;{sv};
    }
}

#
# Caller needs to ensure that set_int, set_double,
# set_numeric and set_sv are only invoked on legal lvalues.
#
sub set_int {
    my ($obj, $expr,$unsigned) = @_;
    runtime("$obj-&gt;{iv} = $expr;");
    $obj-&gt;{flags} &amp;= ~(VALID_SV | VALID_DOUBLE);
    $obj-&gt;{flags} |= VALID_INT|SAVE_INT;
    $obj-&gt;{flags} |= VALID_UNSIGNED if $unsigned; 
}

sub set_double {
    my ($obj, $expr) = @_;
    runtime("$obj-&gt;{nv} = $expr;");
    $obj-&gt;{flags} &amp;= ~(VALID_SV | VALID_INT);
    $obj-&gt;{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
}

sub set_numeric {
    my ($obj, $expr) = @_;
    if ($obj-&gt;{type} == T_INT) {
	$obj-&gt;set_int($expr);
    } else {
	$obj-&gt;set_double($expr);
    }
}

sub set_sv {
    my ($obj, $expr) = @_;
    runtime("SvSetSV($obj-&gt;{sv}, $expr);");
    $obj-&gt;invalidate;
    $obj-&gt;{flags} |= VALID_SV;
}

#
# Stackobj::Padsv
#

@B::Stackobj::Padsv::ISA = 'B::Stackobj';
sub B::Stackobj::Padsv::new {
    my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
    $extra_flags |= SAVE_INT if $extra_flags &amp; VALID_INT;
    $extra_flags |= SAVE_DOUBLE if $extra_flags &amp; VALID_DOUBLE;
    bless {
	type =&gt; $type,
	flags =&gt; VALID_SV | $extra_flags,
	sv =&gt; "PL_curpad[$ix]",
	iv =&gt; "$iname",
	nv =&gt; "$dname"
    }, $class;
}

sub B::Stackobj::Padsv::load_int {
    my $obj = shift;
    if ($obj-&gt;{flags} &amp; VALID_DOUBLE) {
	runtime("$obj-&gt;{iv} = $obj-&gt;{nv};");
    } else {
	runtime("$obj-&gt;{iv} = SvIV($obj-&gt;{sv});");
    }
    $obj-&gt;{flags} |= VALID_INT|SAVE_INT;
}

sub B::Stackobj::Padsv::load_double {
    my $obj = shift;
    $obj-&gt;write_back;
    runtime("$obj-&gt;{nv} = SvNV($obj-&gt;{sv});");
    $obj-&gt;{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
}
sub B::Stackobj::Padsv::save_int {
    my $obj = shift;
    return $obj-&gt;{flags} &amp; SAVE_INT;
}

sub B::Stackobj::Padsv::save_double {
    my $obj = shift;
    return $obj-&gt;{flags} &amp; SAVE_DOUBLE;
}

sub B::Stackobj::Padsv::write_back {
    my $obj = shift;
    my $flags = $obj-&gt;{flags};
    return if $flags &amp; VALID_SV;
    if ($flags &amp; VALID_INT) {
        if ($flags &amp; VALID_UNSIGNED ){
            runtime("sv_setuv($obj-&gt;{sv}, $obj-&gt;{iv});");
        }else{
            runtime("sv_setiv($obj-&gt;{sv}, $obj-&gt;{iv});");
        }     
    } elsif ($flags &amp; VALID_DOUBLE) {
	runtime("sv_setnv($obj-&gt;{sv}, $obj-&gt;{nv});");
    } else {
	confess "write_back failed for lexical @{[$obj-&gt;peek]}\n";
    }
    $obj-&gt;{flags} |= VALID_SV;
}

#
# Stackobj::Const
#

@B::Stackobj::Const::ISA = 'B::Stackobj';
sub B::Stackobj::Const::new {
    my ($class, $sv) = @_;
    my $obj = bless {
	flags =&gt; 0,
	sv =&gt; $sv    # holds the SV object until write_back happens
    }, $class;
    if ( ref($sv) eq  "B::SPECIAL" ){
	$obj-&gt;{type}= T_SPECIAL;	
    }else{
    	my $svflags = $sv-&gt;FLAGS;
    	if ($svflags &amp; SVf_IOK) {
		$obj-&gt;{flags} = VALID_INT|VALID_DOUBLE;
		$obj-&gt;{type} = T_INT;
                if ($svflags &amp; SVf_IVisUV){
                    $obj-&gt;{flags} |= VALID_UNSIGNED;
                    $obj-&gt;{nv} = $obj-&gt;{iv} = $sv-&gt;UVX;
                }else{
                    $obj-&gt;{nv} = $obj-&gt;{iv} = $sv-&gt;IV;
                }
    	} elsif ($svflags &amp; SVf_NOK) {
		$obj-&gt;{flags} = VALID_INT|VALID_DOUBLE;
		$obj-&gt;{type} = T_DOUBLE;
		$obj-&gt;{iv} = $obj-&gt;{nv} = $sv-&gt;NV;
    	} else {
		$obj-&gt;{type} = T_UNKNOWN;
    	}
    }
    return $obj;
}

sub B::Stackobj::Const::write_back {
    my $obj = shift;
    return if $obj-&gt;{flags} &amp; VALID_SV;
    # Save the SV object and replace $obj-&gt;{sv} by its C source code name
    $obj-&gt;{sv} = $obj-&gt;{sv}-&gt;save;
    $obj-&gt;{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
}

sub B::Stackobj::Const::load_int {
    my $obj = shift;
    if (ref($obj-&gt;{sv}) eq "B::RV"){
       $obj-&gt;{iv} = int($obj-&gt;{sv}-&gt;RV-&gt;PV);
    }else{
       $obj-&gt;{iv} = int($obj-&gt;{sv}-&gt;PV);
    }
    $obj-&gt;{flags} |= VALID_INT;
}

sub B::Stackobj::Const::load_double {
    my $obj = shift;
    if (ref($obj-&gt;{sv}) eq "B::RV"){
        $obj-&gt;{nv} = $obj-&gt;{sv}-&gt;RV-&gt;PV + 0.0;
    }else{
        $obj-&gt;{nv} = $obj-&gt;{sv}-&gt;PV + 0.0;
    }
    $obj-&gt;{flags} |= VALID_DOUBLE;
}

sub B::Stackobj::Const::invalidate {}

#
# Stackobj::Bool
#

@B::Stackobj::Bool::ISA = 'B::Stackobj';
sub B::Stackobj::Bool::new {
    my ($class, $preg) = @_;
    my $obj = bless {
	type =&gt; T_INT,
	flags =&gt; VALID_INT|VALID_DOUBLE,
	iv =&gt; $$preg,
	nv =&gt; $$preg,
	preg =&gt; $preg		# this holds our ref to the pseudo-reg
    }, $class;
    return $obj;
}

sub B::Stackobj::Bool::write_back {
    my $obj = shift;
    return if $obj-&gt;{flags} &amp; VALID_SV;
    $obj-&gt;{sv} = "($obj-&gt;{iv} ? &amp;PL_sv_yes : &amp;PL_sv_no)";
    $obj-&gt;{flags} |= VALID_SV;
}

# XXX Might want to handle as_double/set_double/load_double?

sub B::Stackobj::Bool::invalidate {}

1;

__END__

=head1 NAME

B::Stackobj - Helper module for CC backend

=head1 SYNOPSIS

	use B::Stackobj;

=head1 DESCRIPTION

See F&lt;ext/B/README&gt;.

=head1 AUTHOR

Malcolm Beattie, C&lt;mbeattie@sable.ox.ac.uk&gt;

=cut
</pre></body></html>