* Some rudimentary changes to 'Program' to get it working.
[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                 if pir::elements__IP($class) == 1 {
240                         $class := $class.shift;
241                 }
242         }
243         
244         pir::isa__IPP($obj, $class);
245 }
246
247 sub is_null($obj) {
248         pir::isnull__IP($obj);
249 }
250
251 sub key($first, *@parts) {
252         @parts.unshift($first);
253         key_(@parts);
254 }
255
256 sub key_(@parts) {
257         my $key;
258
259         for @parts {
260                 my $element := $_;
261                 Q:PIR {
262                         .local pmc segment
263                         segment = new [ 'Key' ]
264                         
265                         .local pmc element
266                         element = find_lex '$element'
267                         
268                         $I0 = isa element, 'Integer'
269                         unless $I0 goto not_Integer
270                         $I0 = element
271                         segment = $I0
272                         goto have_key
273                         
274                 not_Integer:
275                         
276                         $I0 = isa element, 'Float'
277                         unless $I0 goto not_Float
278                         $N0 = element
279                         segment = $N0
280                         goto have_key
281                         
282                 not_Float:
283                         
284                         $I0 = isa element, 'String'
285                         unless $I0 goto not_String
286                         $S0 = element
287                         segment = $S0
288                         goto have_key
289                         
290                 not_String:
291                         die "Invalid PMC type passed to Parrot::key"
292                         
293                 have_key:
294                         .local pmc key
295                         key = find_lex '$key'
296                         
297                         $I0 = isa key, 'Key'
298                         unless $I0 goto set_key
299                         push key, segment
300                         goto done
301                 
302                 set_key:
303                         key = segment
304                         store_lex '$key', key
305                         
306                 done:
307                 };
308         }
309         
310         $key;
311 }
312
313 sub namespace_name($nsp) {
314         pir::isa($nsp, 'String') 
315                 ?? $nsp
316                 !! $nsp.string_name;
317 }
318
319 sub new($pmc, %args?) {
320         my $key := Key.new(|$pmc.split('::'));
321         
322         %args.elems == 0
323                 ?? pir::new__PP($key)
324                 !! pir::new__PPP($key, %args);
325 }
326
327 sub qualified_name($x, :$namespace = caller_namespace(2)) {
328         if pir::isa__IPS($x, 'P6protoobject') {
329                 $x := $x.WHO;                   # namespace
330         }
331         elsif pir::isa__IPS($x, 'Class') || pir::isa__IPS($x, 'PMCProxy') {
332                 $x := $x.get_namespace;         # namespace
333         }
334         
335         ## break
336         
337         if pir::isa__IPS($x, 'NameSpace') {
338                 $x := $x.get_name.join('::');
339         }
340         elsif pir::isa__IPS($x, 'String') {
341                 if pir::split('::', $x) > 1 {
342                         # keep it
343                 }
344                 else {
345                         my @temp := pir::split(';', $x);
346                         
347                         if @temp == 1 {
348                                 @temp := $namespace.get_name;
349                                 @temp.push($x);
350                         }
351                         
352                         $x := @temp.join('::');
353                 }
354         }
355         elsif pir::isa__IPS($x, 'Sub') {        # includes MultiSubs
356                 my @temp := $x.get_namespace.get_name;
357                 @temp.push( ~$x );
358                 $x := @temp.join('::');
359         }
360         else {
361                 my $type := pir::typeof__SP($x);
362                 die("Don't know how to make qualified name from $type: $x");
363         }
364         
365         $x;
366 }