a few fixes and changes. I think if I refocus my efforts on making the method injecti...
[kakapo:kakapo.git] / src / Parrot / Parrot.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 # Provides access to low-level functions of the Parrot VM.
5 module Parrot;
6
7 sub _pre_initload() {
8         Global::inject_root_symbol(Parrot::is_null);
9         Global::inject_root_symbol(Parrot::isa);
10 }
11
12 # NB: index defaults to 1, and create_key adds 1, for '2', because the default is 1 higher than
13 # the sub that *called* this sub. (foo() calls bar() calls caller(), caller returns 'foo')
14 sub caller($index? = 1) {
15         my $key := Key::create_key('sub', 1 + $index);
16         my &sub := pir::getinterp__P(){$key};
17 }
18
19 # NB: index defaults to 1, and create_key adds 1, for '2', because the default is 1 higher than
20 # the sub that *called* this sub. (foo() calls bar() calls caller(), caller returns 'foo')
21 sub caller_namespace($index? = 1) {
22         my $key := Key::create_key('namespace', $index + 1);
23         my $nsp := pir::getinterp__P(){$key};
24 }
25
26 sub call_method($object, $method_name, *@args, *%opts) {
27         call_method_($object, $method_name, @args, %opts);
28 }
29
30 # Calls method C< $method_name > with flattened arglist C< @args > and flattened
31 # options C< %opts >. Returns the result of the method call.
32 sub call_method_($object, $method_name, @args?, %opts?) {
33
34         Q:PIR {
35                 .local pmc object, meth, args, opts
36                 object  = find_lex '$object'
37                 meth    = find_lex '$method_name'
38                 args    = find_lex '@args'
39                 opts    = find_lex '%opts'
40
41                 $I0 = isa meth, 'Sub'
42                 unless $I0 goto call_string
43
44                 .tailcall object.meth(args :flat, opts :named :flat)
45
46         call_string:
47                 $S0 = meth
48                 .tailcall object.$S0(args :flat, opts :named :flat)
49         };
50 }
51
52 sub call_tuple_method($object, $method, *@args, *%opts) {
53         call_tuple_method_($object, $method, @args, %opts);
54 }
55
56 # Calls method C< $method_name > with flattened arglist C< @args > and flattened
57 # options C< %opts >. Returns an RPA with the tuple returned by the method.
58 sub call_tuple_method_($object, $method, @args?, %opts?) {
59
60         Q:PIR {
61                 .local pmc object, meth, args, opts
62                 object  = find_lex '$object'
63                 meth    = find_lex '$method'
64                 args    = find_lex '@args'
65                 opts    = find_lex '%opts'
66
67                 $I0 = isa meth, 'Sub'
68                 unless $I0 goto call_string
69
70                 ( $P0 :slurpy ) = object.meth(args :flat, opts :named :flat)
71                 .return ($P0)
72
73         call_string:
74                 $S0 = meth
75                 ( $P0 :slurpy ) = object.$S0(args :flat, opts :named :flat)
76                 .return ($P0)
77         };
78 }
79
80 sub call_sub($sub_name, *@args, *%opts) {
81         return call_sub_($sub_name, @args, %opts);
82 }
83
84 sub call_sub_($sub_name, @args, %opts) {
85 # Calls sub C< $sub_name > with flattened arglist C< @args > and flattened options C< %opts >.
86 # Returns the result of the sub call.
87
88         Q:PIR {
89                 .local pmc sub, args, opts
90                 sub     = find_lex '$sub_name'
91                 args    = find_lex '@args'
92                 opts    = find_lex '%opts'
93
94                 $I0 = isa sub, 'Sub'
95                 if $I0 goto call_sub
96
97                 $S0 = sub
98                 sub = find_sub_not_null $S0
99
100         call_sub:
101                 .tailcall sub(args :flat, opts :named :flat)
102         };
103 }
104
105 sub call_tuple_sub($sub, *@args, *%opts) {
106         call_tuple_sub_($sub, @args, %opts);
107 }
108
109 sub call_tuple_sub_($sub, @args?, %opts?) {
110 # Calls sub C< $sub > with flattened arglist C< @args > and flattened
111 # options C< %opts >. Returns an RPA with the tuple returned by the sub.
112
113         unless Opcode::defined(@args)   { @args := Array::new(); }
114         unless Opcode::defined(%opts)   { %opts := Hash::empty(); }
115
116         Q:PIR {
117                 .local pmc sub, args, opts
118                 sub     = find_lex '$sub'
119                 args    = find_lex '@args'
120                 opts    = find_lex '%opts'
121
122                 $I0 = isa sub, 'Sub'
123                 if $I0 goto call_sub
124
125                 $S0 = sub
126                 sub = find_sub_not_null $S0
127
128         call_sub:
129                 ( $P0 :slurpy ) = sub(args :flat, opts :named :flat)
130                 .return ($P0)
131         };
132 }
133
134 sub get_address_of($what) {
135         return Opcode::get_addr($what);
136 }
137
138 # Return a global object by name.
139 sub get_hll_global($path) {
140         if $path.isa('String') {
141                 $path := $path.split('::');
142         }
143
144         unless pir::does__IPS($path, 'array') {
145                 die("$path parameter must be a ::string or array of strings, not: ", $path);
146         }
147
148         my $name := $path.pop;
149         my $key := key_($path);
150
151         $key.defined
152                 ?? pir::get_hll_global__PPS($key, $name)
153                 !! pir::get_hll_global__PS($name);
154 }
155
156 # Return a namespace relative to the HLL root namespace.
157 #
158 # If no C< $path > is specified, returns the HLL root namespace. Otherwise, fetches
159 # the namespace identified by C< $path >, which can either be a string in A::B::C
160 # format, or a key. (See L< key() >, below.)
161
162 sub get_hll_namespace($path?) {
163
164         my $result;
165
166         if pir::defined__IP($path) {
167                 if pir::isa__IPS($path, 'String') {
168                         $path := key_(pir::split__PSS('::', $path));
169                 }
170
171                 $result := pir::get_hll_namespace__PP($path);
172         }
173         else {
174                 $result := pir::get_hll_namespace__P();
175         }
176
177         $result;
178 }
179
180 sub get_self() {
181         my $self := pir::find_dynamic_lex__PS('self');
182
183         if pir::isnull($self) {
184                 pir::die("Fatal: No 'self' lexical in any caller scope");
185         }
186
187         return $self;
188 }
189
190 sub get_sub($path, :$caller_nsp?) {
191         my @parts := $path.split('::');
192         my $name := @parts.pop;
193         my &sub;
194
195         if +@parts == 0 {       # Check in caller nsp
196                 unless $caller_nsp { $caller_nsp := caller_namespace(2); }
197
198                 &sub := $caller_nsp.find_sub($name);
199
200                 if Opcode::defined(&sub) {
201                         return &sub;
202                 }
203         }
204
205         my $namespace := Opcode::get_hll_namespace(@parts);
206
207         if $namespace {
208                 &sub := $namespace.find_sub($name);
209         }
210
211         return &sub;
212 }
213
214 sub isa($obj, $class) {
215         if pir::isa__IPS($class, 'P6protoobject') {
216                 $class := P6metaclass.get_parrotclass($class);
217         }
218         elsif pir::isa__IPS($class, 'String') {
219                 $class := $class.split('::');
220
221                 if pir::elements__IP($class) == 1 {
222                         $class := $class.shift;
223                 }
224         }
225
226         pir::isa__IPP($obj, $class);
227 }
228
229 sub is_null($obj) {
230         pir::isnull__IP($obj);
231 }
232
233 sub key($first, *@parts) {
234         @parts.unshift($first);
235         key_(@parts);
236 }
237
238 sub key_(@parts) {
239         my $key;
240
241         for @parts {
242                 my $element := $_;
243                 Q:PIR {
244                         .local pmc segment
245                         segment = new [ 'Key' ]
246
247                         .local pmc element
248                         element = find_lex '$element'
249
250                         $I0 = isa element, 'Integer'
251                         unless $I0 goto not_Integer
252                         $I0 = element
253                         segment = $I0
254                         goto have_key
255
256                 not_Integer:
257
258                         $I0 = isa element, 'Float'
259                         unless $I0 goto not_Float
260                         $N0 = element
261                         segment = $N0
262                         goto have_key
263
264                 not_Float:
265
266                         $I0 = isa element, 'String'
267                         unless $I0 goto not_String
268                         $S0 = element
269                         segment = $S0
270                         goto have_key
271
272                 not_String:
273                         die "Invalid PMC type passed to Parrot::key"
274
275                 have_key:
276                         .local pmc key
277                         key = find_lex '$key'
278
279                         $I0 = isa key, 'Key'
280                         unless $I0 goto set_key
281                         push key, segment
282                         goto done
283
284                 set_key:
285                         key = segment
286                         store_lex '$key', key
287
288                 done:
289                 };
290         }
291
292         $key;
293 }
294
295 sub macro_const( $namespace = caller_namespace(), :@TAGS, *%named ) {
296         for %named -> $macro {
297                 my $name := $macro.key;
298
299                 die("Cannot define macro $name in namespace {$namespace.string_name} - a symbol with that name already exists")
300                         if $namespace.contains( $name );
301
302                 $namespace.add_var($name, $macro.value);
303         }
304 }
305
306 sub namespace_name($nsp) {
307         pir::isa($nsp, 'String')
308                 ?? $nsp
309                 !! $nsp.string_name;
310 }
311
312 sub new($pmc, %args?) {
313         my $key := Key.new(|$pmc.split('::'));
314
315         %args.elems == 0
316                 ?? pir::new__PP($key)
317                 !! pir::new__PPP($key, %args);
318 }
319
320 sub qualified_name($x, :$namespace = caller_namespace(2)) {
321         if pir::isa__IPS($x, 'P6protoobject') {
322                 $x := $x.WHO;                   # namespace
323         }
324         elsif pir::isa__IPS($x, 'Class') || pir::isa__IPS($x, 'PMCProxy') {
325                 $x := $x.get_namespace;         # namespace
326         }
327
328         ## break
329
330         if pir::isa__IPS($x, 'NameSpace') {
331                 $x := $x.get_name.join('::');
332         }
333         elsif pir::isa__IPS($x, 'String') {
334                 if pir::split('::', $x) > 1 {
335                         # keep it
336                 }
337                 else {
338                         my @temp := pir::split(';', $x);
339
340                         if @temp == 1 {
341                                 @temp := $namespace.get_name;
342                                 @temp.push($x);
343                         }
344
345                         $x := @temp.join('::');
346                 }
347         }
348         elsif pir::isa__IPS($x, 'Sub') {        # includes MultiSubs
349                 my @temp := $x.get_namespace.get_name;
350                 @temp.push( ~$x );
351                 $x := @temp.join('::');
352         }
353         else {
354                 my $type := pir::typeof__SP($x);
355                 die("Don't know how to make qualified name from $type: $x");
356         }
357
358         $x;
359 }
360
361 # Return a global object by name.
362 sub set_hll_global($path, $value) {
363         if $path.isa('String') {
364                 $path := $path.split('::');
365         }
366
367         unless pir::does__IPS($path, 'array') {
368                 die("$path parameter must be a ::string or array of strings, not: ", $path);
369         }
370
371         my $name := $path.pop;
372         my $key := key_($path);
373
374         $key.defined
375                 ?? pir::set_hll_global__vPSP($key, $name, $value)
376                 !! pir::set_hll_global__vSP($name, $value);
377 }