← Back to branch summary

~ubuntu-branches/ubuntu/vivid/nqp/vivid-proposed

« back to all changes in this revision

Viewing changes to src/HLL/sprintf.nqp

  • Committer: Package Import Robot
  • Author(s): Alessandro Ghedini
  • Date: 2013-11-01 12:09:18 UTC
  • mfrom: (1.1.4)
  • Revision ID: package-import@ubuntu.com-20131101120918-kx51sl0sxl3exsxi
Tags: 2013.10-1
* New upstream release
* Bump versioned (Build-)Depends on parrot
* Update patches
* Install new README.pod
* Fix vcs-field-not-canonical
* Do not install rubyish examples
* Do not Depends on parrot-devel anymore
* Add 07_disable-serialization-tests.patch

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/HLL/sprintf.nqp
 
1
my module sprintf {
 
2
    my @handlers;
 
3
    my $assert_used_args;
 
4
 
 
5
    grammar Syntax {
 
6
        token TOP {
 
7
            :my $*ARGS_USED := 0;
 
8
            ^ <statement>* $
 
9
        }
 
10
        
 
11
        method panic($msg) { nqp::die($msg) }
 
12
        
 
13
        token statement {
 
14
            [
 
15
            | <?[%]> [ [ <directive> | <escape> ]
 
16
                || <.panic("'" ~ nqp::substr(self.orig,1) ~ "' is not valid in sprintf format sequence '" ~ self.orig ~ "'")> ]
 
17
            | <![%]> <literal>
 
18
            ]
 
19
        }
 
20
 
 
21
        proto token directive { <...> }
 
22
        token directive:sym<b> { '%' <idx>? <flags>* <size>? [ '.' <precision=.size> ]? $<sym>=<[bB]> }
 
23
        token directive:sym<c> { '%' <idx>? <flags>* <size>? <sym> }
 
24
        token directive:sym<d> { '%' <idx>? <flags>* <size>? [ '.' <precision=.size> ]? $<sym>=<[di]> }
 
25
        token directive:sym<e> { '%' <idx>? <flags>* <size>? [ '.' <precision=.size> ]? $<sym>=<[eE]> }
 
26
        token directive:sym<f> { '%' <idx>? <flags>* <size>? [ '.' <precision=.size> ]? $<sym>=<[fF]> }
 
27
        token directive:sym<g> { '%' <idx>? <flags>* <size>? [ '.' <precision=.size> ]? $<sym>=<[gG]> }
 
28
        token directive:sym<o> { '%' <idx>? <flags>* <size>? [ '.' <precision=.size> ]? <sym> }
 
29
        token directive:sym<s> { '%' <idx>? <flags>* <size>? [ '.' <precision=.size> ]? <sym> }
 
30
        token directive:sym<u> { '%' <idx>? <flags>* <size>? <sym> }
 
31
        token directive:sym<x> { '%' <idx>? <flags>* <size>? [ '.' <precision=.size> ]? $<sym>=<[xX]> }
 
32
 
 
33
        proto token escape { <...> }
 
34
        token escape:sym<%> { '%' <flags>* <size>? <sym> }
 
35
        
 
36
        token literal { <-[%]>+ }
 
37
        
 
38
        token idx {
 
39
            $<param_index>=[\d+] '$'
 
40
        }
 
41
        
 
42
        token flags {
 
43
            | $<space> = ' '
 
44
            | $<plus>  = '+'
 
45
            | $<minus> = '-'
 
46
            | $<zero>  = '0'
 
47
            | $<hash>  = '#'
 
48
        }
 
49
        
 
50
        token size {
 
51
            \d* | $<star>='*'
 
52
        }
 
53
    }
 
54
 
 
55
    class Actions {
 
56
        my $knowhow := nqp::knowhow().new_type(:repr("P6bigint"));
 
57
        my $zero    := nqp::box_i(0, $knowhow);
 
58
        method TOP($/) {
 
59
            my @statements;
 
60
            @statements.push( $_.ast ) for $<statement>;
 
61
 
 
62
            if $assert_used_args && $*ARGS_USED < +@*ARGS_HAVE {
 
63
                nqp::die("Too few directives: found $*ARGS_USED,"
 
64
                ~ " fewer than the " ~ +@*ARGS_HAVE ~ " arguments after the format string")
 
65
            }
 
66
            if $*ARGS_USED > +@*ARGS_HAVE {
 
67
                nqp::die("Too many directives: found $*ARGS_USED, but "
 
68
                ~ (+@*ARGS_HAVE > 0 ?? "only " ~ +@*ARGS_HAVE !! "no")
 
69
                ~ " arguments after the format string")
 
70
            }
 
71
            make nqp::join('', @statements);
 
72
        }
 
73
 
 
74
        sub infix_x($s, $n) {
 
75
            my @strings;
 
76
            my $i := 0;
 
77
            @strings.push($s) while $i++ < $n;
 
78
            nqp::join('', @strings);
 
79
        }
 
80
 
 
81
        sub next_argument($/) {
 
82
            if $<idx> {
 
83
                $assert_used_args := 0;
 
84
                @*ARGS_HAVE[$<idx>.ast]
 
85
            }
 
86
            else {
 
87
                @*ARGS_HAVE[$*ARGS_USED++]
 
88
            }
 
89
        }
 
90
 
 
91
        sub intify($number_representation) {
 
92
            for @handlers -> $handler {
 
93
                if $handler.mine($number_representation) {
 
94
                    return $handler.int($number_representation);
 
95
                }
 
96
            }
 
97
 
 
98
            if nqp::isint($number_representation) {
 
99
                nqp::box_i($number_representation, $knowhow);
 
100
            } else {
 
101
                if nqp::isnum($number_representation)
 
102
                || nqp::isstr($number_representation) {
 
103
                    if $number_representation > 0 {
 
104
                        nqp::fromnum_I(nqp::floor_n($number_representation), $knowhow);
 
105
                    }
 
106
                    else {
 
107
                        nqp::fromnum_I(nqp::ceil_n($number_representation), $knowhow);
 
108
                    }
 
109
                } else {
 
110
                    $number_representation;
 
111
                }
 
112
            }
 
113
        }
 
114
 
 
115
        sub padding_char($st) {
 
116
            my $padding_char := ' ';
 
117
            if (!$st<precision> && !has_flag($st, 'minus'))
 
118
            || $st<sym> ~~ /<[eEfFgG]>/ {
 
119
                $padding_char := '0' if $_<zero> for $st<flags>;
 
120
            }
 
121
            $padding_char
 
122
        }
 
123
 
 
124
        sub has_flag($st, $key) {
 
125
            my $ok := 0;
 
126
            if $st<flags> {
 
127
                $ok := 1 if $_{$key} for $st<flags>
 
128
            }
 
129
            $ok
 
130
        }
 
131
 
 
132
        method statement($/){
 
133
            my $st;
 
134
            if $<directive> { $st := $<directive> }
 
135
            elsif $<escape> { $st := $<escape> }
 
136
            else { $st := $<literal> }
 
137
            my @pieces;
 
138
            @pieces.push: infix_x(padding_char($st), $st<size>.ast - nqp::chars($st.ast)) if $st<size>;
 
139
            has_flag($st, 'minus')
 
140
                ?? @pieces.unshift: $st.ast
 
141
                !! @pieces.push:    $st.ast;
 
142
            make join('', @pieces)
 
143
        }
 
144
 
 
145
        method directive:sym<b>($/) {
 
146
            my $int := intify(next_argument($/));
 
147
            $int := nqp::base_I($int, 2);
 
148
            my $pre := ($<sym> eq 'b' ?? '0b' !! '0B') if $int && has_flag($/, 'hash');
 
149
            if nqp::chars($<precision>) {
 
150
                $int := '' if $<precision>.ast == 0 && $int == 0;
 
151
                $int := $pre ~ infix_x('0', $<precision>.ast - nqp::chars($int)) ~ $int;
 
152
            }
 
153
            else {
 
154
                $int := $pre ~ $int
 
155
            }
 
156
            make $int;
 
157
        }
 
158
        method directive:sym<c>($/) {
 
159
            make nqp::chr(next_argument($/))
 
160
        }
 
161
 
 
162
        method directive:sym<d>($/) {
 
163
            my $int := intify(next_argument($/));
 
164
            my $pad := padding_char($/);
 
165
            my $sign := nqp::islt_I($int, $zero) ?? '-'
 
166
                !! has_flag($/, 'plus')
 
167
                    ?? '+' !! '';
 
168
            $int := nqp::tostr_I(nqp::abs_I($int, $knowhow));
 
169
            $int := nqp::substr($int, 0, $<precision>.ast) if nqp::chars($<precision>);
 
170
            if $pad ne ' ' && $<size> {
 
171
                $int := $sign ~ infix_x($pad, $<size>.ast - nqp::chars($int) - 1) ~ $int;
 
172
            }
 
173
            else {
 
174
                $int := $sign ~ $int;
 
175
            }
 
176
            make $int
 
177
        }
 
178
 
 
179
        sub pad-with-sign($sign, $num, $size, $pad) {
 
180
            if $pad ne ' ' && $size {
 
181
                $sign ~ infix_x($pad, $size - nqp::chars($num) - 1) ~ $num;
 
182
            } else {
 
183
                $sign ~ $num;
 
184
            }
 
185
        }
 
186
        sub stringify-to-precision($float, $precision) {
 
187
            $float := nqp::abs_n($float);
 
188
            my $lhs := nqp::floor_n($float);
 
189
            my $rhs := $float - $lhs;
 
190
 
 
191
            my $int := nqp::fromnum_I($lhs, $knowhow);
 
192
            $lhs := nqp::tostr_I($int);
 
193
 
 
194
            $float := $rhs + 1;
 
195
            $float := $float * nqp::pow_n(10, $precision);
 
196
            $float := ~nqp::floor_n($float + 0.5);
 
197
            $float := $float - nqp::pow_n(10, $precision);
 
198
 
 
199
            $rhs := infix_x('0', $precision - nqp::chars($float)) ~ $float;
 
200
            $rhs := nqp::substr($rhs, nqp::chars($rhs) - $precision);
 
201
 
 
202
            $lhs ~ '.' ~ $rhs;
 
203
        }
 
204
        sub stringify-to-precision2($float, $precision) {
 
205
            my $exp := $float == 0.0 ?? 0 !! nqp::floor_n(nqp::log_n($float) / nqp::log_n(10));
 
206
            $float := nqp::abs_n($float) * nqp::pow_n(10, $precision - ($exp + 1)) + 0.5;
 
207
            $float := nqp::floor_n($float);
 
208
            $float := $float / nqp::pow_n(10, $precision - ($exp + 1));
 
209
#?if jvm
 
210
            if $exp == -4 {
 
211
                $float := stringify-to-precision($float, $precision + 3);
 
212
                $float := nqp::substr($float, 0, nqp::chars($float) - 1) if nqp::chars($float) > 1 && $float ~~ /\.\d**4 0+$/;
 
213
                $float := nqp::substr($float, 0, nqp::chars($float) - 1) if nqp::chars($float) > 1 && $float ~~ /\.\d**4 0+$/;
 
214
            }
 
215
            $float
 
216
#?endif
 
217
        }
 
218
        sub fixed-point($float, $precision, $size, $pad) {
 
219
            my $sign := $float < 0 ?? '-' !! '';
 
220
            $float := stringify-to-precision(nqp::abs_n($float), $precision);
 
221
            pad-with-sign($sign, $float, $size, $pad);
 
222
        }
 
223
        sub scientific($float, $e, $precision, $size, $pad) {
 
224
            my $sign := $float < 0 ?? '-' !! '';
 
225
            $float := nqp::abs_n($float);
 
226
            my $exp := $float == 0.0 ?? 0 !! nqp::floor_n(nqp::log_n($float) / nqp::log_n(10));
 
227
            $float := $float / nqp::pow_n(10, $exp);
 
228
            $float := stringify-to-precision($float, $precision);
 
229
            if $exp < 0 {
 
230
                $exp := -$exp;
 
231
                $float := $float ~ $e ~ '-' ~ ($exp < 10 ?? '0' !! '') ~ $exp;
 
232
            } else {
 
233
                $float := $float ~ $e ~ '+' ~ ($exp < 10 ?? '0' !! '') ~ $exp;
 
234
            }
 
235
            pad-with-sign($sign, $float, $size, $pad);
 
236
        }
 
237
        sub shortest($float, $e, $precision, $size, $pad) {
 
238
            my $sign := $float < 0 ?? '-' !! '';
 
239
            $float := nqp::abs_n($float);
 
240
 
 
241
            my $exp := $float == 0.0 ?? 0 !! nqp::floor_n(nqp::log_n($float) / nqp::log_n(10));
 
242
 
 
243
            if -2 - $precision < $exp && $exp < $precision {
 
244
                my $fixed-precision := $exp > $precision ?? 0 !! $precision - ($exp + 1);
 
245
                my $fixed := stringify-to-precision2($float, $precision);
 
246
                pad-with-sign($sign, $fixed, $size, $pad);
 
247
            } else {
 
248
                $float := $float / nqp::pow_n(10, $exp);
 
249
                $float := stringify-to-precision2($float, $precision);
 
250
                my $sci;
 
251
                if $exp < 0 {
 
252
                    $exp := -$exp;
 
253
                    $sci := $float ~ $e ~ '-' ~ ($exp < 10 ?? '0' !! '') ~ $exp;
 
254
                } else {
 
255
                    $sci := $float ~ $e ~ '+' ~ ($exp < 10 ?? '0' !! '') ~ $exp;
 
256
                }
 
257
                
 
258
                pad-with-sign($sign, $sci, $size, $pad);
 
259
            }
 
260
        }
 
261
 
 
262
        method directive:sym<e>($/) {
 
263
            my $float := next_argument($/);
 
264
            my $precision := $<precision> ?? $<precision>.ast !! 6;
 
265
            my $pad := padding_char($/);
 
266
            my $size := $<size> ?? $<size>.ast !! 0;
 
267
            make scientific($float, $<sym>, $precision, $size, $pad);
 
268
        }
 
269
        method directive:sym<f>($/) {
 
270
            my $int := next_argument($/);
 
271
            my $precision := $<precision> ?? $<precision>.ast !! 6;
 
272
            my $pad := padding_char($/);
 
273
            my $size := $<size> ?? $<size>.ast !! 0;
 
274
            make fixed-point($int, $precision, $size, $pad);
 
275
        }
 
276
        method directive:sym<g>($/) {
 
277
            my $float := next_argument($/);
 
278
            my $precision := $<precision> ?? $<precision>.ast !! 6;
 
279
            my $pad := padding_char($/);
 
280
            my $size := $<size> ?? $<size>.ast !! 0;
 
281
            make shortest($float, $<sym> eq 'G' ?? 'E' !! 'e', $precision, $size, $pad);
 
282
        }
 
283
        method directive:sym<o>($/) {
 
284
            my $int := intify(next_argument($/));
 
285
            $int := nqp::base_I($int, 8);
 
286
            my $pre := '0' if $int && has_flag($/, 'hash');
 
287
            if nqp::chars($<precision>) {
 
288
                $int := '' if $<precision>.ast == 0 && $int == 0;
 
289
                $int := $pre ~ infix_x('0', intify($<precision>.ast) - nqp::chars($int)) ~ $int;
 
290
            }
 
291
            else {
 
292
                $int := $pre ~ $int
 
293
            }
 
294
            make $int
 
295
        }
 
296
 
 
297
        method directive:sym<s>($/) {
 
298
            my $string := next_argument($/);
 
299
            if nqp::chars($<precision>) && nqp::chars($string) > $<precision>.ast {
 
300
                $string := nqp::substr($string, 0, $<precision>.ast);
 
301
            }
 
302
            make $string
 
303
        }
 
304
        # XXX: Should we emulate an upper limit, like 2**64?
 
305
        # XXX: Should we emulate p5 behaviour for negative values passed to %u ?
 
306
        method directive:sym<u>($/) {
 
307
            my $int := intify(next_argument($/));
 
308
            if nqp::islt_I($int, $zero) {
 
309
                    my $err := nqp::getstderr();
 
310
                    nqp::printfh($err, "negative value '" 
 
311
                                    ~ $int
 
312
                                    ~ "' for %u in sprintf");
 
313
                    $int := 0;
 
314
            }
 
315
 
 
316
            # Go through tostr_I to avoid scientific notation.
 
317
            make nqp::tostr_I($int)
 
318
        }
 
319
        method directive:sym<x>($/) {
 
320
            my $int := intify(next_argument($/));
 
321
            $int := nqp::base_I($int, 16);
 
322
            my $pre := '0X' if $int && has_flag($/, 'hash');
 
323
            if nqp::chars($<precision>) {
 
324
                $int := '' if $<precision>.ast == 0 && $int == 0;
 
325
                $int := $pre ~ infix_x('0', $<precision>.ast - nqp::chars($int)) ~ $int;
 
326
            }
 
327
            else {
 
328
                $int := $pre ~ $int
 
329
            }
 
330
            make $<sym> eq 'x' ?? nqp::lc($int) !! $int
 
331
        }
 
332
 
 
333
        method escape:sym<%>($/) {
 
334
            make '%'
 
335
        }
 
336
 
 
337
        method literal($/) {
 
338
            make ~$/
 
339
        }
 
340
 
 
341
        method idx($/) {
 
342
            my $index := $<param_index> - 1;
 
343
            nqp::die("Parameter index starts to count at 1 but 0 was passed") if $index < 0;
 
344
            make $index
 
345
        }
 
346
 
 
347
        method size($/) {
 
348
            make $<star> ?? next_argument({}) !! ~$/
 
349
        }
 
350
    }
 
351
 
 
352
    my $actions := Actions.new();
 
353
 
 
354
    sub sprintf($format, @arguments) {
 
355
        my @*ARGS_HAVE := @arguments;
 
356
        $assert_used_args := 1;
 
357
        return Syntax.parse( $format, :actions($actions) ).ast;
 
358
    }
 
359
 
 
360
    nqp::bindcurhllsym('sprintf', &sprintf);
 
361
 
 
362
    class Directives {
 
363
        method TOP($/) {
 
364
            my $count := 0;
 
365
            $count := nqp::add_i($count, $_.ast) for $<statement>;
 
366
            make $count
 
367
        }
 
368
 
 
369
        method statement($/) {
 
370
            make $<directive> && !$<directive><idx> ?? 1 !! 0
 
371
        }
 
372
    }
 
373
    
 
374
    my $directives := Directives.new();
 
375
    
 
376
    sub sprintfdirectives($format) {
 
377
        return Syntax.parse( $format, :actions($directives) ).ast;
 
378
    }
 
379
 
 
380
    nqp::bindcurhllsym('sprintfdirectives', &sprintfdirectives);
 
381
 
 
382
    sub sprintfaddargumenthandler($interface) {
 
383
        @handlers.push($interface);
 
384
        "Added!"; # return meaningless string
 
385
    }
 
386
 
 
387
    nqp::bindcurhllsym('sprintfaddargumenthandler', &sprintfaddargumenthandler);
 
388
 
 
389
}