some more progress. All the initialization routines run and I can get some of the...
[kakapo:kakapo.git] / src / Pmc / common-methods.nqp
1 # Copyright 2009-2010, Austin Hastings. See accompanying LICENSE file, or
2 # http://www.opensource.org/licenses/artistic-license-2.0.php for license.
3
4 class Kakapo::Pmc::COMMON;
5
6 =begin
7
8 =item new() returns PMC
9
10 Returns a new instance of the PMC type of the invocant.
11
12 =code   my @array := ResizablePMCArray.new();
13
14 Note that this method is compiled at run-time for each class. See L< install_symbols >.
15
16 =end
17 =cut
18
19 INIT {
20         # Make these available for import by other modules.
21         #export(< can clone defined does isa >);
22
23         # List all the PMC types here, with the methods to export. I'll sort them out later.
24         my %methods_for;
25         %methods_for<Class>                     := Array::new( <defined> );
26         %methods_for<Exception>                 := <can clone defined does isa is_equal new>;
27 #       %methods_for<FileHandle>                := <can clone defined isa is_equal new>; # not does
28         %methods_for<Float>                     := <can clone defined does isa is_equal>;
29         %methods_for<Hash>                      := <can clone defined does isa is_equal>;
30         %methods_for<Integer>                   := <can clone defined does isa is_equal>;
31         %methods_for<Key>                       := <can clone defined does isa is_equal>;
32         %methods_for<NameSpace>         := <can clone defined does isa is_equal>;
33         %methods_for<ResizablePMCArray> := <can clone defined does isa is_equal new>;
34         %methods_for<ResizableStringArray>      := <can clone defined does isa is_equal new>;
35         %methods_for<String>                    := <can does is_equal>; #! not new isa clone defined
36 #       %methods_for<StringHandle>              := <can clone defined does isa is_equalnew>;
37         %methods_for<Sub>                       := <can clone defined does isa is_equal>; #! not new
38         %methods_for<Undef>                     := <can does is_equal new>; #! not defined clone isa
39
40         # Order counts
41         my @first_pmcs := <
42                 Undef
43                 String
44                 Hash
45                 ResizablePMCArray
46                 ResizableStringArray
47         >;
48
49         # Get the critical PMCs set up first (need .defined, etc., for building 'new' methods)
50         for @first_pmcs {
51                 P6metaclass.register(~ $_);
52                 my $name := $_;
53                 my $namespace;
54                 Q:PIR {
55                     $P0 = find_lex '$name'
56                     $S0 = $P0
57                     $P1 = get_root_namespace ['parrot'; $S0]
58                     store_lex '$namespace', $P1
59                 };
60                 my $class := pir::get_class__PP($namespace);
61                 install_methods($class, %methods_for{$_}, :skip_new);
62         }
63
64         # Now build 'new' methods.
65         for @first_pmcs {
66             my $name := $_;
67             my $namespace;
68             Q:PIR {
69                 $P0 = find_lex '$name'
70                 $S0 = $P0
71                 $P1 = get_root_namespace ['parrot'; $S0]
72                 store_lex '$namespace', $P1
73             };
74             my $class := pir::get_class__PP($namespace);
75             install_methods($class, %methods_for{$_}); # no :skip_new here
76             %methods_for{$_} := my $undef;
77         }
78
79     # Now process the rest of the PMCs
80     for %methods_for.kv -> $pmc_type, @methods {
81         if @methods {
82             my $ns;
83             Q:PIR {
84                 $P0 = find_lex '$pmc_type'
85                 $S0 = $P0
86                 $P1 = get_root_namespace ['parrot'; $S0]
87                 store_lex '$ns', $P1
88             };
89             if pir::typeof__SP($ns) eq 'NameSpace' {
90                 P6metaclass.register($pmc_type);
91             }
92             install_methods(pir::get_class__PP($ns), @methods);
93         }
94     }
95 }
96
97 #=begin
98 #=item can( $method_name ) returns Boolean
99
100 #Returns C< true > if the invocant object supports calling the C< $method_name > method.
101 #C< $method_name > must be a String. Returns C< false > otherwise.
102
103 #=begin code
104 #       if $object.can( 'resize' ) { ... }
105 #=end code
106 #=end
107
108 method can($method) {
109         pir::can(self, $method);
110 }
111
112 #=begin
113 #=item clone() returns PMC
114
115 #Returns a clone of the invocant object. The C< clone > method is frequently overridden,
116 #but in general should return an object which is a duplicate in all respects -- same
117 #contents, same members, same size, same value, whatever.
118
119 #See the documentation of the particular PMC type to determine I< whether >, and if so
120 #I< how > complex data structures are cloned. In general, Parrot's basic PMC types do
121 #B< deep > clones, which can cause problems if your data structure contains cycles.
122
123 #=begin code
124 #       $obj2 := $object.clone;
125 #=end code
126 #=end
127
128 method clone() {
129         pir::clone(self);
130 }
131
132 sub create_new_method($class) {
133     my $type := ~ $class;
134     my &new := Pir::compile_sub(
135         :name('new'),
136         :namespace($class.get_namespace()),
137         :method(1),
138         :body( (
139             "\t" ~ '$P0 = ' ~ "new [ '$type' ]",
140             "\t" ~ '.return ($P0)',
141         ) ),
142     );
143 }
144
145 #=begin
146 #=item defined() returns Boolean
147
148 #Returns C< true >, always. Every common PMC type is considered to be defined, except
149 #members of the C< Undef > type. That type does not import this method.
150
151 #=begin code
152 #       if $object.defined { ... }
153 #=end code
154 #=end
155
156 method defined() {
157         1;
158 }
159
160 #=begin
161 #=item does( $role ) returns Boolean
162
163 #Returns C< true > if the invocant implements the C< $role > named by the parameter.
164 #Returns C< false > otherwise.
165
166 #=begin code
167 #       if $object.does( 'array' ) { ... }
168 #=end code
169 #=end
170
171 method does($role) { pir::does(self, $role); }
172
173 sub install_methods($class, @methods, :$skip_new?) {
174     my $from_nsp := pir::get_namespace__P();
175     my $from_class := pir::get_class__PP($from_nsp);
176     my %to_methods := pir::inspect__PPS($class, 'methods');
177     my %from_methods := pir::inspect__PPS($from_class, 'methods');
178
179     for @methods {
180         if %from_methods{~ $_} {
181             my $test := $class.find_method(~$_);
182             if Parrot::is_null($test) {
183                 $class.add_method(~$_, %from_methods{~ $_});
184                 $test := $class.find_method(~$_);
185             }
186         }
187         elsif $_ eq 'new' {
188             unless $skip_new {
189                 my $test := $class.find_method("new");
190                 unless $test {
191                     create_new_method($class);
192                 }
193             }
194         }
195         else {
196             pir::die("Request to export unknown COMMON method '$_'");
197         }
198     }
199 }
200
201 method isa($type) {
202         pir::isa(self, $type);
203 }
204
205 method is_equal($other) {
206         pir::iseq__IPP(self, $other);
207 }