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