1
# This is a first cut at a ClassHOW for NQP. It doesn't support all the stuff
2
# that Perl 6 needs, but it's sufficient for NQP. Supports methods, attributes,
3
# role composition, inheritance (single and multiple) and introspection.
13
# Attributes, methods, parents and roles directly added.
17
has @!multi_methods_to_incorporate;
22
# Vtable and mapping of method names to slots.
24
has %!method-vtable-slots;
26
# Have we been composed?
29
# Cached MRO (list of the type objects).
32
# Full list of roles that we do.
35
# Cached values, which are thrown away if the class changes.
40
# Parrot-specific vtable mapping hash. Maps vtable name to method.
41
has %!parrot_vtable_mapping;
42
has %!parrot_vtable_handler_mapping;
54
my $archetypes := Archetypes.new( :nominal(1), :inheritable(1) );
63
# Creates a new instance of this meta-class.
64
method new(:$name = '<anon>') {
65
my $obj := nqp::create(self);
66
$obj.BUILD(:name($name));
70
method BUILD(:$name = '<anon>') {
72
@!attributes := nqp::list();
73
%!methods := nqp::hash();
74
@!method_order := nqp::list();
75
@!multi_methods_to_incorporate := nqp::list();
76
@!parents := nqp::list();
77
@!roles := nqp::list();
78
@!vtable := nqp::list();
79
%!method-vtable-slots := nqp::hash();
81
@!done := nqp::list();
83
%!parrot_vtable_mapping := nqp::hash();
84
%!parrot_vtable_handler_mapping := nqp::hash();
86
@!BUILDALLPLAN := nqp::list();
87
@!BUILDPLAN := nqp::list();
94
# Create a new meta-class instance, and then a new type object
95
# to go with it, and return that.
96
method new_type(:$name = '<anon>', :$repr = 'P6opaque') {
97
my $metaclass := self.new(:name($name));
98
nqp::setwho(nqp::newtype($metaclass, $repr), {});
101
method add_method($obj, $name, $code_obj) {
102
if nqp::existskey(%!methods, $name) {
103
nqp::die("This class already has a method named " ~ $name);
105
if nqp::isnull($code_obj) || !nqp::defined($code_obj) {
106
nqp::die("Cannot add a null method '$name' to class '$!name'");
108
nqp::setmethcacheauth($obj, 0);
109
%!caches{nqp::where(self)} := {} unless nqp::isnull(%!caches);
110
nqp::push(@!method_order, %!methods{$name} := $code_obj);
113
method add_multi_method($obj, $name, $code_obj) {
114
# We can't incorporate these right away as we don't know all
115
# parents yet, maybe, which influences whether we even can
116
# have multis, need to generate a proto or worreva. So just
117
# queue them up in a todo list and we handle it at class
120
%todo<name> := $name;
121
%todo<code> := $code_obj;
122
nqp::push(@!multi_methods_to_incorporate, %todo);
123
nqp::setmethcacheauth($obj, 0);
127
method add_attribute($obj, $meta_attr) {
128
my $name := $meta_attr.name;
130
if $_.name eq $name {
131
nqp::die("This class already has an attribute named " ~ $name);
134
nqp::push(@!attributes, $meta_attr);
137
method add_parent($obj, $parent) {
139
nqp::die("NQPClassHOW does not support adding parents after being composed.");
141
if $obj =:= $parent {
142
nqp::die("Class '$!name' cannot inherit from itself.");
146
nqp::die("Already have " ~ $parent ~ " as a parent class.");
149
nqp::push(@!parents, $parent);
152
method set_default_parent($obj, $parent) {
153
$!default_parent := $parent;
156
# Changes the object's parent. Conditions: it has exactly one parent, and that
157
# parent has no attributes, and nor does the new one.
158
method reparent($obj, $new_parent) {
159
if nqp::elems(@!parents) != 1 {
160
nqp::die("Can only re-parent a class with exactly one parent");
162
for @!parents[0].HOW.mro(@!parents[0]) {
163
if nqp::elems($_.HOW.attributes($_, :local)) {
164
nqp::die("Can only re-parent a class whose parent has no attributes");
167
for $new_parent.HOW.mro($new_parent) {
168
if nqp::elems($_.HOW.attributes($_, :local)) {
169
nqp::die("Can only re-parent to a class with no attributes");
172
@!parents[0] := $new_parent;
173
@!mro := compute_c3_mro($obj);
174
self.publish_type_cache($obj);
175
self.publish_method_cache($obj);
176
self.publish_boolification_spec($obj);
178
self.publish_parrot_vtable_mapping($obj);
179
self.publish_parrot_vtablee_handler_mapping($obj);
184
method add_role($obj, $role) {
187
nqp::die("The role " ~ $role ~ " has already been added.");
190
nqp::push(@!roles, $role);
194
method add_parrot_vtable_mapping($obj, $name, $meth) {
195
if nqp::defined(%!parrot_vtable_mapping{$name}) {
196
nqp::die("Class '" ~ $!name ~
197
"' already has a Parrot v-table override for '" ~
200
%!parrot_vtable_mapping{$name} := $meth;
203
method add_parrot_vtable_handler_mapping($obj, $name, $att_name) {
204
if nqp::defined(%!parrot_vtable_handler_mapping{$name}) {
205
nqp::die("Class '" ~ $!name ~
206
"' already has a Parrot v-table handler for '" ~
209
%!parrot_vtable_handler_mapping{$name} := [ $obj, $att_name ];
213
method compose($obj) {
214
# Incorporate roles. First, specialize them with the type object
215
# for this type (so their $?CLASS is correct). Then delegate to
218
my @specialized_roles;
220
my $ins := $_.HOW.specialize($_, $obj);
221
nqp::push(@specialized_roles, $ins);
222
nqp::push(@!done, $_);
223
nqp::push(@!done, $ins);
225
RoleToClassApplier.apply($obj, @specialized_roles);
228
# If we have no parents and we're not called NQPMu then add the
230
if nqp::elems(@!parents) == 0 && $!name ne 'NQPMu' {
231
self.add_parent($obj, $!default_parent)
235
@!mro := compute_c3_mro($obj);
237
# Incorporate any new multi candidates (needs MRO built).
238
self.incorporate_multi_candidates($obj);
240
# Compose attributes.
241
for self.attributes($obj, :local<0> ) { $_.compose($obj) }
243
# Publish type and method caches and boolification spec.
244
self.publish_type_cache($obj);
245
self.publish_method_cache($obj);
246
self.publish_boolification_spec($obj);
249
# Install Parrot v-table mapping.
250
self.publish_parrot_vtable_mapping($obj);
251
self.publish_parrot_vtablee_handler_mapping($obj);
255
self.create_BUILDPLAN($obj);
257
# Compose the representation.
259
self.compose_repr($obj);
268
method compose_repr($obj) {
269
# Use any attribute information to produce attribute protocol
270
# data. The protocol consists of an array...
273
# ...which contains an array per MRO entry...
274
for @!mro -> $type_obj {
276
nqp::push(@repr_info, @type_info);
278
# ...which in turn contains the current type in the MRO...
279
nqp::push(@type_info, $type_obj);
281
# ...then an array of hashes per attribute...
283
nqp::push(@type_info, @attrs);
284
for $type_obj.HOW.attributes($type_obj, :local) -> $attr {
286
%attr_info<name> := $attr.name;
287
%attr_info<type> := $attr.type;
288
if $attr.box_target {
289
# Merely having the key serves as a "yes".
290
%attr_info<box_target> := 1;
292
if nqp::can($attr, 'auto_viv_container') {
293
%attr_info<auto_viv_container> := $attr.auto_viv_container;
295
if $attr.positional_delegate {
296
%attr_info<positional_delegate> := 1;
298
if $attr.associative_delegate {
299
%attr_info<associative_delegate> := 1;
301
nqp::push(@attrs, %attr_info);
304
# ...followed by a list of immediate parents.
305
nqp::push(@type_info, $type_obj.HOW.parents($type_obj, :local));
308
# Compose the representation using it.
309
my $info := nqp::hash();
310
$info<attribute> := @repr_info;
311
nqp::composetype($obj, $info)
314
method incorporate_multi_candidates($obj) {
315
my $num_todo := nqp::elems(@!multi_methods_to_incorporate);
317
while $i != $num_todo {
318
# Get method name and code.
319
my $name := @!multi_methods_to_incorporate[$i]<name>;
320
my $code := @!multi_methods_to_incorporate[$i]<code>;
322
# Do we have anything in the methods table already in
324
my $dispatcher := %!methods{$name};
325
if nqp::defined($dispatcher) {
326
# Yes. Only or dispatcher, though? If only, error. If
327
# dispatcher, simply add new dispatchee.
328
if nqp::can($dispatcher, 'is_dispatcher') && $dispatcher.is_dispatcher {
329
$dispatcher.add_dispatchee($code);
332
nqp::die("Cannot have a multi candidate for $name when an only method is also in the class");
336
# Go hunting in the MRO for a proto.
339
while $j != nqp::elems(@!mro) && !$found {
340
my $parent := @!mro[$j];
341
my %meths := $parent.HOW.method_table($parent);
342
my $dispatcher := %meths{$name};
343
if nqp::defined($dispatcher) {
344
# Found a possible - make sure it's a dispatcher, not
346
if nqp::can($dispatcher, 'is_dispatcher') && $dispatcher.is_dispatcher {
347
my $new_disp := $dispatcher.derive_dispatcher();
348
$new_disp.add_dispatchee($code);
349
%!methods{$name} := $new_disp;
353
nqp::die("Could not find a proto for multi $name (it may exist, but an only is hiding it if so)");
359
nqp::die("Could not find a proto for multi $name, and proto generation is NYI");
367
sub compute_c3_mro($class) {
368
my @immediate_parents := $class.HOW.parents($class, :local);
370
# Provided we have immediate parents...
372
if nqp::elems(@immediate_parents) {
373
if nqp::elems(@immediate_parents) == 1 {
374
@result := compute_c3_mro(@immediate_parents[0]);
376
# Build merge list of lineraizations of all our parents, add
377
# immediate parents and merge.
379
for @immediate_parents {
380
nqp::push(@merge_list, compute_c3_mro($_));
382
nqp::push(@merge_list, @immediate_parents);
383
@result := c3_merge(@merge_list);
387
# Put this class on the start of the list, and we're done.
388
nqp::unshift(@result, $class);
393
sub c3_merge(@merge_list) {
396
my $something_accepted := 0;
399
# Try to find something appropriate to add to the MRO.
404
my $cand_class := @cand_list[0];
405
$cand_count := $cand_count + 1;
408
unless $_ =:= @cand_list {
409
# Is current candidate in the tail? If so, reject.
411
while $cur_pos <= nqp::elems($_) {
412
if $_[$cur_pos] =:= $cand_class {
415
$cur_pos := $cur_pos + 1;
420
# If we didn't reject it, this candidate will do.
422
$accepted := $cand_class;
423
$something_accepted := 1;
429
# If we never found any candidates, return an empty list.
430
if $cand_count == 0 {
434
# If we didn't find anything to accept, error.
435
unless $something_accepted {
436
nqp::die("Could not build C3 linearization: ambiguous hierarchy");
439
# Otherwise, remove what was accepted from the merge lists.
441
while $i < nqp::elems(@merge_list) {
443
for @merge_list[$i] {
444
unless $_ =:= $accepted {
445
nqp::push(@new_list, $_);
448
@merge_list[$i] := @new_list;
452
# Need to merge what remains of the list, then put what was accepted on
453
# the start of the list, and we're done.
454
@result := c3_merge(@merge_list);
455
nqp::unshift(@result, $accepted);
459
method publish_type_cache($obj) {
461
for @!mro { nqp::push(@tc, $_); }
462
for @!done { nqp::push(@tc, $_); }
463
nqp::settypecache($obj, @tc)
468
for @in { nqp::unshift(@out, $_) }
472
method publish_method_cache($obj) {
473
# Walk MRO and add methods to cache, unless another method
474
# lower in the class hierarchy "shadowed" it.
476
my @mro_reversed := reverse(@!mro);
478
for $_.HOW.method_table($_) {
479
%cache{nqp::iterkey_s($_)} := nqp::iterval($_);
482
nqp::setmethcache($obj, %cache);
483
nqp::setmethcacheauth($obj, 1);
486
method publish_boolification_spec($obj) {
487
my $bool_meth := self.find_method($obj, 'Bool');
488
if nqp::defined($bool_meth) {
489
nqp::setboolspec($obj, 0, $bool_meth)
492
nqp::setboolspec($obj, 5, nqp::null())
497
method publish_parrot_vtable_mapping($obj) {
501
for $_.HOW.parrot_vtable_handler_mappings($_, :local(1)) {
502
%seen_handlers{$_.key} := 1;
504
for $_.HOW.parrot_vtable_mappings($_, :local(1)) {
505
unless nqp::existskey(%mapping, $_.key)
506
|| nqp::existskey(%seen_handlers, $_.key) {
507
%mapping{$_.key} := $_.value;
512
pir::stable_publish_vtable_mapping__0PP($obj, %mapping);
516
method publish_parrot_vtablee_handler_mapping($obj) {
518
my @mro_reversed := reverse(@!mro);
520
for $_.HOW.parrot_vtable_handler_mappings($_, :local(1)) {
521
%mapping{$_.key} := $_.value;
525
pir::stable_publish_vtable_handler_mapping__0PP($obj, %mapping);
530
# Creates the plan for building up the object. This works
531
# out what we'll need to do up front, so we can just zip
532
# through the "todo list" each time we need to make an object.
533
# The plan is an array of arrays. The first element of each
534
# nested array is an "op" representing the task to perform:
535
# 0 code = call specified BUILD method
536
# 1 class name attr_name = try to find initialization value
537
# 2 class name attr_name = try to find initialization value, or set nqp::list()
538
# 3 class name attr_name = try to find initialization value, or set nqp::hash()
539
# 4 class attr_name code = call default value closure if needed
540
method create_BUILDPLAN($obj) {
541
# First, we'll create the build plan for just this class.
543
my @attrs := $obj.HOW.attributes($obj, :local(1));
545
# Does it have its own BUILD?
546
my $build := $obj.HOW.method_table($obj)<BUILD>;
547
if nqp::defined($build) {
548
# We'll call the custom one.
549
nqp::push(@plan, [0, $build]);
552
# No custom BUILD. Rather than having an actual BUILD
553
# in Mu, we produce ops here per attribute that may
556
my $attr_name := $_.name;
557
my $name := nqp::substr($attr_name, 2);
558
my $sigil := nqp::substr($attr_name, 0, 1);
559
my $sigop := $sigil eq '@' ?? 2 !! $sigil eq '%' ?? 3 !! 1;
560
nqp::push(@plan, [$sigop, $obj, $name, $attr_name]);
564
# Check if there's any default values to put in place.
566
if nqp::can($_, 'build') {
567
my $default := $_.build;
568
if nqp::defined($default) {
569
nqp::push(@plan, [4, $obj, $_.name, $default]);
574
# Install plan for this class.
575
@!BUILDPLAN := @plan;
577
# Now create the full plan by getting the MRO, and working from
578
# least derived to most derived, copying the plans.
580
my @mro := self.mro($obj);
581
my $i := nqp::elems(@mro);
584
my $class := @mro[$i];
585
for $class.HOW.BUILDPLAN($class) {
586
nqp::push(@all_plan, $_);
589
@!BUILDALLPLAN := @all_plan;
592
method BUILDPLAN($obj) {
596
method BUILDALLPLAN($obj) {
604
method parents($obj, :$local = 0) {
605
$local ?? @!parents !! @!mro
612
method roles($obj, :$local!) {
616
method methods($obj, :$local = 0) {
623
for $_.HOW.methods($_, :local) {
624
nqp::push(@meths, $_)
631
method method_table($obj) {
639
method traced($obj) {
643
method trace_depth($obj) {
647
method attributes($obj, :$local = 0) {
651
nqp::push(@attrs, $_);
656
for $_.HOW.attributes($_, :local) {
657
nqp::push(@attrs, $_);
665
method parrot_vtable_mappings($obj, :$local!) {
666
%!parrot_vtable_mapping
669
method parrot_vtable_handler_mappings($obj, :$local!) {
670
%!parrot_vtable_handler_mapping
678
method isa($obj, $check) {
679
my $check-class := $check.WHAT;
680
my $i := nqp::elems(@!mro);
683
if @!mro[$i] =:= $check-class {
690
method does($obj, $check) {
691
my $i := nqp::elems(@!done);
694
if @!done[$i] =:= $check {
701
method can($obj, $name) {
703
my %meths := $_.HOW.method_table($obj);
704
my $can := %meths{$name};
705
if nqp::defined($can) {
715
method find_method($obj, $name, :$no_fallback = 0, :$no_trace = 0) {
717
my %meths := $_.HOW.method_table($obj);
718
if nqp::existskey(%meths, $name) {
719
my $found := %meths{$name};
720
return $!trace && !$no_trace && self.should_trace($obj, $name) ??
722
nqp::say(nqp::x(' ', $!trace_depth) ~ "Calling $name");
723
$!trace_depth := $!trace_depth + 1;
724
my $result := $found(|@pos, |%named);
725
$!trace_depth := $!trace_depth - 1;
737
method cache($obj, $key, $value_generator) {
738
%!caches := nqp::hash() unless nqp::ishash(%!caches);
739
nqp::existskey(%!caches, $key) ??
741
(%!caches{$key} := $value_generator())
744
method flush_cache($obj) {
745
%!caches := {} unless nqp::isnull(%!caches)
752
method set_is_mixin($obj) { $!is_mixin := 1 }
753
method is_mixin($obj) { $!is_mixin }
755
method mixin($obj, $role) {
756
# See if we mixed in before.
759
unless nqp::isnull(@!mixin_cache) {
760
for @!mixin_cache -> $c_role, $c_type {
761
if $c_role =:= $role {
762
$new_type := $c_type;
769
# Create and cache mixin-type if needed.
771
# Flush its cache as promised, otherwise outdated NFAs will stick around.
772
self.flush_cache($obj) if !nqp::isnull($obj) || self.is_mixin($obj);
773
# Work out a type name for the post-mixed-in role.
774
my $new_name := self.name($obj) ~ '+{' ~ $role.HOW.name($role) ~ '}';
776
# Create new type, derive it from ourself and then add
777
# all the roles we're mixing it.
778
$new_type := self.new_type(:name($new_name), :repr($obj.REPR));
779
$new_type.HOW.set_is_mixin($new_type);
780
$new_type.HOW.add_parent($new_type, $obj.WHAT);
781
$new_type.HOW.add_role($new_type, $role);
782
$new_type.HOW.compose($new_type);
786
@!mixin_cache := [] if nqp::isnull(@!mixin_cache);
787
nqp::push(@!mixin_cache, $role);
788
nqp::push(@!mixin_cache, $new_type);
793
# If the original object was concrete, change its type by calling a
794
# low level op. Otherwise, we just return the new type object
795
nqp::isconcrete($obj) ??
796
nqp::rebless($obj, $new_type) !!
803
method trace-on($obj, $depth?, :@exclude = <MATCH CAPHASH CREATE orig pos>) {
805
$!trace_depth := $depth // 0;
806
@!trace_exclude := @exclude;
807
nqp::setmethcacheauth($obj, 0);
808
nqp::setmethcache($obj, nqp::hash());
810
method trace-off($obj) {
813
method should_trace($obj, $name) {
814
return 0 if nqp::substr($name, 0, 1) eq '!';
815
for @!trace_exclude {
816
return 0 if $name eq $_;
added
removed
src/how/NQPClassHOW.nqp
