Merge branch 'master' of gitorious.org:kakapo/kakapo
[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 := Pmc::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         # NB: This sub is called VERY EARLY. Don't try to use $obj.method syntax here.
141         
142         if pir::isa__ips( $path, 'String' ) {
143                 $path := pir::split__pss( '::', $path );
144         }
145
146         unless pir::does__IPS($path, 'array') {
147                 die("$path parameter must be a ::string or array of strings, not: ", $path);
148         }
149
150         my $name := $path.pop;
151         my $key := key_($path);
152         
153         pir::defined( $key )
154                 ?? pir::get_hll_global__PPS($key, $name)
155                 !! pir::get_hll_global__PS($name);
156 }
157
158 # Return a namespace relative to the HLL root namespace.
159 #
160 # If no C< $path > is specified, returns the HLL root namespace. Otherwise, fetches
161 # the namespace identified by C< $path >, which can either be a string in A::B::C
162 # format, or a key. (See L< key() >, below.)
163
164 sub get_hll_namespace($path?) {
165
166         my $result;
167
168         if pir::defined__IP($path) {
169                 if pir::isa__IPS($path, 'String') {
170                         $path := key_(pir::split__PSS('::', $path));
171                 }
172
173                 $result := pir::get_hll_namespace__PP($path);
174         }
175         else {
176                 $result := pir::get_hll_namespace__P();
177         }
178
179         $result;
180 }
181
182 sub get_self() {
183         my $self := pir::find_dynamic_lex__PS('self');
184
185         if pir::isnull($self) {
186                 pir::die("Fatal: No 'self' lexical in any caller scope");
187         }
188
189         return $self;
190 }
191
192 sub get_sub($path, :$caller_nsp?) {
193         my @parts := $path.split('::');
194         my $name := @parts.pop;
195         my &sub;
196
197         if +@parts == 0 {       # Check in caller nsp
198                 unless $caller_nsp { $caller_nsp := caller_namespace(2); }
199
200                 &sub := $caller_nsp.find_sub($name);
201
202                 if Opcode::defined(&sub) {
203                         return &sub;
204                 }
205         }
206
207         my $namespace := Opcode::get_hll_namespace(@parts);
208
209         if $namespace {
210                 &sub := $namespace.find_sub($name);
211         }
212
213         return &sub;
214 }
215
216 sub isa($obj, $class) {
217         if pir::isa__IPS($class, 'P6protoobject') {
218                 $class := P6metaclass.get_parrotclass($class);
219         }
220         elsif pir::isa__IPS($class, 'String') {
221                 $class := $class.split('::');
222
223                 if pir::elements__IP($class) == 1 {
224                         $class := $class.shift;
225                 }
226         }
227
228         pir::isa__IPP($obj, $class);
229 }
230
231 sub is_null($obj) {
232         pir::isnull__IP($obj);
233 }
234
235 sub key($first, *@parts) {
236         @parts.unshift($first);
237         key_(@parts);
238 }
239
240 sub key_(@parts) {
241         my $key;
242
243         for @parts {
244                 my $element := $_;
245                 Q:PIR {
246                         .local pmc segment
247                         segment = new [ 'Key' ]
248
249                         .local pmc element
250                         element = find_lex '$element'
251
252                         $I0 = isa element, 'Integer'
253                         unless $I0 goto not_Integer
254                         $I0 = element
255                         segment = $I0
256                         goto have_key
257
258                 not_Integer:
259
260                         $I0 = isa element, 'Float'
261                         unless $I0 goto not_Float
262                         $N0 = element
263                         segment = $N0
264                         goto have_key
265
266                 not_Float:
267
268                         $I0 = isa element, 'String'
269                         unless $I0 goto not_String
270                         $S0 = element
271                         segment = $S0
272                         goto have_key
273
274                 not_String:
275                         die "Invalid PMC type passed to Parrot::key"
276
277                 have_key:
278                         .local pmc key
279                         key = find_lex '$key'
280
281                         $I0 = isa key, 'Key'
282                         unless $I0 goto set_key
283                         push key, segment
284                         goto done
285
286                 set_key:
287                         key = segment
288                         store_lex '$key', key
289
290                 done:
291                 };
292         }
293
294         $key;
295 }
296
297 sub macro_const( $namespace = caller_namespace(), :@TAGS, *%named ) {
298         for %named -> $macro {
299                 my $name := $macro.key;
300
301                 die("Cannot define macro $name in namespace {$namespace.string_name} - a symbol with that name already exists")
302                         if $namespace.contains( $name );
303
304                 $namespace.add_var($name, $macro.value);
305         }
306 }
307
308 sub namespace_name($nsp) {
309         pir::isa($nsp, 'String')
310                 ?? $nsp
311                 !! $nsp.string_name;
312 }
313
314 sub new($pmc, %args?) {
315         my $key := Key.new(|$pmc.split('::'));
316
317         %args.elems == 0
318                 ?? pir::new__PP($key)
319                 !! pir::new__PPP($key, %args);
320 }
321
322 sub qualified_name($x, :$namespace = caller_namespace(2)) {
323         if pir::isa__IPS($x, 'P6protoobject') {
324                 $x := $x.WHO;                   # namespace
325         }
326         elsif pir::isa__IPS($x, 'Class') || pir::isa__IPS($x, 'PMCProxy') {
327                 $x := $x.get_namespace;         # namespace
328         }
329
330         ## break
331
332         if pir::isa__IPS($x, 'NameSpace') {
333                 $x := $x.get_name.join('::');
334         }
335         elsif pir::isa__IPS($x, 'String') {
336                 if pir::split('::', $x) > 1 {
337                         # keep it
338                 }
339                 else {
340                         my @temp := pir::split(';', $x);
341
342                         if @temp == 1 {
343                                 @temp := $namespace.get_name;
344                                 @temp.push($x);
345                         }
346
347                         $x := @temp.join('::');
348                 }
349         }
350         elsif pir::isa__IPS($x, 'Sub') {        # includes MultiSubs
351                 my @temp := $x.get_namespace.get_name;
352                 @temp.push( ~$x );
353                 $x := @temp.join('::');
354         }
355         else {
356                 my $type := pir::typeof__SP($x);
357                 die("Don't know how to make qualified name from $type: $x");
358         }
359
360         $x;
361 }
362
363 # Return a global object by name.
364 sub set_hll_global($path, $value) {
365         if $path.isa('String') {
366                 $path := $path.split('::');
367         }
368
369         unless pir::does__IPS($path, 'array') {
370                 die("$path parameter must be a ::string or array of strings, not: ", $path);
371         }
372
373         my $name := $path.pop;
374         my $key := key_($path);
375
376         $key.defined
377                 ?? pir::set_hll_global__vPSP($key, $name, $value)
378                 !! pir::set_hll_global__vSP($name, $value);
379 }