This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Initial check-in of perl compiler.
[perl5.git] / B / Stackobj.pm
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 use Exporter ();
10 @ISA = qw(Exporter);
11 @EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT
12                 VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
13 %EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
14                 flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
15                              REGISTER TEMPORARY)]);
16
17 use Carp qw(confess);
18 use strict;
19 use B qw(class);
20
21 # Perl internal constants that I should probably define elsewhere.
22 sub SVf_IOK () { 0x10000 }
23 sub SVf_NOK () { 0x20000 }
24
25 # Types
26 sub T_UNKNOWN () { 0 }
27 sub T_DOUBLE ()  { 1 }
28 sub T_INT ()     { 2 }
29
30 # Flags
31 sub VALID_INT ()        { 0x01 }
32 sub VALID_DOUBLE ()     { 0x02 }
33 sub VALID_SV ()         { 0x04 }
34 sub REGISTER ()         { 0x08 } # no implicit write-back when calling subs
35 sub TEMPORARY ()        { 0x10 } # no implicit write-back needed at all
36
37 #
38 # Callback for runtime code generation
39 #
40 my $runtime_callback = sub { confess "set_callback not yet called" };
41 sub set_callback (&) { $runtime_callback = shift }
42 sub runtime { &$runtime_callback(@_) }
43
44 #
45 # Methods
46 #
47
48 sub write_back { confess "stack object does not implement write_back" }
49
50 sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) }
51
52 sub as_sv {
53     my $obj = shift;
54     if (!($obj->{flags} & VALID_SV)) {
55         $obj->write_back;
56         $obj->{flags} |= VALID_SV;
57     }
58     return $obj->{sv};
59 }
60
61 sub as_int {
62     my $obj = shift;
63     if (!($obj->{flags} & VALID_INT)) {
64         $obj->load_int;
65         $obj->{flags} |= VALID_INT;
66     }
67     return $obj->{iv};
68 }
69
70 sub as_double {
71     my $obj = shift;
72     if (!($obj->{flags} & VALID_DOUBLE)) {
73         $obj->load_double;
74         $obj->{flags} |= VALID_DOUBLE;
75     }
76     return $obj->{nv};
77 }
78
79 sub as_numeric {
80     my $obj = shift;
81     return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
82 }
83
84 #
85 # Debugging methods
86 #
87 sub peek {
88     my $obj = shift;
89     my $type = $obj->{type};
90     my $flags = $obj->{flags};
91     my @flags;
92     if ($type == T_UNKNOWN) {
93         $type = "T_UNKNOWN";
94     } elsif ($type == T_INT) {
95         $type = "T_INT";
96     } elsif ($type == T_DOUBLE) {
97         $type = "T_DOUBLE";
98     } else {
99         $type = "(illegal type $type)";
100     }
101     push(@flags, "VALID_INT") if $flags & VALID_INT;
102     push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
103     push(@flags, "VALID_SV") if $flags & VALID_SV;
104     push(@flags, "REGISTER") if $flags & REGISTER;
105     push(@flags, "TEMPORARY") if $flags & TEMPORARY;
106     @flags = ("none") unless @flags;
107     return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
108                    class($obj), join("|", @flags));
109 }
110
111 sub minipeek {
112     my $obj = shift;
113     my $type = $obj->{type};
114     my $flags = $obj->{flags};
115     if ($type == T_INT || $flags & VALID_INT) {
116         return $obj->{iv};
117     } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
118         return $obj->{nv};
119     } else {
120         return $obj->{sv};
121     }
122 }
123
124 #
125 # Caller needs to ensure that set_int, set_double,
126 # set_numeric and set_sv are only invoked on legal lvalues.
127 #
128 sub set_int {
129     my ($obj, $expr) = @_;
130     runtime("$obj->{iv} = $expr;");
131     $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
132     $obj->{flags} |= VALID_INT;
133 }
134
135 sub set_double {
136     my ($obj, $expr) = @_;
137     runtime("$obj->{nv} = $expr;");
138     $obj->{flags} &= ~(VALID_SV | VALID_INT);
139     $obj->{flags} |= VALID_DOUBLE;
140 }
141
142 sub set_numeric {
143     my ($obj, $expr) = @_;
144     if ($obj->{type} == T_INT) {
145         $obj->set_int($expr);
146     } else {
147         $obj->set_double($expr);
148     }
149 }
150
151 sub set_sv {
152     my ($obj, $expr) = @_;
153     runtime("SvSetSV($obj->{sv}, $expr);");
154     $obj->invalidate;
155     $obj->{flags} |= VALID_SV;
156 }
157
158 #
159 # Stackobj::Padsv
160 #
161
162 @B::Stackobj::Padsv::ISA = 'B::Stackobj';
163 sub B::Stackobj::Padsv::new {
164     my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
165     bless {
166         type => $type,
167         flags => VALID_SV | $extra_flags,
168         sv => "curpad[$ix]",
169         iv => "$iname",
170         nv => "$dname"
171     }, $class;
172 }
173
174 sub B::Stackobj::Padsv::load_int {
175     my $obj = shift;
176     if ($obj->{flags} & VALID_DOUBLE) {
177         runtime("$obj->{iv} = $obj->{nv};");
178     } else {
179         runtime("$obj->{iv} = SvIV($obj->{sv});");
180     }
181     $obj->{flags} |= VALID_INT;
182 }
183
184 sub B::Stackobj::Padsv::load_double {
185     my $obj = shift;
186     runtime("$obj->{nv} = SvNV($obj->{sv});");
187     $obj->{flags} |= VALID_DOUBLE;
188 }
189
190 sub B::Stackobj::Padsv::write_back {
191     my $obj = shift;
192     my $flags = $obj->{flags};
193     return if $flags & VALID_SV;
194     if ($flags & VALID_INT) {
195         runtime("sv_setiv($obj->{sv}, $obj->{iv});");
196     } elsif ($flags & VALID_DOUBLE) {
197         runtime("sv_setnv($obj->{sv}, $obj->{nv});");
198     } else {
199         confess "write_back failed for lexical @{[$obj->peek]}\n";
200     }
201     $obj->{flags} |= VALID_SV;
202 }
203
204 #
205 # Stackobj::Const
206 #
207
208 @B::Stackobj::Const::ISA = 'B::Stackobj';
209 sub B::Stackobj::Const::new {
210     my ($class, $sv) = @_;
211     my $obj = bless {
212         flags => 0,
213         sv => $sv    # holds the SV object until write_back happens
214     }, $class;
215     my $svflags = $sv->FLAGS;
216     if ($svflags & SVf_IOK) {
217         $obj->{flags} = VALID_INT|VALID_DOUBLE;
218         $obj->{type} = T_INT;
219         $obj->{nv} = $obj->{iv} = $sv->IV;
220     } elsif ($svflags & SVf_NOK) {
221         $obj->{flags} = VALID_INT|VALID_DOUBLE;
222         $obj->{type} = T_DOUBLE;
223         $obj->{iv} = $obj->{nv} = $sv->NV;
224     } else {
225         $obj->{type} = T_UNKNOWN;
226     }
227     return $obj;
228 }
229
230 sub B::Stackobj::Const::write_back {
231     my $obj = shift;
232     return if $obj->{flags} & VALID_SV;
233     # Save the SV object and replace $obj->{sv} by its C source code name
234     $obj->{sv} = $obj->{sv}->save;
235     $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
236 }
237
238 sub B::Stackobj::Const::load_int {
239     my $obj = shift;
240     $obj->{iv} = int($obj->{sv}->PV);
241     $obj->{flags} |= VALID_INT;
242 }
243
244 sub B::Stackobj::Const::load_double {
245     my $obj = shift;
246     $obj->{nv} = $obj->{sv}->PV + 0.0;
247     $obj->{flags} |= VALID_DOUBLE;
248 }
249
250 sub B::Stackobj::Const::invalidate {}
251
252 #
253 # Stackobj::Bool
254 #
255
256 @B::Stackobj::Bool::ISA = 'B::Stackobj';
257 sub B::Stackobj::Bool::new {
258     my ($class, $preg) = @_;
259     my $obj = bless {
260         type => T_INT,
261         flags => VALID_INT|VALID_DOUBLE,
262         iv => $$preg,
263         nv => $$preg,
264         preg => $preg           # this holds our ref to the pseudo-reg
265     }, $class;
266     return $obj;
267 }
268
269 sub B::Stackobj::Bool::write_back {
270     my $obj = shift;
271     return if $obj->{flags} & VALID_SV;
272     $obj->{sv} = "($obj->{iv} ? &sv_yes : &sv_no)";
273     $obj->{flags} |= VALID_SV;
274 }
275
276 # XXX Might want to handle as_double/set_double/load_double?
277
278 sub B::Stackobj::Bool::invalidate {}
279
280 1;