# 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.
@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
%EXPORT_TAGS = (types
=> [qw(T_UNKNOWN T_DOUBLE T_INT)],
flags
=> [qw(VALID_INT VALID_DOUBLE VALID_SV
VALID_UNSIGNED REGISTER TEMPORARY)]);
use B
qw(class SVf_IOK SVf_NOK SVf_IVisUV);
sub VALID_INT
() { 0x01 }
sub VALID_UNSIGNED
() { 0x02 }
sub VALID_DOUBLE
() { 0x04 }
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
(&) { $runtime_callback = shift }
sub runtime
{ &$runtime_callback(@_) }
sub write_back
{ confess
"stack object does not implement write_back" }
sub invalidate
{ shift->{flags
} &= ~(VALID_INT
|VALID_UNSIGNED
| VALID_DOUBLE
) }
if (!($obj->{flags
} & VALID_SV
)) {
$obj->{flags
} |= VALID_SV
;
if (!($obj->{flags
} & VALID_INT
)) {
$obj->{flags
} |= VALID_INT
|SAVE_INT
;
if (!($obj->{flags
} & VALID_DOUBLE
)) {
$obj->{flags
} |= VALID_DOUBLE
|SAVE_DOUBLE
;
return $obj->{type
} == T_INT ?
$obj->as_int : $obj->as_double;
if ($obj->{flags
} & VALID_INT
){
if ($obj->{flags
} & VALID_DOUBLE
){
return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
my $flags = $obj->{flags
};
if ($type == T_UNKNOWN
) {
} elsif ($type == T_INT
) {
} elsif ($type == T_DOUBLE
) {
$type = "(illegal type $type)";
push(@flags, "VALID_INT") if $flags & VALID_INT
;
push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE
;
push(@flags, "VALID_SV") if $flags & VALID_SV
;
push(@flags, "REGISTER") if $flags & REGISTER
;
push(@flags, "TEMPORARY") if $flags & TEMPORARY
;
@flags = ("none") unless @flags;
return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
class($obj), join("|", @flags));
my $flags = $obj->{flags
};
if ($type == T_INT
|| $flags & VALID_INT
) {
} elsif ($type == T_DOUBLE
|| $flags & VALID_DOUBLE
) {
# Caller needs to ensure that set_int, set_double,
# set_numeric and set_sv are only invoked on legal lvalues.
my ($obj, $expr,$unsigned) = @_;
runtime
("$obj->{iv} = $expr;");
$obj->{flags
} &= ~(VALID_SV
| VALID_DOUBLE
);
$obj->{flags
} |= VALID_INT
|SAVE_INT
;
$obj->{flags
} |= VALID_UNSIGNED
if $unsigned;
runtime
("$obj->{nv} = $expr;");
$obj->{flags
} &= ~(VALID_SV
| VALID_INT
);
$obj->{flags
} |= VALID_DOUBLE
|SAVE_DOUBLE
;
if ($obj->{type
} == T_INT
) {
runtime
("SvSetSV($obj->{sv}, $expr);");
$obj->{flags
} |= VALID_SV
;
@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 & VALID_INT
;
$extra_flags |= SAVE_DOUBLE
if $extra_flags & VALID_DOUBLE
;
flags
=> VALID_SV
| $extra_flags,
sub B
::Stackobj
::Padsv
::load_int
{
if ($obj->{flags
} & VALID_DOUBLE
) {
runtime
("$obj->{iv} = $obj->{nv};");
runtime
("$obj->{iv} = SvIV($obj->{sv});");
$obj->{flags
} |= VALID_INT
|SAVE_INT
;
sub B
::Stackobj
::Padsv
::load_double
{
runtime
("$obj->{nv} = SvNV($obj->{sv});");
$obj->{flags
} |= VALID_DOUBLE
|SAVE_DOUBLE
;
sub B
::Stackobj
::Padsv
::save_int
{
return $obj->{flags
} & SAVE_INT
;
sub B
::Stackobj
::Padsv
::save_double
{
return $obj->{flags
} & SAVE_DOUBLE
;
sub B
::Stackobj
::Padsv
::write_back
{
my $flags = $obj->{flags
};
return if $flags & VALID_SV
;
if ($flags & VALID_INT
) {
if ($flags & VALID_UNSIGNED
){
runtime
("sv_setuv($obj->{sv}, $obj->{iv});");
runtime
("sv_setiv($obj->{sv}, $obj->{iv});");
} elsif ($flags & VALID_DOUBLE
) {
runtime
("sv_setnv($obj->{sv}, $obj->{nv});");
confess
"write_back failed for lexical @{[$obj->peek]}\n";
$obj->{flags
} |= VALID_SV
;
@B::Stackobj
::Const
::ISA
= 'B::Stackobj';
sub B
::Stackobj
::Const
::new
{
sv
=> $sv # holds the SV object until write_back happens
if ( ref($sv) eq "B::SPECIAL" ){
my $svflags = $sv->FLAGS;
if ($svflags & SVf_IOK
) {
$obj->{flags
} = VALID_INT
|VALID_DOUBLE
;
if ($svflags & SVf_IVisUV
){
$obj->{flags
} |= VALID_UNSIGNED
;
$obj->{nv
} = $obj->{iv
} = $sv->UVX;
$obj->{nv
} = $obj->{iv
} = $sv->IV;
} elsif ($svflags & SVf_NOK
) {
$obj->{flags
} = VALID_INT
|VALID_DOUBLE
;
$obj->{iv
} = $obj->{nv
} = $sv->NV;
$obj->{type
} = T_UNKNOWN
;
sub B
::Stackobj
::Const
::write_back
{
return if $obj->{flags
} & VALID_SV
;
# Save the SV object and replace $obj->{sv} by its C source code name
$obj->{sv
} = $obj->{sv
}->save;
$obj->{flags
} |= VALID_SV
|VALID_INT
|VALID_DOUBLE
;
sub B
::Stackobj
::Const
::load_int
{
if (ref($obj->{sv
}) eq "B::RV"){
$obj->{iv
} = int($obj->{sv
}->RV->PV);
$obj->{iv
} = int($obj->{sv
}->PV);
$obj->{flags
} |= VALID_INT
;
sub B
::Stackobj
::Const
::load_double
{
if (ref($obj->{sv
}) eq "B::RV"){
$obj->{nv
} = $obj->{sv
}->RV->PV + 0.0;
$obj->{nv
} = $obj->{sv
}->PV + 0.0;
$obj->{flags
} |= VALID_DOUBLE
;
sub B
::Stackobj
::Const
::invalidate
{}
@B::Stackobj
::Bool
::ISA
= 'B::Stackobj';
sub B
::Stackobj
::Bool
::new
{
flags
=> VALID_INT
|VALID_DOUBLE
,
preg
=> $preg # this holds our ref to the pseudo-reg
sub B
::Stackobj
::Bool
::write_back
{
return if $obj->{flags
} & VALID_SV
;
$obj->{sv
} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
$obj->{flags
} |= VALID_SV
;
# XXX Might want to handle as_double/set_double/load_double?
sub B
::Stackobj
::Bool
::invalidate
{}
B::Stackobj - Helper module for CC backend
Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>