← Back to branch summary

~ubuntu-branches/ubuntu/precise/rakudo/precise

« back to all changes in this revision

Viewing changes to src/builtins/op.pir

  • Committer: Bazaar Package Importer
  • Author(s): Alessandro Ghedini
  • Date: 2011-05-17 11:31:09 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20110517113109-rmfir654u1axbpt4
Tags: 0.1~2011.04-1
http://bugs.debian.org/601862
http://bugs.debian.org/585762
http://bugs.debian.org/577502
http://bugs.debian.org/584498
* New upstream release (Closes: #601862, #585762, #577502)
* New maintainer
* Switch to 3.0 (quilt) format
* Update dependencies (Closes: #584498)
* Update debian/copyright to lastest DEP5 revision
* Do not generate/install perl6 manpage (now done by the build system)
* Enable tests
* Bump Standards-Version to 3.9.2 (no changes needed)
* Do not install extra LICENSE files and duplicated docs
* Remove debian/clean (no more needed)
* Add Vcs-* fields in debian/control
* Rewrite (short) description
* Update upstream copyright years
* Upload to unstable

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/builtins/op.pir
1
 
## $Id$
2
 
 
3
 
=head1 NAME
4
 
 
5
 
src/builtins/op.pir - Perl 6 builtin operators
6
 
 
7
 
=head1 Functions
8
 
 
9
 
=over 4
10
 
 
11
 
=cut
12
 
 
13
 
.namespace []
14
 
 
15
 
## This is used by integer computations, to upgrade the answer and return a
16
 
## Num if we overflow. We may want to return something like a BigInt in the
17
 
## future, but we don't have that yet and this gives something closer to the
18
 
## correct semantics than not upgrading an Int at all.
19
 
.sub '!upgrade_to_num_if_needed'
20
 
    .param num test
21
 
    if test > 2147483647.0 goto upgrade
22
 
    if test < -2147483648.0 goto upgrade
23
 
    $I0 = test
24
 
    .return ($I0)
25
 
  upgrade:
26
 
    .return (test)
27
 
.end
28
 
 
29
 
 
30
 
## autoincrement
31
 
.sub 'prefix:++' :multi(_) :subid('!prefix:++')
32
 
    .param pmc a
33
 
    $I0 = defined a
34
 
    unless $I0 goto inc_undef
35
 
    $P1 = a.'succ'()
36
 
    .tailcall 'infix:='(a, $P1)
37
 
  inc_undef:
38
 
    .tailcall 'infix:='(a, 1)
39
 
.end
40
 
 
41
 
.sub 'postfix:++' :multi(_) :subid('!postfix:++')
42
 
    .param pmc a
43
 
    $P0 = a.'clone'()
44
 
    .const 'Sub' $P1 = '!prefix:++'
45
 
    $P1(a)
46
 
    .return ($P0)
47
 
.end
48
 
 
49
 
.sub 'prefix:--' :multi(_) :subid('!prefix:--')
50
 
    .param pmc a
51
 
    $I0 = defined a
52
 
    unless $I0 goto dec_undef
53
 
    $P1 = a.'pred'()
54
 
    .tailcall 'infix:='(a, $P1)
55
 
  dec_undef:
56
 
    .tailcall 'infix:='(a, -1)
57
 
.end
58
 
 
59
 
.sub 'postfix:--' :multi(_)
60
 
    .param pmc a
61
 
    $P0 = a.'clone'()
62
 
    .const 'Sub' $P1 = '!prefix:--'
63
 
    $P1(a)
64
 
    .return ($P0)
65
 
.end
66
 
 
67
 
.sub 'prefix:++' :multi(Integer) :subid('!prefix:++Int')
68
 
    .param pmc a
69
 
    unless a < 2147483647 goto fallback
70
 
    $P0 = getprop 'readonly', a
71
 
    unless null $P0 goto fallback
72
 
    $P0 = getprop 'type', a
73
 
    if null $P0 goto fast_inc
74
 
    $P1 = get_hll_global 'Int'
75
 
    $I0 = issame $P0, $P1
76
 
    unless $I0 goto fallback
77
 
  fast_inc:
78
 
    inc a
79
 
    .return (a)
80
 
  fallback:
81
 
    .const 'Sub' fb = '!prefix:++'
82
 
    .tailcall fb(a)
83
 
.end
84
 
 
85
 
.sub 'postfix:++' :multi(Integer)
86
 
    .param pmc a
87
 
    $P0 = deobjectref a
88
 
    $P0 = clone $P0
89
 
    .const 'Sub' $P1 = '!prefix:++Int'
90
 
    $P1(a)
91
 
    .return ($P0)
92
 
.end
93
 
 
94
 
 
95
 
## symbolic unary
96
 
.sub 'prefix:!' :multi(_)
97
 
    .param pmc a
98
 
    if a goto a_true
99
 
    $P0 = get_hll_global ['Bool'], 'True'
100
 
    .return ($P0)
101
 
  a_true:
102
 
    $P0 = get_hll_global ['Bool'], 'False'
103
 
    .return ($P0)
104
 
.end
105
 
 
106
 
 
107
 
.sub 'prefix:^?' :multi(_)
108
 
    .param pmc a
109
 
    .tailcall 'prefix:!'(a)
110
 
.end
111
 
 
112
 
 
113
 
.sub 'prefix:+' :multi(_)
114
 
    .param num a
115
 
    .return (a)
116
 
.end
117
 
 
118
 
 
119
 
.sub 'prefix:+' :multi('Integer')
120
 
    .param num a
121
 
    .tailcall '!upgrade_to_num_if_needed'(a)
122
 
.end
123
 
 
124
 
 
125
 
.sub 'prefix:?' :multi(_)
126
 
    .param pmc a
127
 
    if a goto a_true
128
 
    $P0 = get_hll_global ['Bool'], 'False'
129
 
    .return ($P0)
130
 
  a_true:
131
 
    $P0 = get_hll_global ['Bool'], 'True'
132
 
    .return ($P0)
133
 
.end
134
 
 
135
 
 
136
 
## TODO: prefix:= prefix:* prefix:** prefix:~^ prefix:+^
137
 
 
138
 
 
139
 
.sub 'infix:xx' :multi(_,_)
140
 
    .param pmc a
141
 
    .param int n
142
 
    $P0 = 'list'()
143
 
  loop:
144
 
    unless n > 0 goto done
145
 
    push $P0, a
146
 
    dec n
147
 
    goto loop
148
 
  done:
149
 
    .return ($P0)
150
 
.end
151
 
 
152
 
 
153
 
.sub 'infix:+&' :multi(_,_)
154
 
    .param int a
155
 
    .param int b
156
 
    $I0 = band a, b
157
 
    .return ($I0)
158
 
.end
159
 
 
160
 
 
161
 
.sub 'infix:+<' :multi(_,_)
162
 
    .param int a
163
 
    .param int b
164
 
    $I0 = shl a, b
165
 
    .return ($I0)
166
 
.end
167
 
 
168
 
 
169
 
.sub 'infix:+>' :multi(_,_)
170
 
    .param int a
171
 
    .param int b
172
 
    $I0 = shr a, b
173
 
    .return ($I0)
174
 
.end
175
 
 
176
 
 
177
 
.sub 'infix:~&' :multi(_,_)
178
 
    .param string a
179
 
    .param string b
180
 
    $S0 = bands a, b
181
 
    .return ($S0)
182
 
.end
183
 
 
184
 
 
185
 
## TODO: infix:~< infix:~>
186
 
 
187
 
 
188
 
## additive
189
 
 
190
 
.sub 'infix:~' :multi(_,_)
191
 
    .param string a
192
 
    .param string b
193
 
    $S0 = concat a, b
194
 
    $P0 = new ['Str']
195
 
    assign $P0, $S0
196
 
    .return ($P0)
197
 
.end
198
 
 
199
 
 
200
 
.sub 'infix:+|'
201
 
    .param int a
202
 
    .param int b
203
 
    $I0 = bor a, b
204
 
    .return ($I0)
205
 
.end
206
 
 
207
 
 
208
 
.sub 'infix:+^'
209
 
    .param int a
210
 
    .param int b
211
 
    $I0 = bxor a, b
212
 
    .return ($I0)
213
 
.end
214
 
 
215
 
 
216
 
.sub 'infix:~|'
217
 
    .param string a
218
 
    .param string b
219
 
    $S0 = bors a, b
220
 
    .return ($S0)
221
 
.end
222
 
 
223
 
 
224
 
.sub 'infix:~^'
225
 
    .param string a
226
 
    .param string b
227
 
    $S0 = bxors a, b
228
 
    .return ($S0)
229
 
.end
230
 
 
231
 
 
232
 
.sub 'infix:?&'
233
 
    .param int a
234
 
    .param int b
235
 
    $I0 = band a, b
236
 
    $I0 = isne $I0, 0
237
 
    .return ($I0)
238
 
.end
239
 
 
240
 
 
241
 
.sub 'infix:?|'
242
 
    .param int a
243
 
    .param int b
244
 
    $I0 = bor a, b
245
 
    $I0 = isne $I0, 0
246
 
    .return ($I0)
247
 
.end
248
 
 
249
 
 
250
 
.sub 'infix:?^'
251
 
    .param int a
252
 
    .param int b
253
 
    $I0 = bxor a, b
254
 
    $I0 = isne $I0, 0
255
 
    .return ($I0)
256
 
.end
257
 
 
258
 
 
259
 
.sub 'true' :multi(_)
260
 
    .param pmc a
261
 
    .tailcall 'prefix:?'(a)
262
 
.end
263
 
 
264
 
 
265
 
.sub 'not' :multi(_)
266
 
    .param pmc a
267
 
    .tailcall 'prefix:!'(a)
268
 
.end
269
 
 
270
 
 
271
 
.sub 'infix:does'
272
 
    .param pmc var
273
 
    .param pmc role
274
 
    .param pmc init_value      :optional
275
 
    .param int have_init_value :opt_flag
276
 
 
277
 
    # Get the class of the variable we're adding roles to.
278
 
    .local pmc p6meta, parrot_class
279
 
    var.'!rebox'()
280
 
    parrot_class = class var
281
 
 
282
 
    # Derive a new class that does the role(s) specified.
283
 
    .local pmc derived
284
 
    derived = root_new ['parrot';'Class']
285
 
    addparent derived, parrot_class
286
 
    $I0 = isa role, ['Perl6Role']
287
 
    if $I0 goto one_role_select
288
 
    #$P0 = get_root_namespace ['parrot';'Role']
289
 
    #$P0 = get_class $P0
290
 
    $I0 = isa role, 'P6role'
291
 
    if $I0 goto one_role
292
 
    $I0 = isa role, ['List']
293
 
    if $I0 goto many_roles
294
 
  error:
295
 
    'die'("'does' expects a role or a list of roles")
296
 
 
297
 
  one_role_select:
298
 
    role = role.'!select'()
299
 
  one_role:
300
 
    addrole derived, role
301
 
    '!compose_role_attributes'(derived, role)
302
 
    goto added_roles
303
 
 
304
 
  many_roles:
305
 
    .local pmc role_it, cur_role
306
 
    role_it = iter role
307
 
  roles_loop:
308
 
    unless role_it goto roles_loop_end
309
 
    cur_role = shift role_it
310
 
    $I0 = isa cur_role, 'Role'
311
 
    if $I0 goto have_parrot_role
312
 
    $I0 = isa cur_role, 'Perl6Role'
313
 
    unless $I0 goto error
314
 
    cur_role = cur_role.'!select'()
315
 
  have_parrot_role:
316
 
    addrole derived, cur_role
317
 
    '!compose_role_attributes'(derived, cur_role)
318
 
    goto roles_loop
319
 
  roles_loop_end:
320
 
  added_roles:
321
 
 
322
 
    # Instantiate the class to make it form itself.
323
 
    $P0 = new derived
324
 
 
325
 
    # Create a new meta-class, but associate with existing proto-object.
326
 
    .local pmc p6meta, old_proto, new_proto
327
 
    p6meta = get_hll_global ['Perl6Object'], '$!P6META'
328
 
    new_proto = p6meta.'register'(derived)
329
 
    $P0 = new_proto.'HOW'()
330
 
    old_proto = var.'WHAT'()
331
 
    setattribute $P0, 'protoobject', old_proto
332
 
 
333
 
    # Re-bless the object into the subclass.
334
 
    rebless_subclass var, derived
335
 
 
336
 
    # We need to set any initial attribute values up.
337
 
    .lex '$CLASS', new_proto
338
 
    $P0 = find_method new_proto, 'BUILD'
339
 
    $P0(var)
340
 
 
341
 
    # If we were given something to initialize with, do so.
342
 
    unless have_init_value goto no_init
343
 
    .local pmc attrs
344
 
    .local string attr_name
345
 
    attrs = inspect role, "attributes"
346
 
    attrs = attrs.'keys'()
347
 
    $I0 = elements attrs
348
 
    if $I0 != 1 goto attr_error
349
 
    attr_name = attrs[0]
350
 
    attr_name = substr attr_name, 2 # lop off sigil and twigil
351
 
    $P0 = var.attr_name()
352
 
    'infix:='($P0, init_value)
353
 
  no_init:
354
 
 
355
 
    # We're done - return.
356
 
    .return (var)
357
 
 
358
 
attr_error:
359
 
    'die'("Can only supply an initialization value to a role with one attribute")
360
 
.end
361
 
 
362
 
 
363
 
.sub 'infix:but'
364
 
    .param pmc var
365
 
    .param pmc role
366
 
    .param pmc value      :optional
367
 
    .param int have_value :opt_flag
368
 
 
369
 
    # First off, is the role actually a role?
370
 
    $I0 = isa role, 'Perl6Role'
371
 
    if $I0 goto have_role
372
 
    $I0 = isa role, 'Role'
373
 
    if $I0 goto have_role
374
 
 
375
 
    # If not, it may be an enum. If we don't have a value, get the class of
376
 
    # the thing passed as a role and find out.
377
 
    if have_value goto error
378
 
    .local pmc maybe_enum
379
 
    maybe_enum = role.'WHAT'()
380
 
    $P0 = getprop '$!is_enum', maybe_enum
381
 
    if null $P0 goto error
382
 
    unless $P0 goto error
383
 
    value = role
384
 
    role = maybe_enum
385
 
    goto have_role
386
 
    unless null role goto have_role
387
 
 
388
 
    # Did anything go wrong?
389
 
  error:
390
 
    'die'("The but operator can only be used with a role or enum value on the right hand side")
391
 
 
392
 
    # Now we have a role, copy the value and call does on the copy.
393
 
  have_role:
394
 
    $I0 = isa var, 'ObjectRef'
395
 
    unless $I0 goto not_obj_ref
396
 
    var = deref var
397
 
  not_obj_ref:
398
 
    var = clone var
399
 
    if null value goto no_value
400
 
    'infix:does'(var, role, value)
401
 
    goto return
402
 
  no_value:
403
 
    'infix:does'(var, role)
404
 
  return:
405
 
    .return (var)
406
 
.end
407
 
 
408
 
 
409
 
=item !generate_meta_ops
410
 
 
411
 
Generates meta-ops for user defined operators.
412
 
 
413
 
=cut
414
 
 
415
 
.sub '!generate_meta_ops'
416
 
    .param string full_name
417
 
    .param string equiv
418
 
 
419
 
    # If op is already generated, defined, we're done.
420
 
    .local string name
421
 
    name = substr full_name, 6
422
 
    $S0 = concat 'infix:R', name
423
 
    $P0 = get_hll_global $S0
424
 
    unless null $P0 goto done
425
 
 
426
 
    # Generate all the names we'll need.
427
 
    .local string assignment, reverse, cross, reduce, hyper1, hyper2, hyper3, hyper4
428
 
    .local string hyper1_asc, hyper2_asc, hyper3_asc, hyper4_asc
429
 
    assignment = concat 'infix:', name
430
 
                 concat assignment, '='
431
 
    reverse    = concat 'infix:R', name
432
 
    cross      = concat 'infix:X', name
433
 
    reduce     = concat 'prefix:[', name
434
 
                 concat reduce, ']'
435
 
    hyper1_asc = concat 'infix:<<', name
436
 
                 concat hyper1_asc, '>>'
437
 
    hyper2_asc = concat 'infix:>>', name
438
 
                 concat hyper2_asc, '<<'
439
 
    hyper3_asc = concat 'infix:<<', name
440
 
                 concat hyper3_asc, '<<'
441
 
    hyper4_asc = concat 'infix:>>', name
442
 
                 concat hyper4_asc, '>>'
443
 
    hyper1     = concat unicode:"infix:\u00ab", name
444
 
                 concat hyper1, unicode:"\u00bb"
445
 
    hyper2     = concat unicode:"infix:\u00bb", name
446
 
                 concat hyper2, unicode:"\u00ab"
447
 
    hyper3     = concat unicode:"infix:\u00ab", name
448
 
                 concat hyper3, unicode:"\u00ab"
449
 
    hyper4     = concat unicode:"infix:\u00bb", name
450
 
                 concat hyper4, unicode:"\u00bb"
451
 
 
452
 
    # Add all of the tokens.
453
 
    .local pmc optable
454
 
    optable = get_hll_global ['Perl6';'Grammar'], '$optable'
455
 
    optable.'newtok'(assignment, 'equiv'=>'infix::=', 'lvalue'=>1)
456
 
    optable.'newtok'(reduce, 'equiv'=>'infix:=')
457
 
    optable.'newtok'(reverse, 'equiv'=>equiv)
458
 
    optable.'newtok'(cross, 'equiv'=>'infix:X')
459
 
    optable.'newtok'(hyper1, 'equiv'=>equiv)
460
 
    optable.'newtok'(hyper1_asc, 'equiv'=>equiv, 'subname'=>hyper1)
461
 
    optable.'newtok'(hyper2, 'equiv'=>equiv)
462
 
    optable.'newtok'(hyper2_asc, 'equiv'=>equiv, 'subname'=>hyper2)
463
 
    optable.'newtok'(hyper3, 'equiv'=>equiv)
464
 
    optable.'newtok'(hyper3_asc, 'equiv'=>equiv, 'subname'=>hyper3)
465
 
    optable.'newtok'(hyper4, 'equiv'=>equiv)
466
 
    optable.'newtok'(hyper4_asc, 'equiv'=>equiv, 'subname'=>hyper4)
467
 
 
468
 
    # Now generate the subs.
469
 
    $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_simple', '!ASSIGNMETAOP', name)
470
 
    set_hll_global assignment, $P0
471
 
    $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_reduce', name)
472
 
    set_hll_global reduce, $P0
473
 
    $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_reverse', full_name)
474
 
    set_hll_global reverse, $P0
475
 
    $P0 = '!FAIL'()
476
 
    $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_cross', name)
477
 
    set_hll_global cross, $P0
478
 
    $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_hyper', '!HYPEROP', name, 0, 0)
479
 
    set_hll_global hyper1, $P0
480
 
    $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_hyper', '!HYPEROP', name, 1, 1)
481
 
    set_hll_global hyper2, $P0
482
 
    $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_hyper', '!HYPEROP', name, 0, 1)
483
 
    set_hll_global hyper3, $P0
484
 
    $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_hyper', '!HYPEROP', name, 1, 0)
485
 
    set_hll_global hyper4, $P0
486
 
  done:
487
 
.end
488
 
.sub '!generate_meta_op_sub'
489
 
    .param string which_helper
490
 
    .param pmc delegate_to
491
 
    .param pmc args :slurpy
492
 
    .lex '$delegate_to', delegate_to
493
 
    .lex '@args', args
494
 
    $P0 = find_name which_helper
495
 
    $P0 = newclosure $P0
496
 
    .return ($P0)
497
 
.end
498
 
.sub '!generate_meta_op_helper_simple' :outer('!generate_meta_op_sub')
499
 
    .param pmc a
500
 
    .param pmc b
501
 
    $P0 = find_lex '$delegate_to'
502
 
    $S0 = $P0
503
 
    $P0 = find_name $S0
504
 
    $P1 = find_lex '@args'
505
 
    .tailcall $P0($P1 :flat, a, b)
506
 
.end
507
 
.sub '!generate_meta_op_helper_reverse' :outer('!generate_meta_op_sub')
508
 
    .param pmc a
509
 
    .param pmc b
510
 
    $P0 = find_lex '$delegate_to'
511
 
    $S0 = $P0
512
 
    $P0 = find_name $S0
513
 
    .tailcall $P0(b, a)
514
 
.end
515
 
.sub '!generate_meta_op_helper_reduce' :outer('!generate_meta_op_sub')
516
 
    .param pmc args :slurpy
517
 
    $P0 = find_lex '$delegate_to'
518
 
    .tailcall '!REDUCEMETAOP'($P0, 0, args :flat)
519
 
.end
520
 
.sub '!generate_meta_op_helper_cross' :outer('!generate_meta_op_sub')
521
 
    .param pmc args :slurpy
522
 
    $P0 = find_lex '$delegate_to'
523
 
    .tailcall '!CROSSMETAOP'($P0, 0, 0, args :flat)
524
 
.end
525
 
.sub '!generate_meta_op_helper_hyper' :outer('!generate_meta_op_sub')
526
 
    .param pmc a
527
 
    .param pmc b
528
 
    $P0 = find_lex '$delegate_to'
529
 
    $S0 = $P0
530
 
    $P0 = find_name $S0
531
 
    $P1 = find_lex '@args'
532
 
    $I1 = pop $P1
533
 
    $I0 = pop $P1
534
 
    .tailcall $P0($P1 :flat, a, b, $I0, $I1)
535
 
.end
536
 
 
537
 
=back
538
 
 
539
 
=cut
540
 
 
541
 
# Local Variables:
542
 
#   mode: pir
543
 
#   fill-column: 100
544
 
# End:
545
 
# vim: expandtab shiftwidth=4 ft=pir: