Catching up after the holidays.
[kakapo:kakapo.git] / src / Classes / Class.nqp
1 # Copyright (C) 2009, Austin Hastings. See accompanying LICENSE file, or 
2 # http://www.opensource.org/licenses/artistic-license-2.0.php for license.
3
4 module Class;
5 #       Provides a class/subclass management library.
6
7 sub _pre_initload() {
8 # Special sub called when the Kakapo library is loaded or initialized. This is to guarantee this 
9 # module is available during :init and :load processing for other modules.
10
11         use(    'Opcode');      # defined, die
12         use(    'Dumper');
13         
14         Opcode::load_bytecode('P6object.pir');
15         
16         Class::BaseBehavior::_pre_initload();
17         Class::ArrayBased::_pre_initload();
18         Class::HashBased::_pre_initload();
19 }
20
21 sub NEW_CLASS($class_name) {
22         NOTE("NEW_CLASS: ", $class_name);
23         my $class_info := _class_info($class_name);
24         
25         if $class_info<created> {
26                 die("Class '", $class_name, "' already created.");
27         }
28         
29         $class_info<created> := 1;
30         my $new_class := get_meta().new_class($class_name);
31         return $new_class;
32 }
33
34 sub SUBCLASS($class_name, *@parents) {
35         my $class_info := _class_info($class_name);
36         
37         if $class_info<created> {
38                 die("Class '", $class_name, "' already created.");
39         }
40         else {
41                 $class_info<created> := 1;
42         }
43         
44         NOTE("Creating subclass ", $class_name, 
45                 " with ", +@parents, " parents.");
46         my $meta := get_meta();
47
48         unless +@parents {
49                 NOTE("Adding parent class 'Class::HashBased'");
50                 @parents.push('Class::HashBased');
51         }
52
53         NOTE("Creating class with first parent");
54         my $class := $meta.new_class($class_name, 
55                 :parent(@parents.shift));
56         
57         NOTE("Attaching other parents to new class");
58         while @parents {
59                 $meta.add_parent($class, @parents.shift);
60         }
61         
62         return $class;
63 }
64
65 sub _class_info($class_name) {
66         unless our %Class_info { %Class_info := Hash::new(); }
67         
68         unless %Class_info{$class_name} {
69                 %Class_info{$class_name} := Hash::new();
70                 my $info := %Class_info{$class_name};
71                 
72                 $info<multisubs> := Hash::empty();
73         }
74         
75         return %Class_info{$class_name};
76 }
77
78 sub compile_default_multi($class_name, $multi_name, :$is_method) {
79         my $kind := $is_method ?? 'multimethod' !! 'multisub';
80
81         NOTE("Compiling default ", $kind, " for: ", 
82                 $class_name, " :: ", $multi_name);
83
84         NOTE("Looking for fallback method in parent class(es)");
85         my $default_method := Class::find_method_named($class_name, $multi_name);
86         
87         while Opcode::isa($default_method, 'MultiSub') {
88                 NOTE("I don't think nesting multisubs is possible, but...");
89                 $default_method := $default_method[0];
90         }
91
92         my @actions;
93         
94         unless $default_method {
95                 @actions := Array::new(
96                         "say 'No method available that will accept the following arguments:'",
97                         '$P0 = get_hll_global ["Dumper"], "DUMP_"',
98                         '$P0(pos)',
99                         "die 'No method available that will accept the arguments given'",
100                 );
101         }
102
103         compile_multi($class_name, $multi_name,
104                 :actions(@actions),
105                 :is_method($is_method),
106                 :target($default_method),
107         );
108 }
109
110 # =sub compile_multi
111
112 # Creates a multi-sub trampoline that invokes a given NQP function. When invoked 
113 # as `compile_multi('My::Class', 'foo', 'Parameter::Class', 'handler_method')` the
114 # generated trampoline looks like:
115
116 # .namespace [ 'My' ; 'Class' ]
117 # .sub 'foo' :method :multi(_, [ 'Parameter' ; 'Class' ])
118 # .param pmc positionals :slurpy
119 # .param pmc named :named :slurpy
120 # .tailcall 'handler_method'(self, positionals :flat, named :named :flat)
121 # .end
122
123 # But multimethod names block inherited multimethods, so a "default" multi
124 # has to be created that forwards calls to any parent class multimethods. Per
125 # pmichaud, a multi() or multi(_) (on self) will do the trick. So first check if 
126 # the default exists already, and if not, then check if the parent(s*) name
127 # resolves. 
128
129 # =cut
130
131 sub compile_multi($class_name, $multi_name, *@param_types,
132         :$target, :@actions?, :$is_method?) 
133 {
134         my $kind := $is_method ?? 'multimethod' !! 'multisub';
135
136         NOTE("Compiling ", $kind, " trampoline [", 
137                 $class_name, "::", $multi_name, 
138                 "(", @param_types.join(', '), ", ...) -> ",
139                 $target);
140
141         if $is_method {
142                 @param_types.unshift('_');
143         }
144         
145         my $class_info := _class_info($class_name);
146         my $signature  := signature(@param_types);
147         
148         if $class_info<multisubs>{$multi_name}{$signature} {
149                 NOTE("This trampoline has already been compiled.");
150                 return 0;
151         }
152         
153         $class_info<multisubs>{$multi_name}{$signature} := 1;
154         
155         trampoline($class_name, $multi_name, 
156                 :actions(@actions),
157                 :adverbs(":multi(" ~ $signature ~ ")"
158                         ~ ($is_method ?? ' :method' !! '')),
159                 :is_method($is_method),
160                 :target($target),
161         );
162 }
163
164 sub find_class_named($class_name) {
165         my $class := Opcode::get_class($class_name);
166         
167         unless Opcode::defined($class) {
168                 my @parts := $class_name.split('::');
169                 $class := Opcode::get_class(@parts);
170         
171                 unless Opcode::defined($class) {
172                         $class := Opcode::get_class(
173                                 Opcode::get_namespace($class_name)
174                         );
175                 }
176         }
177         
178         return $class;
179 }
180
181 sub find_method_named($class, $method) {
182         if Opcode::isa($class, 'String') {
183                 NOTE("Got class name: ", $class);
184                 $class := find_class_named($class);
185         }
186         elsif ! Opcode::isa($class, 'Class') {
187                 NOTE("Got object PMC: ", $class);
188                 $class := Opcode::typeof($class);
189                 NOTE("Resolved to Class PMC: ", $class);
190         }
191         else {
192                 NOTE("Got Class PMC: ", $class);
193         }
194         
195         my $result := $class.find_method($method);
196         return $result;
197 }
198
199 sub get_method_list($obj) {
200         my $class := Class::of($obj);
201
202         unless Opcode::defined($class) {
203                 die("No class. Don't know what to do.");
204         }
205
206         my @methods := $class.methods.keys;
207         return @methods;
208 }
209
210 sub _initload() {
211         die("Class::_initload cannot be used. 'Class' must initialize in _pre_initload, WAY before everything else.");
212 }
213
214 sub multi_method($class_name, $multi_name, :$starting_with) {
215         multi_sub($class_name, $multi_name, 
216                 :starting_with($starting_with), :is_method(1));
217 }
218
219 sub multi_sub($class_name, $multi_name, :$starting_with, :$is_method?) {
220         my $kind := $is_method ?? 'multimethod' !! 'multisub';
221         
222         NOTE("Creating new ", $kind, " '", $multi_name, "' for class ", $class_name,
223                 ", out of methods starting with ", $starting_with);
224         
225         my $class_info  := _class_info($class_name);
226         my $nsp         := Opcode::get_hll_namespace($class_name);
227         my $prefix_len  := $starting_with.length;
228         
229         for $nsp {
230                 my $name := ~ $_;
231                 
232                 if $name.substr(0, $prefix_len) eq $starting_with {
233                         my $param_class := $name.substr($prefix_len);
234                         my $param1_class := $param_class.split('_').join('::');
235                         
236                         NOTE("Compiling '", $multi_name, "' handler for (_, ", 
237                                 $param1_class, ")");
238                         Class::compile_multi($class_name,
239                                 $multi_name,
240                                 $param1_class,
241                                 :is_method($is_method),
242                                 :target($name),
243                         );
244                 }
245         }
246
247         NOTE("All matching trampolines built. Adding method to class.");
248         my $multi_sub := $nsp{$multi_name};
249         
250         if $is_method {
251                 # FIXME: Is this needed? Can the class just suck up the multi during creation?
252                 unless $class_info<created> {
253                         die("Class '", $class_name, "' has not been created yet. Cannot add multimethod.");
254                 }
255
256                 # FIXME: Pretty sure this guard is wrong. Need the default, but this doesn't seem smart enough.
257                 unless Opcode::defined($class_info<multisubs>{$multi_name}) {
258                         Class::compile_default_multi($class_name, 
259                                 $multi_name, :is_method($is_method));
260                 }
261
262                 get_meta().add_method($class_name, $multi_name, $multi_sub);
263         }
264         
265         NOTE("done");
266 }
267
268 sub name_of($object, :$delimiter?) {
269         unless Opcode::defined($delimiter) {
270                 $delimiter := '::';
271         }
272         
273         my $class := ~ Class::of($object);
274         $class := $class.split(';').join($delimiter);
275         return $class;
276 }
277
278 sub of($object) {
279         my $class;
280         
281         if Opcode::isa($object, 'P6object') {
282                 $class := Opcode::getattribute($object.HOW, 'parrotclass');
283         }
284         else {
285                 $class := Opcode::typeof($object);
286         }
287         
288         return $class;
289 }
290
291 sub signature(@types) {
292         my @sig_names;
293         
294         for @types {
295                 my $type := ~ $_;
296                 my $type_sig := $type eq '_'
297                         ?? $type
298                         !! "['" ~ $type.split('::').join(q<';'>) ~ "']";
299                 @sig_names.push($type_sig);
300         }
301
302         return @sig_names.join(", ");
303 }
304
305 sub trampoline($namespace, $name, :$target, 
306         :@actions?, :$adverbs?, :$is_method?) 
307 {
308         NOTE("Building trampoline [", $namespace, "::", $name, "] -> ", $target);
309         NOTE("is_method? ", $is_method);
310         NOTE("With adverbs: ", $adverbs);
311
312         unless +@actions {
313                 @actions := Array::empty();
314                 my $target_nsp := $namespace;
315                 
316                 if ! Opcode::isa($target, 'String') {
317                         my @parts := $target.get_namespace.get_name;
318                         @parts.shift;
319                         $target_nsp := @parts.join('::');
320                 
321                         if $target_nsp ne $namespace {
322                                 my $load_p0 := "\t"
323                                         ~ '$P0 = get_hll_global ';      
324                                 $load_p0 := $load_p0
325                                         ~ "[ '" 
326                                         ~ @parts.join(q<' ; '>)
327                                         ~ "' ], '"
328                                         ~ $target
329                                         ~ "'";
330                                 
331                                 @actions.push($load_p0);
332                                 $target := '$P0';
333                         }
334                 }
335                 else {
336                         $target := "'" ~ $target ~ "'";
337                 }
338                 
339                 @actions.push(
340                         "\t" ~ ".tailcall " ~ $target
341                                 ~ "("
342                                 ~ ($is_method ?? 'self, ' !! '')
343                                 ~ "pos :flat, adv :flat :named)"
344                 );
345                 
346         }
347         
348         my @code := Array::new(
349                 ".namespace [ '" 
350                         ~ $namespace.split('::').join(q<' ; '>)
351                         ~ "' ]",
352                 ".sub '" ~ $name ~ "' " ~ $adverbs,
353                 "\t" ~ ".param pmc pos :slurpy",
354                 "\t" ~ ".param pmc adv :slurpy :named",
355         );
356         
357         for @actions {
358                 @code.push("\t" ~ $_);
359         }
360
361         @code.push(
362                 ".end",
363         );
364         
365         my $trampoline := @code.join("\n");
366         NOTE("Trampoline is:\n", $trampoline);
367         Pir::compile($trampoline);
368         NOTE("Trampoline compiled okay.");
369 }       
370
371 ### Moved to P6object.nqp
372
373 sub get_meta() {
374         our $meta;
375         
376         unless Opcode::defined($meta) {
377                 $meta := Opcode::new('P6metaclass');
378         }
379
380         return $meta;
381 }