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 | #
|
---|
8 | package B::Stackobj;
|
---|
9 |
|
---|
10 | our $VERSION = '1.00';
|
---|
11 |
|
---|
12 | use 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 |
|
---|
20 | use Carp qw(confess);
|
---|
21 | use strict;
|
---|
22 | use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);
|
---|
23 |
|
---|
24 | # Types
|
---|
25 | sub T_UNKNOWN () { 0 }
|
---|
26 | sub T_DOUBLE () { 1 }
|
---|
27 | sub T_INT () { 2 }
|
---|
28 | sub T_SPECIAL () { 3 }
|
---|
29 |
|
---|
30 | # Flags
|
---|
31 | sub VALID_INT () { 0x01 }
|
---|
32 | sub VALID_UNSIGNED () { 0x02 }
|
---|
33 | sub VALID_DOUBLE () { 0x04 }
|
---|
34 | sub VALID_SV () { 0x08 }
|
---|
35 | sub REGISTER () { 0x10 } # no implicit write-back when calling subs
|
---|
36 | sub TEMPORARY () { 0x20 } # no implicit write-back needed at all
|
---|
37 | sub SAVE_INT () { 0x40 } #if int part needs to be saved at all
|
---|
38 | sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all
|
---|
39 |
|
---|
40 |
|
---|
41 | #
|
---|
42 | # Callback for runtime code generation
|
---|
43 | #
|
---|
44 | my $runtime_callback = sub { confess "set_callback not yet called" };
|
---|
45 | sub set_callback (&) { $runtime_callback = shift }
|
---|
46 | sub runtime { &$runtime_callback(@_) }
|
---|
47 |
|
---|
48 | #
|
---|
49 | # Methods
|
---|
50 | #
|
---|
51 |
|
---|
52 | sub write_back { confess "stack object does not implement write_back" }
|
---|
53 |
|
---|
54 | sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }
|
---|
55 |
|
---|
56 | sub 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 |
|
---|
65 | sub 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 |
|
---|
74 | sub 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 |
|
---|
83 | sub as_numeric {
|
---|
84 | my $obj = shift;
|
---|
85 | return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
|
---|
86 | }
|
---|
87 |
|
---|
88 | sub 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 | #
|
---|
102 | sub 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 |
|
---|
126 | sub 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 | #
|
---|
143 | sub 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 |
|
---|
151 | sub 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 |
|
---|
158 | sub 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 |
|
---|
167 | sub 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';
|
---|
179 | sub 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 |
|
---|
192 | sub 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 |
|
---|
202 | sub 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 | }
|
---|
208 | sub B::Stackobj::Padsv::save_int {
|
---|
209 | my $obj = shift;
|
---|
210 | return $obj->{flags} & SAVE_INT;
|
---|
211 | }
|
---|
212 |
|
---|
213 | sub B::Stackobj::Padsv::save_double {
|
---|
214 | my $obj = shift;
|
---|
215 | return $obj->{flags} & SAVE_DOUBLE;
|
---|
216 | }
|
---|
217 |
|
---|
218 | sub 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';
|
---|
241 | sub 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 |
|
---|
271 | sub 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 |
|
---|
279 | sub 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 |
|
---|
289 | sub 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 |
|
---|
299 | sub B::Stackobj::Const::invalidate {}
|
---|
300 |
|
---|
301 | #
|
---|
302 | # Stackobj::Bool
|
---|
303 | #
|
---|
304 |
|
---|
305 | @B::Stackobj::Bool::ISA = 'B::Stackobj';
|
---|
306 | sub 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 |
|
---|
318 | sub 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 |
|
---|
327 | sub B::Stackobj::Bool::invalidate {}
|
---|
328 |
|
---|
329 | 1;
|
---|
330 |
|
---|
331 | __END__
|
---|
332 |
|
---|
333 | =head1 NAME
|
---|
334 |
|
---|
335 | B::Stackobj - Helper module for CC backend
|
---|
336 |
|
---|
337 | =head1 SYNOPSIS
|
---|
338 |
|
---|
339 | use B::Stackobj;
|
---|
340 |
|
---|
341 | =head1 DESCRIPTION
|
---|
342 |
|
---|
343 | See F<ext/B/README>.
|
---|
344 |
|
---|
345 | =head1 AUTHOR
|
---|
346 |
|
---|
347 | Malcolm Beattie, C<[email protected]>
|
---|
348 |
|
---|
349 | =cut
|
---|