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