Catching up after the holidays.
[kakapo:kakapo.git] / src / Parrot / Opcode.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 Opcode;
5 # Provides NQP-callable versions of various Parrot opcodes.
6 # (NOTE: A lot of the code here uses 'method' just to save a find_lex opcode. Don't take it personally.)
7
8 sub _pre_initload() {
9 # Kakapo startup function. Do the Global exports early, so that other modules can import these 
10 # functions during their init processing.
11
12         Global::export(:tags('DEFAULT'),        'defined', 'die');
13         Global::export(:tags('TYPE'),           'can', 'does', 'get_class', 'isa', 'new', 'typeof');
14 }
15
16 sub backtrace() {
17         Q:PIR {
18                 backtrace
19         };
20 }
21
22 method can($method_name) {
23         my $result := Q:PIR {
24                 .local string method_name
25                 $P0 = find_lex '$method_name'
26                 method_name = $P0
27                 
28                 $I0 = can self, method_name
29                 %r = box $I0
30         };
31         
32         return $result;
33 }
34
35 method clone() {
36         my $clone := Q:PIR {
37                 %r = clone self
38         };
39                 
40         return $clone;
41 }
42
43 method defined() {
44         my $result := Q:PIR {
45                 $I0 = defined self
46                 %r = box $I0
47         };
48         
49         return $result;
50 }
51
52 method delete($key) {
53         Q:PIR {
54                 $P0 = find_lex '$key'
55                 delete self[$P0]
56         };
57         
58         return self;
59 }
60
61 sub die(*@parts) {
62         my $message := @parts.join;
63         
64         Q:PIR {
65                 $P0 = find_lex '$message'
66                 $S0 = $P0
67                 die $S0
68         };
69 }
70
71 method does($role) {
72         my $result := Q:PIR {
73                 .local string role
74                 $P0 = find_lex '$role'
75                 role = $P0
76                 
77                 $I0 = does self, role
78                 %r = box $I0
79         };
80
81         return $result;
82 }
83
84 method elements() {
85         my $result := Q:PIR {
86                 $I0 = elements self
87                 %r = box $I0
88         };
89
90         return $result;
91 }
92
93 sub exit($status?) {
94         Q:PIR {
95                 $P0 = find_lex '$status'
96                 $I0 = 0
97                 if null $P0 goto have_status
98                 
99                 $I0 = $P0
100         have_status:
101                 
102                 exit $I0
103         };
104 }
105
106 method find_lex() {
107         my $result := Q:PIR {
108                 $S0 = self
109                 %r = find_lex $S0
110         };
111         
112         return $result;
113 }
114
115 method get_addr() {
116         my $result := Q:PIR {
117                 $I0 = 0
118                 if null self goto done
119                 $I0 = get_addr self
120         done:
121                 %r = box $I0
122         };
123         
124         return $result;
125 }
126
127 method getattribute($name) {
128         my $result := Q:PIR {
129                 $P0 = find_lex '$name'
130                 $S0 = $P0
131                 %r = getattribute self, $S0
132         };
133         
134         return $result;
135 }
136
137 method get_class() {
138         my $result := Q:PIR {
139                 %r = get_class self
140         };
141         
142         return $result;
143 }
144
145 method get_integer() {
146         my $result := Q:PIR {
147                 $I0 = self
148                 %r = box $I0
149         };
150         
151         return $result;
152 }
153
154 method get_global() {
155         my $result := Q:PIR {
156                 $S0 = self
157                 %r = get_global $S0
158         };
159         
160         return $result;
161 }
162                 
163 sub get_hll_global($p1, $p2?) {
164 # May be called with C< ('a::b') >, C< (@names) >, C< ('a::b', 'c') >, or C< (@nsp_names, 'c') >.
165
166         my @parts := isa($p1, 'String') ?? $p1.split('::') !! $p1;
167         
168         if $p2 {
169                 @parts.push($p2);
170         }
171         
172         my $name := @parts.pop;
173
174         my $result := Q:PIR {
175                 $P0 = find_lex '@parts'
176                 $P1 = find_lex '$name'
177                 $S1 = $P1
178                 %r = get_hll_global [$P0], $S1
179         };
180         
181         return $result;
182 }
183
184 sub get_hll_namespace($p1?) {
185 # Can be called C< () >, C< ('a::b') >, or C< (@parts) >.
186
187         my $result;
188         
189         if defined($p1) {
190                 if isa($p1, 'String') {
191                         $p1 := $p1.split('::');
192                 }
193                 
194                 $result := Q:PIR {
195                         $P0 = find_lex '$p1'
196                         %r = get_hll_namespace $P0
197                 };
198         }
199         else {
200                 $result := Q:PIR {
201                         %r = get_hll_namespace
202                 };
203         }
204         
205         return $result;
206 }
207
208 sub getinterp() {
209         my $result := Q:PIR {
210                 %r = getinterp
211         };
212         
213         return $result;
214 }
215
216 sub get_namespace($p1?) {
217 # Can be called C< () >, C< ('a::b') >, or C< (@parts) >.
218
219         my $result;
220         
221         if defined($p1) {
222                 if isa($p1, 'String') {
223                         $p1 := $p1.split('::');
224                 }
225                 
226                 $result := Q:PIR {
227                         $P0 = find_lex '$p1'
228                         %r = get_namespace $P0
229                 };
230         }
231         else {
232                 $result := Parrot::caller_namespace(3);
233         }
234         
235         return $result;
236 }
237
238 sub get_root_global($p1, $p2?) {
239 # May be called with C< ('a::b') >, C< (@names) >, C< ('a::b', 'c') >, or C< (@nsp_names, 'c') >.
240
241         my @parts := isa($p1, 'String') ?? $p1.split('::') !! $p1;
242         
243         if $p2 {
244                 @parts.push($p2);
245         }
246         
247         my $name := @parts.pop;
248         
249         my $result := Q:PIR {
250                 $P0 = find_lex '@parts'
251                 $P1 = find_lex '$name'
252                 $S1 = $P1
253                 %r = get_root_global [$P0], $S1
254         };
255         
256         return $result;
257 }
258
259 sub get_root_namespace(@parts) {
260         my $namespace := Q:PIR {
261                 $P0 = find_lex '@parts'
262                 %r = get_root_namespace $P0
263         };
264         
265         return $namespace;
266 }
267
268 method inspect($key?) {
269         my $result := Q:PIR {
270                 $P0 = find_lex '$key'
271                 $I0 = defined $P0
272                 if $I0 goto inspect_string
273                 
274                 %r = inspect self
275                 goto done
276                 
277         inspect_string:
278                 $S0 = $P0
279                 %r = inspect self, $S0
280         
281         done:
282         };
283         
284         return $result;
285 }
286
287 sub isnull(*@what) {
288         my $result := Q:PIR {
289                 $P0 = find_lex '@what'
290                 $P0 = shift $P0
291                 $I0 = isnull $P0
292                 %r = box $I0
293         };
294         
295         return $result;
296 }
297
298 method isa($class) {
299         my $result := Q:PIR {
300                 $P0 = find_lex '$class'
301                 $S0 = $P0
302                 $I0 = isa self, $S0
303                 %r = box $I0
304         };
305
306         return $result;
307 }
308
309 method iseq($other) {
310         my $result := Q:PIR {
311                 $P0 = find_lex '$other'
312                 $I0 = iseq self, $P0
313                 %r = box $I0
314         };
315         
316         return $result;
317 }
318
319 method join($delim?) {
320         unless defined($delim) { $delim := ''; }
321         my $result := Q:PIR {
322                 $P0 = find_lex '$delim'
323                 $S0 = $P0
324                 $S1 = join $S0, self
325                 %r = box $S1
326         };
327         
328         return $result;
329 }
330
331 sub load_bytecode($path) {
332         Q:PIR {
333                 $P0 = find_lex '$path'
334                 $S0 = $P0
335                 load_bytecode $S0
336         };
337 }
338
339 method load_language() {
340         Q:PIR {
341                 $S0 = self
342                 load_language $S0
343         };
344         
345         return self;
346 }
347
348 sub make_root_namespace($p1) {
349         my $result;
350         
351         if defined($p1) {
352                 my @parts := isa($p1, 'String') ?? $p1.split('::') !! $p1;
353                 
354                 my $nsp := get_root_namespace();
355                 $result := $nsp.make_namespace(@parts);
356         }
357         else {
358                 die("Undefined namespace path");
359         }
360         
361         return $result;
362 }
363
364 sub new($type, $init?) {
365         my $result := Q:PIR {
366                 .local pmc type, init
367                 type = find_lex '$type'
368                 init = find_lex '$init'
369                 
370                 $I0 = defined init
371                 unless $I0 goto no_init
372                 
373                 %r = new type, init
374                 goto done
375                 
376         no_init:
377                 %r = new type
378                 
379         done:
380         };
381         
382         return $result;
383 }
384
385 sub newclass($p1) {
386         my $result := Q:PIR {
387                 $P0 = find_lex '$p1'
388                 %r = newclass $P0
389         };
390         
391         return $result;
392 }
393
394 method setattribute($name, $value) {
395         Q:PIR {
396                 $P0 = find_lex '$name'
397                 $S0 = $P0
398                 $P1 = find_lex '$value'
399                 setattribute self, $S0, $P1
400         };
401 }
402
403 method set_integer($value) {
404         Q:PIR {
405                 $P0 = find_lex '$value'
406                 $I0 = $P0
407                 self = $I0
408         };
409         
410         return $value;
411 }
412
413 method store_lex($value) {
414         Q:PIR {
415                 $S0 = self
416                 $P0 = find_lex '$value'
417                 store_lex $S0, $P0
418         };
419         
420         return $value;
421 }
422
423 sub throw($exc) {
424         Q:PIR {
425                 $P0 = find_lex '$exc'
426                 throw $P0
427         };
428 }
429
430 our sub trace($value) {
431         Q:PIR {
432                 $P0 = find_lex '$value'
433                 $I0 = $P0
434                 trace $I0
435         };
436 }
437
438 our sub typeof($what) {
439         my $result := Q:PIR {
440                 $P0 = find_lex '$what'
441                 unless null $P0 goto get_type
442                 say "typeof <null> is not a valid request"
443                 backtrace
444         get_type:
445                 $S0 = typeof $P0
446                 %r = box $S0
447         };
448
449         return $result;
450 }