Fix everything so kakapo builds. Most failures involved the now-missing IO dynops.
[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()
16 {
17     # TODO: backtrace causes an IMCC parse error. It might be a dynop now
18     #pir::backtrace();
19 }
20
21 sub can($object, $method)               { pir::can__IPS($object, $method); }
22 sub class($object)                      { pir::class__PP($object); }
23 sub clone($object)                      { pir::clone($object); }
24 sub defined($object)                    { pir::defined__IP($object); }
25
26 # FIXME: Presently there is no pir:: syntax for delete_p_k, so have to do this.
27 sub delete($object, $key) {
28         Q:PIR {
29                 $P0 = find_lex '$object'
30                 $P1 = find_lex '$key'
31                 delete $P0[$P1]
32         };
33 }
34
35 sub does($object, $role)                { pir::does($object, $role); }
36 sub elements($object)           { pir::elements($object); }
37 sub exit($status)                       { pir::exit($status); }
38 sub find_method($object, $name) { pir::find_method__PPS($object, $name); }
39 sub get_addr($object)           { pir::get_addr__IP($object); }
40 sub getattribute($object, $name)        { pir::getattribute__PPS($object, $name); }
41 sub get_class($object)          { pir::get_class__PP($object); }
42 sub get_integer($object)                { pir::set__IP($object); }
43 sub get_global($name)           { pir::get_global__PS($name); }
44 sub getinterp()                 { pir::getinterp__P(); }
45 sub get_namespace($namespace)   { pir::get_namespace__PP($namespace); }
46 sub get_root_namespace(@parts)  { pir::get_root_namespace__PP(@parts); }
47 sub inspect($object)                    { pir::inspect__PP($object); }
48 sub inspect_string($object, $key)       { pir::inspect__PPS($object, $key); }
49 sub isnull($object)                     { pir::isnull($object); }
50 sub isa($object, $class)                { pir::isa__IPS($object, $class); }
51 sub iseq($object, $other)               { pir::iseq__IPP($object, $other); }
52 sub join($object, $delim)               { pir::join($delim, $object); }
53 sub load_bytecode($path)                { pir::load_bytecode__vS($path); }
54 sub load_language($name)                { pir::load_language__vS($name); }
55 sub new($type)                  { pir::new__PP($type); } # FIXME: __PP or __PS
56 sub newclass($name)             { pir::newclass__PP($name); }
57 sub setattribute($object, $name, $value) { pir::setattribute__vPSP($object, $name, $value); }
58 # FIXME: Not sure if this should be 'assign' or 'set'
59 sub set_integer($object, $value)        { pir::assign__vPI($object, $value); }
60 sub throw($exception)           { pir::throw($exception); }
61 sub typeof($object)                     { pir::typeof__SP($object); }
62
63 ### FIXME: Move this to Parrot:: or something.
64
65 sub get_hll_global($p1, $p2?) {
66 # May be called with C< ('a::b') >, C< (@names) >, C< ('a::b', 'c') >, or C< (@nsp_names, 'c') >.
67
68         my @parts := isa($p1, 'String') ?? $p1.split('::') !! $p1;
69
70         if $p2 {
71                 @parts.push($p2);
72         }
73
74         my $name := @parts.pop;
75
76         my $result := Q:PIR {
77                 $P0 = find_lex '@parts'
78                 $P1 = find_lex '$name'
79                 $S1 = $P1
80                 %r = get_hll_global [$P0], $S1
81         };
82
83         return $result;
84 }
85
86 sub get_root_global($p1, $p2?) {
87 # May be called with C< ('a::b') >, C< (@names) >, C< ('a::b', 'c') >, or C< (@nsp_names, 'c') >.
88
89         my @parts := pir::isa($p1, 'String') ?? $p1.split('::') !! $p1;
90
91         if $p2 {
92                 @parts.push($p2);
93         }
94
95         my $name := @parts.pop;
96
97         my $result := Q:PIR {
98                 $P0 = find_lex '@parts'
99                 $P1 = find_lex '$name'
100                 $S1 = $P1
101                 %r = get_root_global [$P0], $S1
102         };
103
104         return $result;
105 }
106
107 sub make_root_namespace($p1) {
108         my $result;
109
110         if defined($p1) {
111                 my @parts := isa($p1, 'String') ?? $p1.split('::') !! $p1;
112
113                 my $nsp := get_root_namespace();
114                 $result := $nsp.make_namespace(@parts);
115         }
116         else {
117                 die("Undefined namespace path");
118         }
119
120         return $result;
121 }