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