1#      Stackobj.pm
2#
3#      Copyright (c) 1996 Malcolm Beattie
4#
5#      You may distribute under the terms of either the GNU General Public
6#      License or the Artistic License, as specified in the README file.
7#
8package B::Stackobj;
9
10our $VERSION = '1.00';
11
12use Exporter ();
13@ISA = qw(Exporter);
14@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
15		VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
16%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
17		flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
18			     VALID_UNSIGNED REGISTER TEMPORARY)]);
19
20use Carp qw(confess);
21use strict;
22use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);
23
24# Types
25sub T_UNKNOWN () { 0 }
26sub T_DOUBLE ()  { 1 }
27sub T_INT ()     { 2 }
28sub T_SPECIAL () { 3 }
29
30# Flags
31sub VALID_INT ()	{ 0x01 }
32sub VALID_UNSIGNED ()	{ 0x02 }
33sub VALID_DOUBLE ()	{ 0x04 }
34sub VALID_SV ()		{ 0x08 }
35sub REGISTER ()		{ 0x10 } # no implicit write-back when calling subs
36sub TEMPORARY ()	{ 0x20 } # no implicit write-back needed at all
37sub SAVE_INT () 	{ 0x40 } #if int part needs to be saved at all
38sub SAVE_DOUBLE () 	{ 0x80 } #if double part needs to be saved at all
39
40
41#
42# Callback for runtime code generation
43#
44my $runtime_callback = sub { confess "set_callback not yet called" };
45sub set_callback (&) { $runtime_callback = shift }
46sub runtime { &$runtime_callback(@_) }
47
48#
49# Methods
50#
51
52sub write_back { confess "stack object does not implement write_back" }
53
54sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }
55
56sub as_sv {
57    my $obj = shift;
58    if (!($obj->{flags} & VALID_SV)) {
59	$obj->write_back;
60	$obj->{flags} |= VALID_SV;
61    }
62    return $obj->{sv};
63}
64
65sub as_int {
66    my $obj = shift;
67    if (!($obj->{flags} & VALID_INT)) {
68	$obj->load_int;
69	$obj->{flags} |= VALID_INT|SAVE_INT;
70    }
71    return $obj->{iv};
72}
73
74sub as_double {
75    my $obj = shift;
76    if (!($obj->{flags} & VALID_DOUBLE)) {
77	$obj->load_double;
78	$obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
79    }
80    return $obj->{nv};
81}
82
83sub as_numeric {
84    my $obj = shift;
85    return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
86}
87
88sub as_bool {
89	my $obj=shift;
90	if ($obj->{flags} & VALID_INT ){
91		return $obj->{iv};
92	}
93	if ($obj->{flags} & VALID_DOUBLE ){
94		return $obj->{nv};
95	}
96	return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
97}
98
99#
100# Debugging methods
101#
102sub peek {
103    my $obj = shift;
104    my $type = $obj->{type};
105    my $flags = $obj->{flags};
106    my @flags;
107    if ($type == T_UNKNOWN) {
108	$type = "T_UNKNOWN";
109    } elsif ($type == T_INT) {
110	$type = "T_INT";
111    } elsif ($type == T_DOUBLE) {
112	$type = "T_DOUBLE";
113    } else {
114	$type = "(illegal type $type)";
115    }
116    push(@flags, "VALID_INT") if $flags & VALID_INT;
117    push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
118    push(@flags, "VALID_SV") if $flags & VALID_SV;
119    push(@flags, "REGISTER") if $flags & REGISTER;
120    push(@flags, "TEMPORARY") if $flags & TEMPORARY;
121    @flags = ("none") unless @flags;
122    return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
123		   class($obj), join("|", @flags));
124}
125
126sub minipeek {
127    my $obj = shift;
128    my $type = $obj->{type};
129    my $flags = $obj->{flags};
130    if ($type == T_INT || $flags & VALID_INT) {
131	return $obj->{iv};
132    } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
133	return $obj->{nv};
134    } else {
135	return $obj->{sv};
136    }
137}
138
139#
140# Caller needs to ensure that set_int, set_double,
141# set_numeric and set_sv are only invoked on legal lvalues.
142#
143sub set_int {
144    my ($obj, $expr,$unsigned) = @_;
145    runtime("$obj->{iv} = $expr;");
146    $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
147    $obj->{flags} |= VALID_INT|SAVE_INT;
148    $obj->{flags} |= VALID_UNSIGNED if $unsigned;
149}
150
151sub set_double {
152    my ($obj, $expr) = @_;
153    runtime("$obj->{nv} = $expr;");
154    $obj->{flags} &= ~(VALID_SV | VALID_INT);
155    $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
156}
157
158sub set_numeric {
159    my ($obj, $expr) = @_;
160    if ($obj->{type} == T_INT) {
161	$obj->set_int($expr);
162    } else {
163	$obj->set_double($expr);
164    }
165}
166
167sub set_sv {
168    my ($obj, $expr) = @_;
169    runtime("SvSetSV($obj->{sv}, $expr);");
170    $obj->invalidate;
171    $obj->{flags} |= VALID_SV;
172}
173
174#
175# Stackobj::Padsv
176#
177
178@B::Stackobj::Padsv::ISA = 'B::Stackobj';
179sub B::Stackobj::Padsv::new {
180    my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
181    $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
182    $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
183    bless {
184	type => $type,
185	flags => VALID_SV | $extra_flags,
186	sv => "PL_curpad[$ix]",
187	iv => "$iname",
188	nv => "$dname"
189    }, $class;
190}
191
192sub B::Stackobj::Padsv::load_int {
193    my $obj = shift;
194    if ($obj->{flags} & VALID_DOUBLE) {
195	runtime("$obj->{iv} = $obj->{nv};");
196    } else {
197	runtime("$obj->{iv} = SvIV($obj->{sv});");
198    }
199    $obj->{flags} |= VALID_INT|SAVE_INT;
200}
201
202sub B::Stackobj::Padsv::load_double {
203    my $obj = shift;
204    $obj->write_back;
205    runtime("$obj->{nv} = SvNV($obj->{sv});");
206    $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
207}
208sub B::Stackobj::Padsv::save_int {
209    my $obj = shift;
210    return $obj->{flags} & SAVE_INT;
211}
212
213sub B::Stackobj::Padsv::save_double {
214    my $obj = shift;
215    return $obj->{flags} & SAVE_DOUBLE;
216}
217
218sub B::Stackobj::Padsv::write_back {
219    my $obj = shift;
220    my $flags = $obj->{flags};
221    return if $flags & VALID_SV;
222    if ($flags & VALID_INT) {
223        if ($flags & VALID_UNSIGNED ){
224            runtime("sv_setuv($obj->{sv}, $obj->{iv});");
225        }else{
226            runtime("sv_setiv($obj->{sv}, $obj->{iv});");
227        }
228    } elsif ($flags & VALID_DOUBLE) {
229	runtime("sv_setnv($obj->{sv}, $obj->{nv});");
230    } else {
231	confess "write_back failed for lexical @{[$obj->peek]}\n";
232    }
233    $obj->{flags} |= VALID_SV;
234}
235
236#
237# Stackobj::Const
238#
239
240@B::Stackobj::Const::ISA = 'B::Stackobj';
241sub B::Stackobj::Const::new {
242    my ($class, $sv) = @_;
243    my $obj = bless {
244	flags => 0,
245	sv => $sv    # holds the SV object until write_back happens
246    }, $class;
247    if ( ref($sv) eq  "B::SPECIAL" ){
248	$obj->{type}= T_SPECIAL;
249    }else{
250    	my $svflags = $sv->FLAGS;
251    	if ($svflags & SVf_IOK) {
252		$obj->{flags} = VALID_INT|VALID_DOUBLE;
253		$obj->{type} = T_INT;
254                if ($svflags & SVf_IVisUV){
255                    $obj->{flags} |= VALID_UNSIGNED;
256                    $obj->{nv} = $obj->{iv} = $sv->UVX;
257                }else{
258                    $obj->{nv} = $obj->{iv} = $sv->IV;
259                }
260    	} elsif ($svflags & SVf_NOK) {
261		$obj->{flags} = VALID_INT|VALID_DOUBLE;
262		$obj->{type} = T_DOUBLE;
263		$obj->{iv} = $obj->{nv} = $sv->NV;
264    	} else {
265		$obj->{type} = T_UNKNOWN;
266    	}
267    }
268    return $obj;
269}
270
271sub B::Stackobj::Const::write_back {
272    my $obj = shift;
273    return if $obj->{flags} & VALID_SV;
274    # Save the SV object and replace $obj->{sv} by its C source code name
275    $obj->{sv} = $obj->{sv}->save;
276    $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
277}
278
279sub B::Stackobj::Const::load_int {
280    my $obj = shift;
281    if (ref($obj->{sv}) eq "B::RV"){
282       $obj->{iv} = int($obj->{sv}->RV->PV);
283    }else{
284       $obj->{iv} = int($obj->{sv}->PV);
285    }
286    $obj->{flags} |= VALID_INT;
287}
288
289sub B::Stackobj::Const::load_double {
290    my $obj = shift;
291    if (ref($obj->{sv}) eq "B::RV"){
292        $obj->{nv} = $obj->{sv}->RV->PV + 0.0;
293    }else{
294        $obj->{nv} = $obj->{sv}->PV + 0.0;
295    }
296    $obj->{flags} |= VALID_DOUBLE;
297}
298
299sub B::Stackobj::Const::invalidate {}
300
301#
302# Stackobj::Bool
303#
304
305@B::Stackobj::Bool::ISA = 'B::Stackobj';
306sub B::Stackobj::Bool::new {
307    my ($class, $preg) = @_;
308    my $obj = bless {
309	type => T_INT,
310	flags => VALID_INT|VALID_DOUBLE,
311	iv => $$preg,
312	nv => $$preg,
313	preg => $preg		# this holds our ref to the pseudo-reg
314    }, $class;
315    return $obj;
316}
317
318sub B::Stackobj::Bool::write_back {
319    my $obj = shift;
320    return if $obj->{flags} & VALID_SV;
321    $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
322    $obj->{flags} |= VALID_SV;
323}
324
325# XXX Might want to handle as_double/set_double/load_double?
326
327sub B::Stackobj::Bool::invalidate {}
328
3291;
330
331__END__
332
333=head1 NAME
334
335B::Stackobj - Helper module for CC backend
336
337=head1 SYNOPSIS
338
339	use B::Stackobj;
340
341=head1 DESCRIPTION
342
343See F<ext/B/README>.
344
345=head1 AUTHOR
346
347Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
348
349=cut
350