Catching up after the holidays.
[kakapo:kakapo.git] / src / Program.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 Program;
5 # Provides a conventional framework for program execution. 
6
7 =begin SYNOPSIS
8
9         # At outmost scope of your module:
10         Program::init(:after('Other::Module'));
11         
12         # Do what you can here:
13         our @Array := (1, 2, 3);
14         
15         sub _initload() {
16                 # Do init stuff that requires Other::Module here
17         }
18         
19         Program::register_main('MyModule::main');
20         
21         sub main() {
22                 Program::at_end('MyModule::finalize');
23
24                 if +@Array > 2 {
25                         say("Too many items.");
26                         Program::exit(1);
27                 }
28                 
29                 say("Hello, world!");
30         }
31         
32         sub finalize() {
33                 say("Hasta la vista, baby.");
34         }
35         
36 =end SYNOPSIS
37
38 # Don't initialize *anything,* here.            !IMPORTANT
39 our $At_end_queue;
40 our $At_start_queue;
41 our $Init_queue;
42 our $Load_queue;
43 our $Main;
44 our $Processing_init_queue;
45 our $Processing_load_queue;
46
47 _pre_initload();
48
49 sub add_call($queue, $call, %opts, $caller_nsp) {
50 # Adds a C< $call > with C< @prereqs > to C< $queue >, tagged with key C< $name >. When no call 
51 # is specified, calculates a reasonable default using any of the C< @sub_names > defined in the 
52 # C< $caller_nsp > namespace.
53
54 # For example, when the caller calls:
55
56         # Program::init(:after('Dumper'));
57         
58 # The value of C< $queue > is determined by it being a call to C< init >. The C< $call > will
59 # be undef, because no Sub or name was given. The C< $name > will be undef because no
60 # C< :name > was given. The C< @prereqs > will be ( 'Dumper' ), and C< $caller_nsp > will be 
61 # captured by C< init >. The C< @sub_names > will be C< ( '_init' ) >.
62
63         my $name := %opts<name> ?? %opts<name> !! Parrot::namespace_name($caller_nsp);
64         
65         if %opts<done> {
66                 $queue.mark_as_done($name);
67         }
68         else {
69                 my @prereqs := %opts<after>;
70                 
71                 if isa(@prereqs, 'String') {
72                         @prereqs := Array::new(@prereqs);
73                 }
74
75                 $call := determine_call($call, $caller_nsp, Array::new('_load', '_initload'));
76                 $queue.add_entry($name, $call, @prereqs);
77         }
78 }
79
80 sub determine_call($call, $caller_nsp, @sub_names) {
81 # Determines a sub to be called. If C< $call > is defined, it specifies the call -- either a sub
82 # of some kind, or a String name to be resolved, or some other invokable object. Otherwise,
83 # the C< $caller_nsp > is checked for any of the default C< @sub_names >. The first one
84 # found is used.
85
86         my $nsp_name := Parrot::namespace_name($caller_nsp);
87         
88         if defined($call) {
89                 if isa($call, 'String') {
90                         if +$call.split('::') == 1 {
91                                 $call := $nsp_name ~ '::' ~ $call;
92                         }
93                 }
94                 
95                 return $call;
96         }
97         
98         for @sub_names {
99                 if $call := $caller_nsp{~$_} {
100                         return $call;
101                 }
102         }
103         
104         die("Cannot find any viable call (", @sub_names.join(', '), ") in ", $nsp_name);
105 }
106
107 sub call($call) {
108 # Calls the Sub or MultiSub PMC passed as C<$call>, or, if C<$call> 
109 # is a String, looks up the named symbol and calls that.
110
111         if Opcode::isa($call, 'String') {
112                 $call := Opcode::get_hll_global($call);
113         }
114
115         my $status := 0;
116         
117         if $call {
118                 $status := $call();
119         }
120         
121         return $status;
122 }
123
124 sub call_main() {
125 # Executes the calls registered in the L<C< at_start >> queue, then
126 # runs the C<main> sub registered via L<C< register_main >>. If the
127 # C<main> sub returns, the result is passed to L<C< exit >>.
128
129         process_queue($At_start_queue);
130
131         call($Main);
132         exit(0);
133 }
134
135 sub exit($status) {
136 # Exits the program, makes any calls registered with L<C<at_end>>, and 
137 # causes the Parrot interpreter to exit with status C<$status>.
138
139         process_queue($At_end_queue);
140         _exit($status);
141 }
142
143 sub _exit($status) {
144 # Immediately exits the Parrot VM, returning C<$status>, without calling any of 
145 # the registered L<C< at_end >> calls.
146
147         Opcode::exit($status);
148 }
149
150 sub init($call?, *%opts) {
151 # Requests a call to the sub named by C< $call >, or to the sub object given in C< $call >, or
152 # to a default sub (named '_load' or '_initload') in the caller's namespace. The call will take
153 # place after all C< :load > subs in this library or program have been run. 
154
155 # The purpose of this routine is analogous to that of L<C< init >>, except for the (very 
156 # significant!) difference between C< :init > and C< :load > processing. The argument values
157 # and semantics are identical to those of C< init >.
158
159         add_call($Init_queue, $call, %opts, Parrot::caller_namespace(2));
160 }
161
162 sub initload($call?, *%opts) {
163 # A shortcut routine. Equivalent to calling L<C< init >> and L<C< load >> with the same arguments.
164
165         my $caller_nsp := Parrot::caller_namespace(2);
166         add_call($Init_queue, $call, %opts, $caller_nsp);
167         add_call($Load_queue, $call, %opts, $caller_nsp);
168 }
169
170 sub is_upgraded($queue) {
171         return $queue.isa('ManagedQueue');
172 }
173
174 sub load($call?, *%opts) {
175 # Requests a call to the sub named by C< $call >, or to the sub object given in C< $call >, or
176 # to a default sub (named '_load' or '_initload') in the caller's namespace. The call will take
177 # place after all C< :load > subs in this library or program have been run. 
178
179 # The purpose of this routine is analogous to that of L<C< init >>, except for the (very 
180 # significant!) difference between C< :init > and C< :load > processing. The argument values
181 # and semantics are identical to those of C< init >.
182
183         add_call($Load_queue, $call, %opts, Parrot::caller_namespace(2));
184 }
185
186 sub _pre_initload(*@modules_done) {
187         if our $_Pre_initload_done { return 0; }
188         $_Pre_initload_done := 1;
189         
190         Global::use('Dumper');
191         Global::use('Opcode', :tags('DEFAULT', 'TYPE'));
192         
193         $At_end_queue   := DependencyQueue.new();
194         $At_start_queue := DependencyQueue.new();
195         $Init_queue     := Parrot::call_method_(DependencyQueue, 'new', @modules_done);
196         $Load_queue     := Parrot::call_method_(DependencyQueue, 'new', @modules_done);
197
198         if ! Opcode::defined($Main) {
199                 $Main := 'main';
200         }
201 }
202
203 sub process_init_queue() {
204 # Removes each registered I< call > from the C< :init > queue, and invokes them in order.
205 # If the queue is not already ordered according to the parameters given when the calls
206 # were registered, the queue is first reordered.
207
208 # See L<C< init >> for how to add items to the queue.
209
210 # Returns nothing.
211
212         process_queue($Init_queue);
213 }
214
215 sub process_load_queue() {
216 # Process the C<:load> queue. See L<C< process_init_queue >>.
217
218         process_queue($Load_queue);
219 }
220
221 sub process_queue($q) {
222 # Called to process any of the queues in this module. Pulls all of the calls out of the queue, in order, and invokes them.
223
224         while ! $q.is_empty {
225                 my &call := $q.next;
226                 call(&call);
227         }
228         
229         $q.reset();
230 }
231
232 sub register_main($call) {
233 # Sets the C< main > function to call.
234 # FIXME: This should default to the namespace of the caller, and to 'main' in that nsp if not given.
235
236         if Opcode::defined($call) {
237         say("Registering main routine: ", $call);
238                 $Main := $call;
239         }
240 }
241
242 sub upgrade_queue($queue) {
243 # Upgrades a C< ResizablePMCArray >-based queue to a C< ManagedQueue >. 
244
245 # When Parrot loads bytecode, the ManagedQueue class has not been registered as a class, and so it is impossible to 
246 # make new ManagedQueue objects. Because there is no guarantee of the order that C< :init > and C< :load > methods
247 # are run, there is no way to ensure that ManagedQueue is registered before any other class tries to register a call.
248
249 # To deal with this uncertainty, the various registration functions (L<C< init >>, L<C< initload >>, and 
250 # L<C< load >>) will create a simple ResizablePMCArray if no ManagedQueue exists. In this case, the entire request 
251 # is bundled up and placed in the RPA.
252
253 # This function creates a new ManagedQueue, processes the RPA, unpacks the registration bundles and inserts the
254 # calls according to the request in the bundle.
255
256 # Returns the new ManagedQueue.
257
258         if ! Opcode::defined($queue) {
259                 $queue := ManagedQueue.new();
260         }
261         elsif $queue.isa('ResizablePMCArray') {
262                 my @rpa := $queue;
263                 $queue := ManagedQueue.new();
264                 
265                 while @rpa {
266                         my $item := @rpa.shift;
267                         my %opts := Opcode::isa($item, 'FixedPMCArray') ?? $item[1] !! $item.value;
268                         my $pair := %opts<pair>;
269                         $pair := make_pair($pair[0], $pair[1]);
270                         enqueue_pair($queue, $pair, %opts);
271                 }
272         }
273         
274         return $queue;
275 }