« back to all changes in this revision
Viewing changes to src/builtins/guts.pir
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Ryan Niebur
- Date: 2009-10-04 14:31:57 UTC
- Revision ID: james.westby@ubuntu.com-20091004143157-ubq3wu0grk0f1e6a
Tags: upstream-0.1~2009.09
Import upstream version 0.1~2009.09
- files added:
- build
- docs
- docs/announce
- dynext
- lib
- src
- src/builtins
- src/classes
- src/ops
- src/parrot
- src/parser
- src/pmc
- src/setting
- src/setting/IO
- src/setting/IO/Socket
- src/utils
- src/utils/perl6doc
- t
- t/00-parrot
- t/01-sanity
- t/pmc
- tools
- tools/util
added
removed
src/builtins/guts.pir
1
## $Id$
2
3
=head1 NAME
4
5
src/builtins/guts.pir - subs that are part of the internals, not for users
6
7
=head1 SUBS
8
9
=over 4
10
11
=item !EXPORT(symbols, from :named('from') [, to :named('to')] )
12
13
Export symbols in namespace C<from> to the namespace given by C<to>.
14
If C<to> isn't given, then exports into the HLL global namespace.
15
This function differs somewhat from Parrot's C<Exporter> PMC in that
16
it understands how to properly merge C<MultiSub> PMCs.
17
18
=cut
19
20
.namespace []
21
.sub '!EXPORT'
22
.param string symbols
23
.param pmc from :named('from')
24
.param pmc to :named('to') :optional
25
.param int has_to :opt_flag
26
.param int to_p6_multi :named('to_p6_multi') :optional
27
28
if has_to goto have_to
29
to = get_hll_namespace
30
have_to:
31
32
.local pmc list
33
list = split ',', symbols
34
list_loop:
35
unless list goto list_end
36
.local string symbol
37
.local pmc value
38
symbol = shift list
39
value = from[symbol]
40
$I0 = isa value, 'MultiSub'
41
unless $I0 goto store_value
42
if to_p6_multi != 1 goto no_convert
43
$P0 = value[0]
44
'!TOPERL6MULTISUB'($P0)
45
value = from[symbol]
46
no_convert:
47
$P0 = to[symbol]
48
if null $P0 goto store_value
49
$I0 = isa $P0, 'MultiSub'
50
unless $I0 goto err_type_conflict
51
$I0 = elements $P0
52
splice $P0, value, $I0, 0
53
goto list_loop
54
store_value:
55
to[symbol] = value
56
goto list_loop
57
list_end:
58
.return ()
59
60
err_type_conflict:
61
$S0 = concat "Unable to add Multisub '", symbol
62
$S0 .= "' to existing value"
63
die $S0
64
.end
65
66
67
=item !CALLMETHOD('method', obj)
68
69
Invoke a method on a possibly foreign object. If the object
70
supports the requested method, we use it, otherwise we assume
71
the object is foreign and try using the corresponding method
72
from C<Any>.
73
74
=cut
75
76
.namespace []
77
.sub '!CALLMETHOD'
78
.param string method
79
.param pmc obj
80
$I0 = isa obj, 'Perl6Scalar'
81
if $I0 goto any_method
82
$I0 = can obj, method
83
unless $I0 goto any_method
84
.tailcall obj.method()
85
any_method:
86
.local pmc anyobj
87
anyobj = get_global '$!ANY'
88
unless null anyobj goto any_method_1
89
anyobj = new ['Any']
90
set_global '$!ANY', anyobj
91
any_method_1:
92
$P0 = find_method anyobj, method
93
.tailcall obj.$P0()
94
.end
95
96
97
=item !dispatch_method_indirect
98
99
Does an indirect method dispatch.
100
101
=cut
102
103
.sub '!dispatch_method_indirect'
104
.param pmc obj
105
.param pmc methodish
106
.param pmc pos_args :slurpy
107
.param pmc name_args :slurpy :named
108
109
$I0 = isa methodish, 'P6Invocation'
110
if $I0 goto ready_to_dispatch
111
$P0 = get_hll_global 'Callable'
112
$I0 = $P0.'ACCEPTS'(methodish)
113
unless $I0 goto candidate_list
114
ready_to_dispatch:
115
.tailcall methodish(obj, pos_args :flat, name_args :flat :named)
116
117
candidate_list:
118
$P0 = root_new ['parrot';'P6Invocation'], methodish
119
.tailcall $P0(obj, pos_args :flat, name_args :flat :named)
120
.end
121
122
123
=item !dispatch_dispatcher_parallel
124
125
Does a parallel method dispatch over an existing dispatcher. Just invokes the normal
126
dispatcher for each thingy we're dispatching over.
127
128
=cut
129
130
.sub '!dispatch_dispatcher_parallel'
131
.param pmc invocanty
132
.param string dispatcher
133
.param pmc pos_args :slurpy
134
.param pmc named_args :slurpy :named
135
136
.local pmc it, result, disp
137
disp = find_name dispatcher
138
result = new ['Perl6Array']
139
invocanty = invocanty.'list'()
140
it = iter invocanty
141
it_loop:
142
unless it goto it_loop_done
143
$P0 = shift it
144
$P0 = disp($P0, pos_args :flat, named_args :flat :named)
145
$P0 = $P0.'Scalar'()
146
result.'push'($P0)
147
goto it_loop
148
it_loop_done:
149
150
.return (result)
151
.end
152
153
154
=item !dispatch_method_parallel
155
156
Does a parallel method dispatch. Invokes the method for each thing in the
157
array of invocants.
158
159
=cut
160
161
.sub '!dispatch_method_parallel'
162
.param pmc invocanty
163
.param string name
164
.param pmc pos_args :slurpy
165
.param pmc named_args :slurpy :named
166
167
.local pmc it, result
168
result = new ['Perl6Array']
169
invocanty = invocanty.'list'()
170
it = iter invocanty
171
it_loop:
172
unless it goto it_loop_done
173
$P0 = shift it
174
$P0 = $P0.name(pos_args :flat, named_args :flat :named)
175
$P0 = $P0.'Scalar'()
176
result.'push'($P0)
177
goto it_loop
178
it_loop_done:
179
180
.return (result)
181
.end
182
183
184
=item !VAR
185
186
Helper function for implementing the VAR and .VAR macros.
187
188
=cut
189
190
.sub '!VAR'
191
.param pmc variable
192
$I0 = isa variable, 'Perl6Scalar'
193
unless $I0 goto nothing
194
$P0 = root_new ['parrot';'MutableVAR'], variable
195
.return ($P0)
196
nothing:
197
.return (variable)
198
.end
199
200
201
=item !SAMETYPE_EXACT
202
203
Takes two types and returns true if they match exactly (not accounting for any
204
subtyping relations, etc).
205
206
=cut
207
208
.sub '!SAMETYPE_EXACT'
209
.param pmc t1
210
.param pmc t2
211
212
# If they have equal address, obviously the same.
213
.local pmc t1meta, t2meta
214
t1meta = t1.'HOW'()
215
t2meta = t2.'HOW'()
216
eq_addr t1meta, t2meta, same
217
218
# If they are junctions, compare inside them recursively.
219
$I0 = isa t1, 'Junction'
220
unless $I0 goto not_junc
221
$I1 = isa t2, 'Junction'
222
unless $I0 == $I1 goto not_junc
223
.local pmc j1, j2
224
.local int max, i
225
j1 = t1.'eigenstates'()
226
j2 = t1.'eigenstates'()
227
max = elements j1
228
i = 0
229
junc_loop:
230
if i >= max goto junc_loop_end
231
$P0 = j1[i]
232
$P1 = j2[i]
233
$I0 = '!SAMETYPE_EXACT'($P0, $P1)
234
unless $I0 goto not_same
235
inc i
236
goto junc_loop
237
junc_loop_end:
238
not_junc:
239
240
not_same:
241
.return(0)
242
same:
243
.return (1)
244
.end
245
246
247
=item !CREATE_SUBSET_TYPE
248
249
Creates a subset type. Basically, we make an anonymous subclass of the
250
original type, attach the refinement and override ACCEPTS. We also chase up
251
to find a real, non-subtype and stash that away for fast access later.
252
253
=cut
254
255
.sub '!CREATE_SUBSET_TYPE'
256
.param pmc refinee
257
.param pmc refinement
258
259
.local pmc p6meta
260
p6meta = get_hll_global ['Perl6Object'], '$!P6META'
261
262
# Check if the refinee is a refinement type itself; if so, get the real
263
# base type we're refining.
264
.local pmc real_type, real_type_pc
265
real_type = getprop 'subtype_realtype', refinee
266
unless null $P0 goto got_real_type
267
real_type = refinee
268
got_real_type:
269
270
# Create subclass. If it's a role, pun it.
271
.local pmc parrot_class, type_obj, subset
272
type_obj = refinee
273
$I0 = isa type_obj, 'Perl6Role'
274
unless $I0 goto ambig_role_done
275
type_obj = type_obj.'!select'()
276
ambig_role_done:
277
$I0 = isa type_obj, 'P6role'
278
unless $I0 goto role_done
279
type_obj = type_obj.'!pun'()
280
role_done:
281
parrot_class = p6meta.'get_parrotclass'(type_obj)
282
subset = subclass parrot_class
283
284
# Override accepts.
285
.local pmc parrotclass
286
.const 'Sub' $P0 = "!SUBTYPE_ACCEPTS"
287
subset.'add_method'('ACCEPTS', $P0)
288
.const 'Sub' $P1 = "!SUBTYPE_PROTOOVERRIDES"
289
subset.'add_method'('PROTOOVERRIDES', $P1)
290
291
# It's an abstraction.
292
$P0 = get_hll_global 'Abstraction'
293
$P0 = $P0.'!select'()
294
subset.'add_role'($P0)
295
296
# Register it, creating a proto-object.
297
subset = p6meta.'register'(subset)
298
299
# Mark it a subtype and stash away real type, refinee and refinement.
300
$I0 = isa real_type, 'Perl6Role'
301
unless $I0 goto real_type_done
302
real_type = real_type.'!select'()
303
real_type_done:
304
setprop subset, 'subtype_realtype', real_type
305
setprop subset, 'subtype_refinement', refinement
306
setprop subset, 'subtype_refinee', refinee
307
308
.return (subset)
309
.end
310
.sub "!SUBTYPE_ACCEPTS" :anon :method
311
.param pmc topic
312
313
# Get refinement and check against that.
314
.local pmc refinement
315
refinement = getprop 'subtype_refinement', self
316
$P0 = refinement(topic)
317
unless $P0 goto false
318
319
# Recurse up the tree.
320
.local pmc refinee
321
refinee = getprop 'subtype_refinee', self
322
$P0 = refinee.'ACCEPTS'(topic)
323
unless $P0 goto false
324
325
true:
326
$P0 = get_hll_global ['Bool'], 'True'
327
.return ($P0)
328
false:
329
$P0 = get_hll_global ['Bool'], 'False'
330
.return ($P0)
331
.end
332
.sub '!SUBTYPE_PROTOOVERRIDES' :anon :method
333
.return ('new', 'ACCEPTS')
334
.end
335
336
337
=item !TOPERL6MULTISUB
338
339
At the moment, we don't have the abilility to have Parrot use our own MultiSub
340
type, nor are we ready to (because built-ins need to get Perl 6 signatures
341
first). So for now we just transform multis in user code like this.
342
343
=cut
344
345
.sub '!TOPERL6MULTISUB'
346
.param pmc sub
347
348
# Look up what's currently installed in the namespace for this sub; if it
349
# is already a Perl6MultiSub, leave it.
350
.local pmc namespace, current_thing
351
.local string name
352
namespace = sub.'get_namespace'()
353
name = sub
354
current_thing = namespace[name]
355
if null current_thing goto error
356
$S0 = typeof current_thing
357
if $S0 == 'MultiSub' goto not_perl6_multisub
358
.return()
359
# It's not a Perl6MultiSub, create one and put contents into it.
360
not_perl6_multisub:
361
.local pmc p6multi, sub_iter
362
p6multi = root_new ['parrot';'Perl6MultiSub']
363
sub_iter = iter current_thing
364
iter_loop:
365
unless sub_iter goto iter_loop_end
366
$P0 = shift sub_iter
367
push p6multi, $P0
368
goto iter_loop
369
iter_loop_end:
370
371
# Nor replace the current thing with the new data structure.
372
copy current_thing, p6multi
373
.return()
374
375
error:
376
'die'('Sub lookup failed')
377
.end
378
379
380
=item !clone_multi_for_lexical
381
382
=cut
383
384
.sub '!clone_multi_for_lexical'
385
.param pmc existing
386
if null existing goto fresh
387
unless existing goto fresh
388
$P0 = existing.'clone'()
389
.return ($P0)
390
fresh:
391
$P0 = root_new ['parrot';'Perl6MultiSub']
392
.return ($P0)
393
.end
394
395
396
=item !UNIT_START
397
398
=cut
399
400
.sub '!UNIT_START'
401
.param pmc unitmain
402
.param pmc args
403
404
args = 'list'(args)
405
if args goto start_main
406
.tailcall unitmain()
407
408
start_main:
409
## We're running as main program
410
## Remove program argument (0) and put it in $*PROGRAM_NAME, then set up
411
## @ARGS global.
412
$P0 = shift args
413
set_hll_global '$PROGRAM_NAME', $P0
414
args = args.'Array'()
415
set_hll_global '@ARGS', args
416
## run unitmain
417
.local pmc result, MAIN
418
result = unitmain()
419
## if there's a MAIN sub in unitmain's namespace, run it also
420
$P0 = unitmain.'get_namespace'()
421
MAIN = $P0['MAIN']
422
if null MAIN goto done
423
args = get_hll_global '@ARGS'
424
result = MAIN(args :flat)
425
done:
426
.return (result)
427
.end
428
429
430
=item !capture
431
432
Combine slurpy positional and slurpy named args into a list.
433
Note that original order may be lost -- that's the nature
434
of captures.
435
436
=cut
437
438
.sub '!capture'
439
.param pmc args :slurpy
440
.param pmc options :slurpy :named
441
unless options goto done
442
.local pmc it
443
it = iter options
444
iter_loop:
445
unless it goto done
446
$S0 = shift it
447
$P0 = options[$S0]
448
$P0 = 'infix:=>'($S0, $P0)
449
push args, $P0
450
goto iter_loop
451
done:
452
.tailcall args.'list'()
453
.end
454
455
456
=item !ADDTOROLE
457
458
Adds a given role initializing multi-variant to a Role object, creating it
459
and putting it in the namespace if it doesn't already exist.
460
461
=cut
462
463
.sub '!ADDTOROLE'
464
.param pmc variant
465
466
# Get short name of role.
467
.local pmc ns
468
.local string short_name
469
ns = variant.'get_namespace'()
470
ns = ns.'get_name'()
471
short_name = pop ns
472
$P0 = box short_name
473
setprop variant, "$!shortname", $P0
474
$I0 = index short_name, '['
475
if $I0 == -1 goto have_short_name
476
short_name = substr short_name, 0, $I0
477
have_short_name:
478
479
# See if we have a Role object already.
480
.local pmc role_obj
481
role_obj = get_root_global ns, short_name
482
if null role_obj goto need_role_obj
483
$I0 = isa role_obj, 'NameSpace'
484
unless $I0 goto have_role_obj
485
need_role_obj:
486
role_obj = new ['Perl6Role']
487
transform_to_p6opaque role_obj
488
set_root_global ns, short_name, role_obj
489
$P0 = box short_name
490
setattribute role_obj, "$!shortname", $P0
491
have_role_obj:
492
493
# Add this variant.
494
role_obj.'!add_variant'(variant)
495
.end
496
497
498
=item !meta_create(type, name, also)
499
500
Create a metaclass object for C<type> with the given C<name>.
501
This simply creates a handle on which we can hang methods, attributes,
502
traits, etc. -- the class itself isn't created until the class
503
is composed (see C<!meta_compose> below).
504
505
=cut
506
507
.sub '!meta_create'
508
.param string type
509
.param string name
510
.param int also
511
512
.local pmc nsarray
513
$P0 = get_hll_global [ 'Perl6';'Compiler' ], 'parse_name'
514
$P1 = null
515
nsarray = $P0($P1, name)
516
517
if type == 'package' goto package
518
if type == 'module' goto package
519
if type == 'class' goto class
520
if type == 'grammar' goto class
521
if type == 'role' goto role
522
'die'("Unsupported package declarator ", type)
523
524
package:
525
$P0 = get_hll_namespace nsarray
526
.return ($P0)
527
528
class:
529
.local pmc parrotclass, metaclass, ns
530
ns = get_hll_namespace nsarray
531
if also goto is_also
532
parrotclass = newclass ns
533
$P0 = box type
534
setprop parrotclass, 'pkgtype', $P0
535
'!set_resolves_list'(parrotclass)
536
metaclass = new ['ClassHOW']
537
setattribute metaclass, 'parrotclass', parrotclass
538
.return (metaclass)
539
is_also:
540
parrotclass = get_class ns
541
metaclass = getprop 'metaclass', parrotclass
542
.return (metaclass)
543
544
role:
545
# This is a little fun. We only want to create the Parrot role and suck
546
# in the methods once per role definition. We do this and it is attached to
547
# the namespace. Then we attach this "master role" to a new one we create
548
# per invocation, so the methods can be newclosure'd and added into it in
549
# the body.
550
.local pmc info, parrotrole
551
ns = get_hll_namespace nsarray
552
parrotrole = get_class ns
553
unless null parrotrole goto have_role
554
555
info = root_new ['parrot';'Hash']
556
$P0 = nsarray[-1]
557
info['name'] = $P0
558
info['namespace'] = nsarray
559
parrotrole = root_new ['parrot';'P6role'], info
560
have_role:
561
562
# Copy list of roles done by the original role into this specific
563
# one.
564
.local pmc specific_role, tmp, it
565
specific_role = root_new ['parrot';'P6role']
566
setprop specific_role, '$!orig_role', parrotrole
567
tmp = parrotrole.'roles'()
568
it = iter tmp
569
roles_loop:
570
unless it goto roles_loop_end
571
tmp = shift it
572
specific_role.'add_role'(tmp)
573
goto roles_loop
574
roles_loop_end:
575
576
# Now create a meta-object (RoleHOW) to package this all up in.
577
.local pmc metaclass
578
metaclass = new ['RoleHOW']
579
setprop specific_role, 'metaclass', metaclass
580
setattribute metaclass, 'parrotclass', specific_role
581
setattribute metaclass, 'protoobject', specific_role
582
setattribute metaclass, 'shortname', $P0
583
$P1 = box name
584
setattribute metaclass, 'longname', $P1
585
.return (metaclass)
586
.end
587
588
589
=item !meta_compose(Class metaclass)
590
591
Compose the class. This includes resolving any inconsistencies
592
and creating the protoobjects.
593
594
=cut
595
596
.sub '!meta_compose'
597
.param pmc metaclass
598
.local pmc p6meta
599
p6meta = get_hll_global ['Perl6Object'], '$!P6META'
600
601
# If it's a RoleHOW or otherwise just not a ClassHOW, nothing to do.
602
$I0 = isa metaclass, 'RoleHOW'
603
if $I0 goto no_pkgtype
604
$I0 = isa metaclass, 'ClassHOW'
605
unless $I0 goto no_pkgtype
606
607
# Extract the parrotclass form the metaclass.
608
.local pmc parrotclass
609
parrotclass = getattribute metaclass, 'parrotclass'
610
611
# Parrot handles composing methods into roles, but we need to handle the
612
# attribute composition ourselves.
613
.local pmc roles, roles_it
614
roles = getprop '@!roles', parrotclass
615
if null roles goto roles_it_loop_end
616
roles = '!get_flattened_roles_list'(roles)
617
roles_it = iter roles
618
roles_it_loop:
619
unless roles_it goto roles_it_loop_end
620
$P0 = shift roles_it
621
$I0 = does parrotclass, $P0
622
if $I0 goto roles_it_loop
623
parrotclass.'add_role'($P0)
624
'!compose_role_attributes'(parrotclass, $P0)
625
goto roles_it_loop
626
roles_it_loop_end:
627
628
# We may need to set up invoke vtable if postcircumfix:<( )>
629
# is implemented.
630
'!setup_invoke_vtable'(metaclass)
631
632
# Create proto-object with default parent being Any or Grammar, unless
633
# there already is a parent.
634
.local pmc proto
635
$P0 = parrotclass.'parents'()
636
$I0 = elements $P0
637
if $I0 goto register_parent_set
638
$S0 = 'Any'
639
$P0 = getprop 'pkgtype', parrotclass
640
if null $P0 goto no_pkgtype
641
if $P0 != 'grammar' goto register
642
$S0 = 'Grammar'
643
register:
644
proto = p6meta.'register'(parrotclass, 'parent'=>$S0, 'how'=>metaclass)
645
goto have_proto
646
register_parent_set:
647
proto = p6meta.'register'(parrotclass, 'how'=>metaclass)
648
have_proto:
649
transform_to_p6opaque proto
650
.return (proto)
651
no_pkgtype:
652
.return (metaclass)
653
.end
654
655
656
=item !setup_invoke_vtable
657
658
If we override postcircumfix:<( )> then also add a
659
vtable override for invoke.
660
661
=cut
662
663
.sub '!setup_invoke_vtable'
664
.param pmc metaclass
665
.local pmc parrotclass
666
parrotclass = getattribute metaclass, 'parrotclass'
667
$P0 = parrotclass.'methods'()
668
$P0 = $P0['postcircumfix:( )']
669
if null $P0 goto no_invoke
670
.const 'Sub' $P1 = '!invoke_vtable_override_helper'
671
parrotclass.'add_vtable_override'('invoke', $P1)
672
no_invoke:
673
.end
674
.sub '' :subid('!invoke_vtable_override_helper')
675
.param pmc pos_args :slurpy
676
.param pmc named_args :slurpy :named
677
$P0 = getinterp
678
$P0 = $P0['sub']
679
$P0 = getprop '$!self', $P0
680
.tailcall $P0.'postcircumfix:( )'(pos_args :flat, named_args :flat :named)
681
.end
682
683
684
=item !get_flattened_roles_list
685
686
Flattens out the list of roles.
687
688
=cut
689
690
.sub '!get_flattened_roles_list'
691
.param pmc unflat_list
692
.local pmc flat_list, it, cur_role, nested_roles, nested_it
693
flat_list = root_new ['parrot';'ResizablePMCArray']
694
it = iter unflat_list
695
it_loop:
696
unless it goto it_loop_end
697
cur_role = shift it
698
$I0 = isa cur_role, 'Role'
699
unless $I0 goto error_not_a_role
700
push flat_list, cur_role
701
nested_roles = getprop '@!roles', cur_role
702
if null nested_roles goto it_loop
703
nested_roles = '!get_flattened_roles_list'(nested_roles)
704
nested_it = iter nested_roles
705
nested_it_loop:
706
unless nested_it goto it_loop
707
$P0 = shift nested_it
708
push flat_list, $P0
709
goto nested_it_loop
710
it_loop_end:
711
.return (flat_list)
712
error_not_a_role:
713
'die'('Can not compose a non-role.')
714
.end
715
716
717
=item !meta_attribute(metaclass, name, itypename [, 'type'=>type] )
718
719
Add attribute C<name> to C<metaclass> with the given C<itypename>
720
and C<type>.
721
722
=cut
723
724
.sub '!meta_attribute'
725
.param pmc metaclass
726
.param string name
727
.param string itypename :optional
728
.param int has_itypename :opt_flag
729
.param pmc attr :slurpy :named
730
731
# twigil handling (for has &!foo, we just get name as !foo)
732
.local int offset
733
.local string twigil
734
offset = 1
735
$S0 = substr name, 0, 1
736
if $S0 != '!' goto offset_done
737
offset = 0
738
offset_done:
739
twigil = substr name, offset, 1
740
if twigil == '.' goto twigil_public
741
if twigil == '!' goto twigil_done
742
substr name, offset, 0, '!'
743
goto twigil_done
744
twigil_public:
745
substr name, offset, 1, '!'
746
twigil_done:
747
748
# In the future, we'll want to have just called metaclass.add_attribute(...)
749
# here and let it handle all of this, but we ain't quite ready for that yet.
750
$I0 = isa metaclass, 'P6metaclass'
751
unless $I0 goto got_parrot_class
752
metaclass = getattribute metaclass, 'parrotclass'
753
got_parrot_class:
754
755
$P0 = metaclass.'attributes'()
756
$I0 = exists $P0[name]
757
if $I0 goto attr_exists
758
addattribute metaclass, name
759
$P1 = getprop '@!attribute_list', metaclass
760
unless null $P1 goto have_attrlist
761
$P1 = root_new ['parrot';'ResizableStringArray']
762
setprop metaclass, '@!attribute_list', $P1
763
have_attrlist:
764
push $P1, name
765
$P0 = metaclass.'attributes'()
766
attr_exists:
767
768
.local pmc attrhash, it
769
attrhash = $P0[name]
770
771
# Set any itype for the attribute.
772
unless has_itypename goto itype_done
773
.local pmc itype
774
if itypename == 'Perl6Scalar' goto itype_pmc
775
itype = get_class itypename
776
goto have_itype
777
itype_pmc:
778
$P0 = get_root_namespace ['parrot';'Perl6Scalar']
779
itype = get_class $P0
780
have_itype:
781
attrhash['itype'] = itype
782
itype_done:
783
784
# and set any other attributes that came in via the slurpy hash
785
it = iter attr
786
attr_loop:
787
unless it goto attr_done
788
$S0 = shift it
789
$P0 = attr[$S0]
790
attrhash[$S0] = $P0
791
goto attr_loop
792
attr_done:
793
794
# Anything to do with handles?
795
$P0 = attr['handles']
796
if null $P0 goto handles_done
797
798
# For the handles trait verb, we may have got a name or a list of names.
799
# If so, just generate methods with those names. Otherwise, need to store
800
# them as a property on the metaclass, so the dispatcher can smart-match
801
# against them later. Also, the % syntax is spec'd as reserved, so we give
802
# an error on that for now.
803
.const 'Sub' handles = '!handles'
804
.local pmc handles_it
805
$S0 = substr name, 0, 1
806
if $S0 == '%' goto reserved_syntax_error
807
$I0 = isa $P0, 'Str'
808
if $I0 goto simple_handles
809
$I0 = isa $P0, 'List'
810
if $I0 goto simple_handles
811
$I0 = isa $P0, 'Perl6Pair'
812
if $I0 goto simple_handles
813
814
.local pmc class_handles_list, handles_hash
815
class_handles_list = getprop '@!handles_dispatchers', metaclass
816
unless null class_handles_list goto have_class_handles_list
817
class_handles_list = root_new ['parrot';'ResizablePMCArray']
818
setprop metaclass, '@!handles_dispatchers', class_handles_list
819
have_class_handles_list:
820
handles_hash = root_new ['parrot';'Hash']
821
handles_hash['attrname'] = name
822
handles_hash['match_against'] = $P0
823
push class_handles_list, handles_hash
824
goto handles_done
825
826
simple_handles:
827
$P0 = 'list'($P0)
828
handles_it = iter $P0
829
handles_loop:
830
.local string visible_name
831
.local pmc orig_name
832
unless handles_it goto handles_done
833
$P0 = clone handles
834
$P1 = box name
835
setprop $P0, 'attrname', $P1
836
$P1 = shift handles_it
837
$I0 = isa $P1, 'Perl6Pair'
838
if $I0 goto handles_pair
839
visible_name = $P1
840
orig_name = $P1
841
goto naming_done
842
handles_pair:
843
visible_name = $P1.'key'()
844
orig_name = $P1.'value'()
845
naming_done:
846
setprop $P0, 'methodname', orig_name
847
metaclass.'add_method'(visible_name, $P0)
848
goto handles_loop
849
handles_done:
850
.return ()
851
reserved_syntax_error:
852
'die'("The use of a %hash with the handles trait verb is reserved")
853
.end
854
855
856
.sub '!handles' :method
857
.param pmc args :slurpy
858
.param pmc options :slurpy :named
859
.local pmc method, attribute
860
.local string attrname
861
$P0 = getinterp
862
method = $P0['sub']
863
$P1 = getprop 'attrname', method
864
attrname = $P1
865
attribute = getattribute self, attrname
866
$P1 = getprop 'methodname', method
867
$S1 = $P1
868
$S0 = substr attrname, 0, 1
869
if $S0 != '@' goto single_dispatch
870
.local pmc it
871
it = iter attribute
872
it_loop:
873
unless it goto it_loop_end
874
$P0 = shift it
875
$I0 = $P0.'can'($S1)
876
unless $I0 goto it_loop
877
.tailcall $P0.$S1(args :flat, options :flat :named)
878
it_loop_end:
879
'die'("You used handles on attribute ", attrname, ", but nothing in the array can do method ", $S1)
880
single_dispatch:
881
.tailcall attribute.$S1(args :flat, options :flat :named)
882
.end
883
884
885
=item !set_resolves_list(class)
886
887
Gets all the methods that the class has and adds them to the resolves list.
888
889
=cut
890
891
.sub '!set_resolves_list'
892
.param pmc class
893
.local pmc meths, it, res_list
894
meths = class.'methods'()
895
it = iter meths
896
res_list = root_new ['parrot';'ResizableStringArray']
897
it_loop:
898
unless it goto it_loop_end
899
$S0 = shift it
900
$P0 = meths[$S0]
901
$I0 = isa $P0, 'MultiSub'
902
if $I0 goto it_loop
903
push res_list, $S0
904
goto it_loop
905
it_loop_end:
906
class.'resolve_method'(res_list)
907
.end
908
909
910
=item !compose_role_attributes(class, role)
911
912
Helper method to compose the attributes of a role into a class.
913
914
=cut
915
916
.sub '!compose_role_attributes'
917
.param pmc class
918
.param pmc role
919
920
# Need to get hold of attribute order list for the class.
921
.local pmc attr_order_list
922
attr_order_list = getprop '@!attribute_list', class
923
unless null attr_order_list goto have_attr_order_list
924
attr_order_list = root_new ['parrot';'ResizableStringArray']
925
setprop class, '@!attribute_list', attr_order_list
926
have_attr_order_list:
927
928
.local pmc role_attrs, class_attrs, ra_iter, fixup_list
929
.local string cur_attr
930
role_attrs = inspect role, "attributes"
931
class_attrs = class."attributes"()
932
fixup_list = root_new ['parrot';'ResizableStringArray']
933
ra_iter = iter role_attrs
934
ra_iter_loop:
935
unless ra_iter goto ra_iter_loop_end
936
cur_attr = shift ra_iter
937
938
# Check that this attribute doesn't conflict with one already in the class.
939
$I0 = exists class_attrs[cur_attr]
940
unless $I0 goto no_conflict
941
942
# We have a name conflict. Let's compare the types. If they match, then we
943
# can merge the attributes.
944
.local pmc class_attr_type, role_attr_type
945
$P0 = class_attrs[cur_attr]
946
if null $P0 goto conflict
947
class_attr_type = $P0['type']
948
if null class_attr_type goto conflict
949
$P0 = role_attrs[cur_attr]
950
if null $P0 goto conflict
951
role_attr_type = $P0['type']
952
if null role_attr_type goto conflict
953
$I0 = '!SAMETYPE_EXACT'(class_attr_type, role_attr_type)
954
if $I0 goto merge
955
956
conflict:
957
$S0 = "Conflict of attribute '"
958
$S0 = concat cur_attr
959
$S0 = concat "' in composition of role '"
960
$S1 = role
961
$S0 = concat $S1
962
$S0 = concat "'"
963
'die'($S0)
964
965
no_conflict:
966
addattribute class, cur_attr
967
push fixup_list, cur_attr
968
push attr_order_list, cur_attr
969
merge:
970
goto ra_iter_loop
971
ra_iter_loop_end:
972
973
# Now we need, for any merged in attributes, to copy property data.
974
.local pmc fixup_iter, class_props, role_props, props_iter
975
class_attrs = class."attributes"()
976
fixup_iter = iter fixup_list
977
fixup_iter_loop:
978
unless fixup_iter goto fixup_iter_loop_end
979
cur_attr = shift fixup_iter
980
role_props = role_attrs[cur_attr]
981
class_props = class_attrs[cur_attr]
982
props_iter = iter role_props
983
props_iter_loop:
984
unless props_iter goto props_iter_loop_end
985
$S0 = shift props_iter
986
$P0 = role_props[$S0]
987
class_props[$S0] = $P0
988
goto props_iter_loop
989
props_iter_loop_end:
990
goto fixup_iter_loop
991
fixup_iter_loop_end:
992
.end
993
994
995
=item !add_metaclass_method
996
997
=cut
998
999
.sub '!add_metaclass_method'
1000
.param pmc metaclass
1001
.param pmc name
1002
.param pmc method
1003
1004
# Create role for the method and mix it into the meta-class.
1005
$P0 = root_new ['parrot';'P6role']
1006
$S0 = name
1007
addmethod $P0, $S0, method
1008
'infix:does'(metaclass, $P0)
1009
1010
# Add forward method to the class itself.
1011
.lex '$meth_name', name
1012
.const 'Sub' $P1 = '!metaclass_method_forwarder'
1013
$P1 = newclosure $P1
1014
$P0 = getattribute metaclass, 'parrotclass'
1015
$P0.'add_method'(name, $P1)
1016
.end
1017
.sub '!metaclass_method_forwarder' :outer('!add_metaclass_method') :method :anon
1018
.param pmc pos_args :slurpy
1019
.param pmc named_args :slurpy :named
1020
$P0 = self.'HOW'()
1021
$P1 = find_lex '$meth_name'
1022
$S0 = $P1
1023
.tailcall $P0.$S0(self, pos_args :flat, named_args :flat :named)
1024
.end
1025
1026
1027
=item !create_parametric_role
1028
1029
Helper method for creating parametric roles.
1030
1031
=cut
1032
1033
.sub '!create_parametric_role'
1034
.param pmc metarole
1035
'!meta_compose'(metarole)
1036
.local pmc parrotrole, orig_role, meths, meth_iter
1037
parrotrole = getattribute metarole, 'parrotclass'
1038
orig_role = getprop '$!orig_role', parrotrole
1039
meths = orig_role.'methods'()
1040
meth_iter = iter meths
1041
it_loop:
1042
unless meth_iter goto it_loop_end
1043
$S0 = shift meth_iter
1044
$P0 = meths[$S0]
1045
$P1 = clone $P0
1046
$P2 = getprop '$!signature', $P0
1047
setprop $P1, '$!signature', $P2
1048
$I0 = isa $P0, 'Code'
1049
unless $I0 goto ret_pir_skip_rs
1050
$P2 = getattribute $P0, ['Sub'], 'proxy'
1051
$P2 = getprop '$!real_self', $P2
1052
$P3 = getattribute $P1, ['Sub'], 'proxy'
1053
setprop $P3, '$!real_self', $P2
1054
ret_pir_skip_rs:
1055
addmethod parrotrole, $S0, $P1
1056
goto it_loop
1057
it_loop_end:
1058
.return (parrotrole)
1059
.end
1060
1061
1062
=item !create_simple_role(name)
1063
1064
Internal helper method to create a role with a single parameterless variant.
1065
1066
=cut
1067
1068
.sub '!create_simple_role'
1069
.param string name
1070
.local pmc info, role, helper
1071
1072
# Create Parrot-level role. Need to make sure it gets its methods from
1073
# the right namespace.
1074
.local pmc ns
1075
ns = split '::', name
1076
name = ns[-1]
1077
info = root_new ['parrot';'Hash']
1078
info['name'] = name
1079
info['namespace'] = ns
1080
role = root_new ['parrot';'P6role'], info
1081
1082
# Now we need to wrap it up as a Perl6Role.
1083
helper = find_name '!create_simple_role_helper'
1084
helper = clone helper
1085
setprop helper, '$!metarole', role
1086
$P0 = new ["Signature"]
1087
setprop helper, '$!signature', $P0
1088
role = new ['Perl6Role']
1089
transform_to_p6opaque role
1090
1091
$P0 = box name
1092
setattribute role, '$!shortname', $P0
1093
role.'!add_variant'(helper)
1094
1095
# Store it in the namespace.
1096
ns = clone ns
1097
$S0 = pop ns
1098
set_hll_global ns, $S0, role
1099
.return(role)
1100
.end
1101
.sub '!create_simple_role_helper'
1102
$P0 = getinterp
1103
$P0 = $P0['sub']
1104
$P0 = getprop '$!metarole', $P0
1105
.return ($P0)
1106
.end
1107
1108
1109
=item !create_anon_enum(value_list)
1110
1111
Constructs a Mapping, based upon the values list.
1112
1113
=cut
1114
1115
.sub '!create_anon_enum'
1116
.param pmc values
1117
1118
# Put the values into list context, so case of a single valued enum works.
1119
values = values.'list'()
1120
1121
# For now, we assume integer type, unless we have a first pair that says
1122
# otherwise.
1123
.local pmc cur_val
1124
cur_val = box 0
1125
1126
# Iterate over values and make mapping.
1127
.local pmc result, values_it, cur_item
1128
result = new ['Mapping']
1129
values_it = iter values
1130
values_loop:
1131
unless values_it goto values_loop_end
1132
cur_item = shift values_it
1133
$I0 = isa cur_item, 'Perl6Pair'
1134
if $I0 goto pair
1135
1136
nonpair:
1137
$P0 = 'postfix:++'(cur_val)
1138
result[cur_item] = $P0
1139
goto values_loop
1140
1141
pair:
1142
cur_val = cur_item.'value'()
1143
$P0 = cur_item.'key'()
1144
result[$P0] = cur_val
1145
cur_val = clone cur_val
1146
'postfix:++'(cur_val)
1147
goto values_loop
1148
1149
values_loop_end:
1150
.return (result)
1151
.end
1152
1153
1154
=item !create_enum(name, type, value_list)
1155
1156
Constructs an enumeration.
1157
1158
=cut
1159
1160
.sub '!create_enum'
1161
.param string name
1162
.param pmc values
1163
1164
# Use !create_anon_enum to associate all names with their underlying
1165
# values.
1166
values = '!create_anon_enum'(values)
1167
1168
# Create a role for the enumeration and mark it as an enum.
1169
.local pmc para_role, role
1170
para_role = '!create_simple_role'(name)
1171
role = para_role.'!select'()
1172
$P0 = box 1
1173
setprop role, '$!is_enum', $P0
1174
1175
# Compute short name and add attribute to the role; type is this
1176
# role so that you can only store other enum elements in the slut.
1177
.local pmc ns, outer_ns
1178
.local string short_name, attr_name
1179
$P0 = get_hll_global [ 'Perl6';'Compiler' ], 'parse_name'
1180
$P1 = null
1181
ns = $P0($P1, name)
1182
outer_ns = clone ns
1183
short_name = pop outer_ns
1184
attr_name = concat "$!", short_name
1185
'!meta_attribute'(role, attr_name, 'Perl6Scalar', 'type'=>role)
1186
1187
# Add an l-value accessor method for the attribute.
1188
.local pmc attr_name_pmc, accessor
1189
attr_name_pmc = box attr_name
1190
.lex '$attr_name', attr_name_pmc
1191
.const 'Sub' accessor = '!create_enum_helper_accessor'
1192
accessor = newclosure accessor
1193
addmethod role, short_name, accessor
1194
1195
# Next, we need methods on the role for each variant, returning
1196
# a true or false value depending on if the current value of the
1197
# enum is set to that.
1198
.const 'Sub' checker_create = '!create_enum_helper_checker_create'
1199
.local pmc it, cur_value
1200
it = iter values
1201
checker_loop:
1202
unless it goto checker_loop_end
1203
$S0 = shift it
1204
cur_value = values[$S0]
1205
$P0 = checker_create(attr_name, cur_value)
1206
addmethod role, $S0, $P0
1207
goto checker_loop
1208
checker_loop_end:
1209
1210
# We'll make a list of the values and the .pick method on the role will
1211
# use that (Enum.pick then just works through punning).
1212
.local pmc value_list
1213
.local string value_name
1214
value_list = root_new ['parrot';'ResizablePMCArray']
1215
.lex '@values', value_list
1216
.const 'Sub' pick = '!create_enum_helper_pick'
1217
pick = newclosure pick
1218
addmethod role, 'pick', pick
1219
1220
# Go over all of the values...
1221
it = iter values
1222
value_loop:
1223
unless it goto value_loop_end
1224
value_name = shift it
1225
cur_value = values[value_name]
1226
1227
# Mix the enum role into it, so Val ~~ Enum will work, and set the value
1228
# field to itself plus set it readonly.
1229
cur_value = 'infix:but'(cur_value, role)
1230
$P0 = cur_value.short_name()
1231
copy $P0, cur_value
1232
$P1 = box 1
1233
setprop $P0, 'readonly', $P1
1234
1235
# It should also do Abstraction.
1236
$P0 = get_hll_global 'Abstraction'
1237
'infix:does'(cur_value, $P0)
1238
1239
# Now create and mix in another role to provide .WHAT, .perl and .name.
1240
$S0 = concat name, '::'
1241
$S0 = concat value_name
1242
$P0 = '!create_enum_value_role'(role, $S0, value_name)
1243
'infix:does'(cur_value, $P0)
1244
1245
# Put it onto the list for .pick and install it in the namespace(s).
1246
push value_list, cur_value
1247
set_hll_global ns, value_name, cur_value
1248
set_hll_global outer_ns, value_name, cur_value
1249
1250
goto value_loop
1251
value_loop_end:
1252
.end
1253
.sub '!create_enum_helper_accessor' :method :outer('!create_enum')
1254
$P0 = find_lex '$attr_name'
1255
$S0 = $P0
1256
$P0 = getattribute self, $S0
1257
.return ($P0)
1258
.end
1259
.sub '!create_enum_helper_checker_create'
1260
.param pmc attr_name
1261
.param pmc value
1262
.lex '$attr_name', attr_name
1263
.lex '$value', value
1264
.const 'Sub' $P0 = '!create_enum_helper_checker'
1265
$P0 = newclosure $P0
1266
.return ($P0)
1267
.end
1268
.sub '!create_enum_helper_checker' :method :outer('!create_enum_helper_checker_create')
1269
$P0 = find_lex '$attr_name'
1270
$S0 = $P0
1271
$P0 = getattribute self, $S0
1272
$P1 = find_lex '$value'
1273
.tailcall 'infix:eq'($P0, $P1)
1274
.end
1275
.sub '!create_enum_helper_pick' :method :outer('!create_enum')
1276
.param pmc pos_args :slurpy
1277
$P0 = find_lex '@values'
1278
$P0 = 'list'($P0 :flat)
1279
.tailcall $P0.'pick'(pos_args :flat)
1280
.end
1281
.sub '!create_enum_value_role'
1282
.param pmc enum_role
1283
.param pmc long_name
1284
.param pmc short_name
1285
.lex '$enum_role', enum_role
1286
.lex '$long_name', long_name
1287
.lex '$short_name', short_name
1288
$P0 = root_new ['parrot';'P6role']
1289
.const 'Sub' ACCEPTS = '!create_enum_value_role_ACCEPTS'
1290
ACCEPTS = newclosure ACCEPTS
1291
addmethod $P0, 'ACCEPTS', ACCEPTS
1292
.const 'Sub' WHAT = '!create_enum_value_role_WHAT'
1293
WHAT = newclosure WHAT
1294
addmethod $P0, 'WHAT', WHAT
1295
.const 'Sub' name = '!create_enum_value_role_name'
1296
name = newclosure name
1297
addmethod $P0, 'name', name
1298
.const 'Sub' perl = '!create_enum_value_role_perl'
1299
perl = newclosure perl
1300
addmethod $P0, 'perl', perl
1301
.return ($P0)
1302
.end
1303
.sub '!create_enum_value_role_ACCEPTS' :method :outer('!create_enum_value_role')
1304
.param pmc topic
1305
$P0 = find_lex '$enum_role'
1306
$I0 = does topic, $P0
1307
unless $I0 goto done
1308
$P0 = find_lex '$short_name'
1309
$S0 = $P0
1310
$I0 = topic.$S0()
1311
done:
1312
.return ($I0)
1313
.end
1314
.sub '!create_enum_value_role_WHAT' :method :outer('!create_enum_value_role')
1315
$P0 = find_lex '$enum_role'
1316
.return ($P0)
1317
.end
1318
.sub '!create_enum_value_role_name' :method :outer('!create_enum_value_role')
1319
$P0 = find_lex '$short_name'
1320
.return ($P0)
1321
.end
1322
.sub '!create_enum_value_role_perl' :method :outer('!create_enum_value_role')
1323
$P0 = find_lex '$long_name'
1324
.return ($P0)
1325
.end
1326
1327
1328
=item !fixup_routine_type(sub, new_type)
1329
1330
Reblesses a sub into a new type.
1331
1332
=cut
1333
1334
.sub '!fixup_routine_type'
1335
.param pmc sub
1336
.param string new_type_name
1337
1338
# Create the correct object and rebless the sub into that class.
1339
.local pmc new_type
1340
new_type = get_hll_global new_type_name
1341
$P0 = new_type.'new'()
1342
$P0 = typeof $P0
1343
rebless_subclass sub, $P0
1344
1345
# We also make sure the Parrot-level sub has a backlink to the
1346
# Rakudo-level object, since interpinfo only gives us the
1347
# Parrot-level sub.
1348
$P0 = getattribute sub, ['Sub'], 'proxy'
1349
setprop $P0, '$!real_self', sub
1350
.end
1351
1352
1353
=item !state_var_init
1354
1355
Loads any existing values of state variables for a block.
1356
1357
=cut
1358
1359
.sub '!state_var_init'
1360
.local pmc lexpad, state_store, names_it
1361
$P0 = getinterp
1362
lexpad = $P0['lexpad'; 1]
1363
$P0 = $P0['sub'; 1]
1364
state_store = getprop '$!state_store', $P0
1365
unless null state_store goto have_state_store
1366
state_store = root_new ['parrot';'Hash']
1367
setprop $P0, '$!state_store', state_store
1368
have_state_store:
1369
1370
names_it = iter state_store
1371
names_loop:
1372
unless names_it goto names_loop_end
1373
$S0 = shift names_it
1374
$P0 = state_store[$S0]
1375
lexpad[$S0] = $P0
1376
goto names_loop
1377
names_loop_end:
1378
.end
1379
1380
1381
=item !state_var_inited
1382
1383
Takes the name of a state variable and returns true if it's been
1384
initialized already.
1385
1386
=cut
1387
1388
.sub '!state_var_inited'
1389
.param string name
1390
$P0 = getinterp
1391
$P0 = $P0['sub'; 1]
1392
$P0 = getprop '$!state_store', $P0
1393
$P0 = $P0[name]
1394
$I0 = isnull $P0
1395
$I0 = not $I0
1396
.return ($I0)
1397
.end
1398
1399
1400
=item !MAKE_WHATEVER_CLOSURE
1401
1402
Creates whatever closures (*.foo => { $_.foo })
1403
1404
=cut
1405
1406
.sub '!MAKE_WHATEVER_CLOSURE'
1407
.param pmc whatever
1408
.param pmc pos_args :slurpy
1409
.param pmc named_args :slurpy :named
1410
.local pmc name
1411
$P0 = getinterp
1412
$P0 = $P0['sub']
1413
name = getprop 'name', $P0
1414
.lex '$name', name
1415
.lex '$pos_args', pos_args
1416
.lex '$named_args', named_args
1417
.const 'Sub' $P0 = '!whatever_dispatch_helper'
1418
$P0 = newclosure $P0
1419
.const 'Sub' fixup = '!fixup_routine_type'
1420
fixup($P0, "Block")
1421
.return ($P0)
1422
.end
1423
.sub '!whatever_dispatch_helper' :outer('!MAKE_WHATEVER_CLOSURE')
1424
.param pmc obj
1425
$P0 = find_lex '$name'
1426
$S0 = $P0
1427
$P1 = find_lex '$pos_args'
1428
$P2 = find_lex '$named_args'
1429
.tailcall obj.$S0($P1 :flat, $P2 :flat :named)
1430
.end
1431
1432
1433
=item !HANDLES_HELPER
1434
1435
=cut
1436
1437
.sub '!HANDLES_DISPATCH_HELPER'
1438
.param pmc obj
1439
.param pmc pos_args :slurpy
1440
.param pmc name_args :slurpy :named
1441
1442
# Look up attribute and method name, and look up the attribute.
1443
.local pmc attr
1444
.local string attrname, methodname
1445
$P0 = getinterp
1446
$P0 = $P0['sub']
1447
$P1 = getprop 'methodname', $P0
1448
methodname = $P1
1449
$P1 = getprop 'attrname', $P0
1450
attrname = $P1
1451
attr = getattribute obj, attrname
1452
1453
# If it's an array, need to iterate over the set of options. Otherwise,
1454
# just delegate.
1455
$S0 = substr attrname, 0, 1
1456
if $S0 == '@' goto handles_on_array
1457
.tailcall attr.methodname(pos_args :flat, name_args :flat :named)
1458
handles_on_array:
1459
.local pmc handles_array_it
1460
handles_array_it = iter attr
1461
handles_array_it_loop:
1462
unless handles_array_it goto handles_array_it_loop_end
1463
$P0 = shift handles_array_it
1464
$I0 = $P0.'can'(methodname)
1465
unless $I0 goto handles_array_it_loop
1466
.tailcall $P0.methodname(pos_args :flat, name_args :flat :named)
1467
handles_array_it_loop_end:
1468
'die'("You used handles on attribute ", attrname, ", but nothing in the array can do method ", methodname)
1469
.end
1470
1471
1472
=item !make_type_fail_message
1473
1474
Makes a type check failure error message, so we don't have to be doing so all
1475
over the rest of the code base.
1476
1477
=cut
1478
1479
.sub '!make_type_fail_message'
1480
.param string what_failed
1481
.param pmc got_type
1482
.param pmc wanted_type
1483
1484
# Initial bit.
1485
.local string output
1486
output = concat what_failed, " type check failed; expected "
1487
1488
# Work out what we were looking for and show that.
1489
$I0 = isa wanted_type, 'P6protoobject'
1490
if $I0 goto simple_type
1491
$I0 = isa wanted_type, 'Junction'
1492
if $I0 goto junc_wanted
1493
simple_type:
1494
$P0 = wanted_type.'WHAT'()
1495
goto wanted_type_done
1496
junc_wanted:
1497
$P0 = wanted_type.'eigenstates'()
1498
$I0 = elements $P0
1499
if $I0 > 1 goto wanted_type_done
1500
$P0 = $P0[0]
1501
wanted_type_done:
1502
$S0 = $P0.'perl'()
1503
output = concat $S0
1504
1505
# Report what we actually got.
1506
output = concat ", but got "
1507
$P0 = got_type.'WHAT'()
1508
$S0 = $P0.'perl'()
1509
output = concat $S0
1510
1511
.return (output)
1512
.end
1513
1514
1515
=item !bindability_checker
1516
1517
Invokes a sub in bindability checking mode. Catches any exceptions that are
1518
thrown while trying to bind. If the bind fails, returns null. Otherwise, we
1519
return the resume continuation so we can continue execution after the bind.
1520
1521
=cut
1522
1523
.sub '!bindability_checker'
1524
.param pmc orig_sub
1525
.param pmc pos_args
1526
.param pmc named_args
1527
1528
# Clone sub and attach a prop to say we're just doing a bindability check.
1529
.local pmc sub
1530
sub = clone orig_sub
1531
.fixup_cloned_sub(orig_sub, sub)
1532
setprop sub, '$!bind_check_only', sub
1533
1534
# Set up exception handler and invoke. We really should get an exception
1535
# whether it binds or not; if we don't, best we can do is hand back the
1536
# sub, but warn something may be very wrong.
1537
push_eh oh_noes
1538
sub(pos_args :flat, named_args :flat :named)
1539
pop_eh
1540
warn("Potential internal error: bindability check may have done more than just binding.")
1541
.return (sub)
1542
1543
oh_noes:
1544
.local pmc ex
1545
.get_results (ex)
1546
if ex == '__BIND_SUCCESSFUL__' goto success
1547
null $P0
1548
.return ($P0)
1549
success:
1550
$P0 = ex["resume"]
1551
.return ($P0)
1552
.end
1553
1554
1555
=item !deferal_fail
1556
1557
Used by P6invocation to help us get soft-failure semantics when no deferal
1558
is possible.
1559
1560
=cut
1561
1562
.sub '!deferal_fail'
1563
.param pmc pos_args :slurpy
1564
.param pmc named_args :slurpy :named
1565
.lex '__CANDIDATE_LIST__', $P0
1566
.tailcall '!FAIL'('No method to defer to')
1567
.end
1568
1569
=back
1570
1571
=cut
1572
1573
# Local Variables:
1574
# mode: pir
1575
# fill-column: 100
1576
# End:
1577
# vim: expandtab shiftwidth=4 ft=pir:
Loggerhead is a web-based interface for Breezy
Version: 2.0.1