More Array functions! Plus got rid of ::empty.
[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 class Parrot;
5 # Provides access to low-level functions of the Parrot VM.
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 sub caller($index? = 1) {
28         my $key := Key.new('sub', $index + 1);
29         my $sub := pir::getinterp__P(){$key};
30 }
31
32
33 sub caller_namespace($index?) {
34         unless $index {
35                 $index := 1;
36         }
37         
38         my $nsp := Q:PIR {
39                 .local pmc key
40                 key = new 'Key'
41                 key = 'namespace'
42                 $P0 = find_lex '$index'
43                 $S0 = $P0
44                 $P1 = new 'Key'
45                 $P1 = $S0
46                 push key, $P1
47                 
48                 $P0 = getinterp
49                 %r = $P0[ key ]
50         };
51         
52         return $nsp;
53 }
54
55 sub call_method($object, $method_name, *@args, *%opts) {
56         call_method_($object, $method_name, @args, %opts);
57 }
58
59 sub call_method_($object, $method_name, @args?, %opts?) {
60 # Calls method C< $method_name > with flattened arglist C< @args > and flattened 
61 # options C< %opts >. Returns the result of the method call.
62
63         unless Opcode::defined(@args)   { @args := Array::new(); }
64         unless Opcode::defined(%opts)   { %opts := Hash::empty(); }
65         
66         Q:PIR {
67                 .local pmc object, meth, args, opts
68                 object  = find_lex '$object'
69                 meth    = find_lex '$method_name'
70                 args    = find_lex '@args'
71                 opts    = find_lex '%opts'
72                 
73                 $I0 = isa meth, 'Sub'
74                 unless $I0 goto call_string
75                 
76                 .tailcall object.meth(args :flat, opts :named :flat)
77                 
78         call_string:
79                 $S0 = meth
80                 .tailcall object.$S0(args :flat, opts :named :flat)
81         };
82 }
83
84 sub call_tuple_method($object, $method, *@args, *%opts) {
85         call_tuple_method_($object, $method, @args, %opts);
86 }
87
88 sub call_tuple_method_($object, $method, @args?, %opts?) {
89 # Calls method C< $method_name > with flattened arglist C< @args > and flattened 
90 # options C< %opts >. Returns an RPA with the tuple returned by the method.
91
92         unless Opcode::defined(@args)   { @args := Array::new(); }
93         unless Opcode::defined(%opts)   { %opts := Hash::empty(); }
94         
95         Q:PIR {
96                 .local pmc object, meth, args, opts
97                 object  = find_lex '$object'
98                 meth    = find_lex '$method'
99                 args    = find_lex '@args'
100                 opts    = find_lex '%opts'
101                 
102                 $I0 = isa meth, 'Sub'
103                 unless $I0 goto call_string
104                 
105                 ( $P0 :slurpy ) = object.meth(args :flat, opts :named :flat)
106                 .return ($P0)
107                 
108         call_string:
109                 $S0 = meth
110                 ( $P0 :slurpy ) = object.$S0(args :flat, opts :named :flat)
111                 .return ($P0)
112         };
113 }
114
115 sub call_sub($sub_name, *@args, *%opts) {
116         return call_sub_($sub_name, @args, %opts);
117 }
118
119 sub call_sub_($sub_name, @args, %opts) {
120 # Calls sub C< $sub_name > with flattened arglist C< @args > and flattened options C< %opts >. 
121 # Returns the result of the sub call.
122
123         Q:PIR {
124                 .local pmc sub, args, opts
125                 sub     = find_lex '$sub_name'
126                 args    = find_lex '@args'
127                 opts    = find_lex '%opts'
128                 
129                 $I0 = isa sub, 'Sub'
130                 if $I0 goto call_sub
131                 
132                 $S0 = sub
133                 sub = find_sub_not_null $S0
134                 
135         call_sub:
136                 .tailcall sub(args :flat, opts :named :flat)
137         };
138 }
139
140 sub call_tuple_sub($sub, *@args, *%opts) {
141         call_tuple_sub_($sub, @args, %opts);
142 }
143
144 sub call_tuple_sub_($sub, @args?, %opts?) {
145 # Calls sub C< $sub > with flattened arglist C< @args > and flattened 
146 # options C< %opts >. Returns an RPA with the tuple returned by the sub.
147
148         unless Opcode::defined(@args)   { @args := Array::new(); }
149         unless Opcode::defined(%opts)   { %opts := Hash::empty(); }
150         
151         Q:PIR {
152                 .local pmc sub, args, opts
153                 sub     = find_lex '$sub'
154                 args    = find_lex '@args'
155                 opts    = find_lex '%opts'
156                 
157                 $I0 = isa sub, 'Sub'
158                 if $I0 goto call_sub
159                 
160                 $S0 = sub
161                 sub = find_sub_not_null $S0
162         
163         call_sub:
164                 ( $P0 :slurpy ) = sub(args :flat, opts :named :flat)
165                 .return ($P0)           
166         };
167 }
168
169 sub get_address_of($what) {
170         return Opcode::get_addr($what);
171 }
172
173 #! _get_interpreter cached the interp. Moved to Opcode and dumbed down. Recode your stuff.
174
175 # Return a global object by name.
176 sub get_hll_global($path) {
177         if $path.isa('String') {
178                 $path := $path.split('::');
179         }
180         
181         unless pir::does__IPS($path, 'array') {
182                 die("$path parameter must be a ::string or array of strings, not: ", $path);
183         }
184         
185         my $name := $path.pop;
186         my $key := key_($path);
187         
188         pir::get_hll_global__PPS(key_($path), $name);
189 }
190
191 # Return a namespace relative to the HLL root namespace.
192 #
193 # If no C< $path > is specified, returns the HLL root namespace. Otherwise, fetches
194 # the namespace identified by C< $path >, which can either be a string in A::B::C 
195 # format, or a key. (See L< key() >, below.)
196
197 sub get_hll_namespace($path?) {
198
199         my $result;
200         
201         if pir::defined__IP($path) {
202                 if pir::isa__IPS($path, 'String') {
203                         $path := key_(pir::split__PSS('::', $path));
204                 }
205                 
206                 $result := pir::get_hll_namespace__PP($path);
207         }
208         else {
209                 $result := pir::get_hll_namespace__P();
210         }
211
212         $result;
213 }
214
215 sub get_self() {
216         my $self := pir::find_dynamic_lex__PS('self');
217         
218         if pir::isnull($self) {
219                 pir::die("Fatal: No 'self' lexical in any caller scope");
220         }
221         
222         return $self;
223 }
224
225 sub get_sub($path, :$caller_nsp?) {
226         my @parts := $path.split('::');
227         my $name := @parts.pop;
228         my &sub;
229         
230         if +@parts == 0 {       # Check in caller nsp
231                 unless $caller_nsp { $caller_nsp := caller_namespace(2); }
232                 
233                 &sub := $caller_nsp.find_sub($name);
234                 
235                 if Opcode::defined(&sub) {
236                         return &sub;
237                 }
238         }
239
240         my $namespace := Opcode::get_hll_namespace(@parts);
241         
242         if $namespace {
243                 &sub := $namespace.find_sub($name);
244         }
245         
246         return &sub;
247 }
248
249 sub key($first, *@parts) {
250         @parts.unshift($first);
251         key_(@parts);
252 }
253
254 sub key_(@parts) {
255         my $key;
256
257         for @parts {
258                 my $element := $_;
259                 Q:PIR {
260                         .local pmc segment
261                         segment = new [ 'Key' ]
262                         
263                         .local pmc element
264                         element = find_lex '$element'
265                         
266                         $I0 = isa element, 'Integer'
267                         unless $I0 goto not_Integer
268                         $I0 = element
269                         segment = $I0
270                         goto have_key
271                         
272                 not_Integer:
273                         
274                         $I0 = isa element, 'Float'
275                         unless $I0 goto not_Float
276                         $N0 = element
277                         segment = $N0
278                         goto have_key
279                         
280                 not_Float:
281                         
282                         $I0 = isa element, 'String'
283                         unless $I0 goto not_String
284                         $S0 = element
285                         segment = $S0
286                         goto have_key
287                         
288                 not_String:
289                         die "Invalid PMC type passed to Parrot::key"
290                         
291                 have_key:
292                         .local pmc key
293                         key = find_lex '$key'
294                         
295                         $I0 = isa key, 'Key'
296                         unless $I0 goto set_key
297                         push key, segment
298                         goto done
299                 
300                 set_key:
301                         key = segment
302                         store_lex '$key', key
303                         
304                 done:
305                 };
306         }
307         
308         $key;
309 }
310
311 sub namespace_name($nsp) {
312         pir::isa($nsp, 'String') 
313                 ?? $nsp
314                 !! $nsp.string_name;
315 }
316
317 method new($pmc, %args?) {
318         my $key := Key.new_($pmc.split('::'));
319         
320         %args.elements == 0
321                 ?? pir::new__PP($key)
322                 !! pir::new__PPP($key, %args);
323 }