Added bootstrap tests for UnitTest::Loader
[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 # Provides NQP-callable versions of various Parrot opcodes.
5 module Opcode;
6
7 # Kakapo startup function. Do the global exports early, so that other modules 
8 # can import these functions during their init processing.
9 sub _pre_initload() {
10
11         export(:tags('DEFAULT'),        'defined');
12         export(:tags('TYPE'),   'can', 'does', 'get_class', 'isa', 'new', 'typeof');
13 }
14
15 sub backtrace()                 { pir::backtrace(); }
16 sub can($object, $method)               { pir::can__IPS($object, $method); }
17 sub class($object)                      { pir::class__PP($object); }
18 sub clone($object)                      { pir::clone($object); }
19 sub defined($object)                    { pir::defined__IP($object); }
20
21 # FIXME: Presently there is no pir:: syntax for delete_p_k, so have to do this.
22 sub delete($object, $key) {
23         Q:PIR {
24                 $P0 = find_lex '$object'
25                 $P1 = find_lex '$key'
26                 delete $P0[$P1]
27         };
28 }
29
30 sub does($object, $role)                { pir::does($object, $role); }
31 sub elements($object)           { pir::elements($object); }
32 sub exit($status)                       { pir::exit($status); }
33 sub get_addr($object)           { pir::get_addr__IP($object); }
34 sub getattribute($object, $name)        { pir::getattribute__PPS($object, $name); }
35 sub get_class($object)          { pir::get_class__PP($object); }
36 sub get_integer($object)                { pir::set__IP($object); }
37 sub get_global($name)           { pir::get_global__PS($name); }
38 sub getinterp()                 { pir::getinterp__P(); }
39 sub get_namespace($namespace)   { pir::get_namespace__PP($namespace); }
40 sub get_root_namespace(@parts)  { pir::get_root_namespace__PP(@parts); }
41 sub inspect($object)                    { pir::inspect__PP($object); }
42 sub inspect_string($object, $key)       { pir::inspect__PPS($object, $key); }
43 sub isnull($object)                     { pir::isnull($object); }
44 sub isa($object, $class)                { pir::isa__IPS($object, $class); }
45 sub iseq($object, $other)               { pir::iseq__IPP($object, $other); }
46 sub join($object, $delim)               { pir::join($delim, $object); }
47 sub load_bytecode($path)                { pir::load_bytecode__vS($path); }
48 sub load_language($name)                { pir::load_language__vS($name); }
49 sub new($type)                  { pir::new__PP($type); } # FIXME: __PP or __PS
50 sub newclass($name)             { pir::newclass__PP($name); }
51 sub setattribute($object, $name, $value) { pir::setattribute__vPSP($object, $name, $value); }
52 # FIXME: Not sure if this should be 'assign' or 'set'
53 sub set_integer($object, $value)        { pir::assign__vPI($object, $value); }
54 sub throw($exception)           { pir::throw($exception); }
55 sub typeof($object)                     { pir::typeof__SP($object); }
56
57 ### FIXME: Move this to Parrot:: or something.
58
59 sub get_hll_global($p1, $p2?) {
60 # May be called with C< ('a::b') >, C< (@names) >, C< ('a::b', 'c') >, or C< (@nsp_names, 'c') >.
61
62         my @parts := isa($p1, 'String') ?? $p1.split('::') !! $p1;
63
64         if $p2 {
65                 @parts.push($p2);
66         }
67         
68         my $name := @parts.pop;
69
70         my $result := Q:PIR {
71                 $P0 = find_lex '@parts'
72                 $P1 = find_lex '$name'
73                 $S1 = $P1
74                 %r = get_hll_global [$P0], $S1
75         };
76         
77         return $result;
78 }
79
80 sub get_root_global($p1, $p2?) {
81 # May be called with C< ('a::b') >, C< (@names) >, C< ('a::b', 'c') >, or C< (@nsp_names, 'c') >.
82         
83         my @parts := pir::isa($p1, 'String') ?? $p1.split('::') !! $p1;
84         
85         if $p2 {
86                 @parts.push($p2);
87         }
88
89         my $name := @parts.pop;
90         
91         my $result := Q:PIR {
92                 $P0 = find_lex '@parts'
93                 $P1 = find_lex '$name'
94                 $S1 = $P1
95                 %r = get_root_global [$P0], $S1
96         };
97         
98         return $result;
99 }
100
101 sub make_root_namespace($p1) {
102         my $result;
103         
104         if defined($p1) {
105                 my @parts := isa($p1, 'String') ?? $p1.split('::') !! $p1;
106                 
107                 my $nsp := get_root_namespace();
108                 $result := $nsp.make_namespace(@parts);
109         }
110         else {
111                 die("Undefined namespace path");
112         }
113         
114         return $result;
115 }