File Coverage

blib/lib/MarpaX/Languages/ECMAScript/AST/Grammar/ECMAScript_262_5/StringNumericLiteral/NativeNumberSemantics.pm
Criterion Covered Total %
statement 18 145 12.4
branch 0 58 0.0
condition 0 23 0.0
subroutine 6 51 11.7
pod 45 45 100.0
total 69 322 21.4


line stmt bran cond sub pod time code
1 1     1   4 use strict;
  1         2  
  1         29  
2 1     1   4 use warnings FATAL => 'all';
  1         1  
  1         39  
3              
4             package MarpaX::Languages::ECMAScript::AST::Grammar::ECMAScript_262_5::StringNumericLiteral::NativeNumberSemantics;
5 1     1   835 use Data::Float qw/have_signed_zero have_infinite have_nan/;
  1         8105  
  1         153  
6 1     1   1646 use Math::BigFloat;
  1         21823  
  1         7  
7 1     1   47193 use Scalar::Util qw/blessed/;
  1         4  
  1         68  
8 1     1   878 use Scalar::Util::Numeric qw/isinf isnan/;
  1         836  
  1         2490  
9              
10             our $POS_ZERO = have_signed_zero() ? Data::Float::pos_zero() : 0;
11             our $NEG_ZERO = have_signed_zero() ? Data::Float::neg_zero() : 0;
12             our $POS_INF = have_infinite() ? Data::Float::pos_infinity() : Math::BigFloat->binf();
13             our $NEG_INF = have_infinite() ? Data::Float::neg_infinity() : Math::BigFloat->binf('-');
14             our $POS_ONE = +1;
15             our $NEG_ONE = -1;
16             our $NAN = have_nan() ? Data::Float::nan() : Math::BigFloat->bnan();
17             our $UNDEF = undef;
18              
19             # ABSTRACT: ECMAScript 262, Edition 5, lexical string numeric grammar default semantics package, using native perl representations
20              
21             our $VERSION = '0.018'; # VERSION
22              
23              
24              
25             sub new {
26 0     0 1   my ($class, %opts) = @_;
27             my $self = {_number => $opts{number} // 0,
28             _length => $opts{length} // 0,
29 0   0       _decimal => $opts{decimal } // 0};
      0        
      0        
30 0           bless($self, $class);
31 0           return $self;
32             }
33              
34              
35             sub clone_init {
36 0     0 1   my ($self) = @_;
37 0           return (ref $self)->new();
38             }
39              
40              
41             sub clone {
42 0     0 1   my ($self) = @_;
43 0           return (ref $self)->new(number => $self->{_number}, length => $self->{_length}, decimal => $self->{_decimal});
44             }
45              
46              
47             sub decimalOn {
48 0     0 1   $_[0]->{_decimal} = 1;
49 0           return $_[0];
50             }
51              
52              
53             sub mul {
54 0     0 1   $_[0]->{_number} *= $_[1]->{_number};
55 0           return $_[0];
56             }
57              
58              
59             sub div {
60 0     0 1   $_[0]->{_number} /= $_[1]->{_number};
61 0           return $_[0];
62             }
63              
64              
65             sub mod {
66 0     0 1   $_[0]->{_number} %= $_[1]->{_number};
67 0           return $_[0];
68             }
69              
70              
71             sub nan {
72 0     0 1   $_[0]->{_number} = $NAN;
73 0           return $_[0];
74             }
75              
76              
77             sub pos_one {
78 0     0 1   $_[0]->{_number} = $POS_ONE;
79 0           return $_[0];
80             }
81              
82              
83             sub neg_one {
84 0     0 1   $_[0]->{_number} = $NEG_ONE;
85 0           return $_[0];
86             }
87              
88              
89             sub pos_zero {
90 0     0 1   $_[0]->{_number} = $POS_ZERO;
91 0           return $_[0];
92             }
93              
94              
95             sub neg_zero {
96 0     0 1   $_[0]->{_number} = $NEG_ZERO;
97 0           return $_[0];
98             }
99              
100              
101             sub pos_inf {
102 0     0 1   $_[0]->{_number} = $POS_INF;
103 0           return $_[0];
104             }
105              
106              
107             sub neg_inf {
108 0     0 1   $_[0]->{_number} = $NEG_INF;
109 0           return $_[0];
110             }
111              
112              
113             sub pow {
114 0     0 1   $_[0]->{_number} **= $_[1]->{_number};
115 0           return $_[0];
116             }
117              
118              
119             sub and {
120 0     0 1   $_[0]->{_number} &= $_[1]->{_number};
121 0           return $_[0];
122             }
123              
124              
125             sub or {
126 0     0 1   $_[0]->{_number} |= $_[1]->{_number};
127 0           return $_[0];
128             }
129              
130              
131             sub xor {
132 0     0 1   $_[0]->{_number} ^= $_[1]->{_number};
133 0           return $_[0];
134             }
135              
136              
137             sub not {
138 0     0 1   $_[0]->{_number} = ~$_[0]->{_number};
139 0           return $_[0];
140             }
141              
142              
143             sub sqrt {
144 0     0 1   my $x = eval {sqrt($_[0]->{_number})};
  0            
145 0 0         if ($@) {
146 0           return $_[0]->nan();
147             }
148 0           return $_[0];
149             }
150              
151              
152             sub left_shift {
153 0     0 1   $_[0]->{_number} <<= $_[1]->{_number};
154 0           return $_[0];
155             }
156              
157              
158             sub right_shift {
159 0     0 1   $_[0]->{_number} >>= $_[1]->{_number};
160 0           return $_[0];
161             }
162              
163              
164             sub inc {
165 0     0 1   $_[0]->{_number} += 1;
166 0           return $_[0];
167             }
168              
169              
170             sub dec {
171 0     0 1   $_[0]->{_number} -= 1;
172 0           return $_[0];
173             }
174              
175              
176             sub int {
177 0     0 1   $_[0]->{_number} = CORE::int("$_[1]");
178 0           $_[0]->{_length} = length("$_[1]");
179 0           return $_[0];
180             }
181              
182              
183             sub hex {
184 0     0 1   $_[0]->{_number} = CORE::hex("$_[1]");
185 0           return $_[0];
186             }
187              
188              
189             sub neg {
190 0     0 1   $_[0]->{_number} *= -1;
191 0           return $_[0];
192             }
193              
194              
195             sub abs {
196 0     0 1   $_[0]->{_number} = CORE::abs($_[0]->{_number});
197 0           return $_[0];
198             }
199              
200              
201             sub new_from_sign {
202 0 0   0 1   if ($_[0]->is_nan) {
    0          
203 0           return $_[0]->clone_init->nan;
204             }
205             elsif ($_[0]->is_pos) {
206 0           return $_[0]->clone_init->pos_one;
207             }
208             else {
209 0           return $_[0]->clone_init->neg_one;
210             }
211             }
212              
213              
214             sub new_from_cmp {
215 0 0 0 0 1   if ($_[0]->is_nan || $_[1]->is_nan) {
216 0           return $_[0]->clone_init->nan;
217             }
218             else {
219 0           my $tmp = $_[0]->clone->sub($_[1]);
220 0 0         if ($tmp->is_zero) {
    0          
221 0           return $_[0]->clone_init->pos_zero;
222             }
223             elsif ($tmp->is_neg) {
224 0           return $_[0]->clone_init->neg_one;
225             }
226             else {
227 0           return $_[0]->clone_init->pos_one;
228             }
229             }
230             }
231              
232              
233             sub add {
234 0     0 1   $_[0]->{_number} += $_[1]->{_number};
235 0           return $_[0];
236             }
237              
238              
239             sub sub {
240 0     0 1   $_[0]->{_number} -= $_[1]->{_number};
241 0           return $_[0];
242             }
243              
244              
245             sub inc_length {
246 0     0 1   ++$_[0]->{_length};
247 0           return $_[0];
248             }
249              
250              
251             sub new_from_length {
252 0     0 1   return $_[0]->clone_init->int("$_[0]->{_length}");
253             }
254              
255              
256             sub sign {
257 0 0   0 1   if ($_[0]->is_zero) {
    0          
    0          
258 0           return 0;
259             }
260             elsif ($_[0]->is_pos) {
261 0           return 1;
262             }
263             elsif ($_[0]->is_neg) {
264 0           return -1;
265             }
266             else {
267 0           return undef;
268             }
269             }
270              
271              
272             sub cmp {
273 0     0 1   return $_[0]->new_from_cmp($_[1])->sign;
274             }
275              
276              
277             sub host_number {
278 0     0 1   return $_[0]->{_number};
279             }
280              
281              
282             sub host_value {
283             #
284             # This is native implementation, i.e. we assume that the Math and/or CPUs under the hood
285             # are already IEEE-754 compliant, including rounding.
286             #
287             # This mean that we return internal number as is.
288             #
289 0     0 1   return $_[0]->{_number};
290             }
291              
292              
293             sub is_zero {
294 0   0 0 1   my $blessed = blessed($_[0]->{_number}) || '';
295 0 0         if (! $blessed) {
    0          
296             #
297             # float_is_zero never fails
298             #
299 0           return Data::Float::float_is_zero($_[0]->{_number});
300             } elsif ($_[0]->{_number}->can('is_zero')) {
301 0           return $_[0]->{_number}->is_zero();
302             } else {
303 0           return $UNDEF;
304             }
305             }
306              
307              
308             sub is_pos_one {
309 0   0 0 1   my $blessed = blessed($_[0]->{_number}) || '';
310 0 0         if (! $blessed) {
    0          
311 0 0         return ($_[0]->{_number} == $POS_ONE) ? 1 : 0;
312             } elsif ($_[0]->{_number}->can('is_one')) {
313 0           return $_[0]->{_number}->is_one();
314             } else {
315 0           return $UNDEF;
316             }
317             }
318              
319              
320             sub is_neg_one {
321 0   0 0 1   my $blessed = blessed($_[0]->{_number}) || '';
322 0 0         if (! $blessed) {
    0          
323 0 0         return ($_[0]->{_number} == $NEG_ONE) ? 1 : 0;
324             } elsif ($_[0]->{_number}->can('is_one')) {
325 0           return $_[0]->{_number}->is_one('-');
326             } else {
327 0           return $UNDEF;
328             }
329             }
330              
331              
332             sub is_pos {
333 0   0 0 1   my $blessed = blessed($_[0]->{_number}) || '';
334 0 0         if (! $blessed) {
    0          
335 0 0         if ($_[0]->is_nan) {
336 0           return 0;
337             } else {
338 0 0         return (Data::Float::signbit($_[0]->{_number}) == 0) ? 1 : 0;
339             }
340             } elsif ($_[0]->{_number}->can('is_pos')) {
341 0           return $_[0]->{_number}->is_pos();
342             } else {
343 0           return $UNDEF;
344             }
345             }
346              
347              
348             sub is_neg {
349 0   0 0 1   my $blessed = blessed($_[0]->{_number}) || '';
350 0 0         if (! $blessed) {
    0          
351 0 0         if ($_[0]->is_nan) {
352 0           return 0;
353             } else {
354 0 0         return (Data::Float::signbit($_[0]->{_number}) == 0) ? 0 : 1;
355             }
356             } elsif ($_[0]->{_number}->can('is_neg')) {
357 0           return $_[0]->{_number}->is_neg();
358             } else {
359 0           return $UNDEF;
360             }
361             }
362              
363              
364             sub is_inf {
365 0   0 0 1   my $blessed = blessed($_[0]->{_number}) || '';
366 0 0         if (! $blessed) {
    0          
367             #
368             # isinf() never fails
369             #
370 0           return isinf($_[0]->{_number});
371             } elsif ($_[0]->{_number}->can('is_inf')) {
372 0           return $_[0]->{_number}->is_inf();
373             } else {
374 0           return $UNDEF;
375             }
376             }
377              
378              
379             sub is_nan {
380 0   0 0 1   my $blessed = blessed($_[0]->{_number}) || '';
381 0 0         if (! $blessed) {
    0          
382             #
383             # isnan() never fails
384             #
385 0           return isnan($_[0]->{_number});
386             } elsif ($_[0]->{_number}->can('is_nan')) {
387 0           return $_[0]->{_number}->is_nan();
388             } else {
389 0           return $UNDEF;
390             }
391             }
392              
393             1;
394              
395             __END__