1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30 apl:
31 v2apl:
32 procedure ();
33
34
35
36 call cu_$af_arg_count ((0), code);
37 if code ^= error_table_$not_act_fnc
38 then do;
39 call active_fnc_err_ (0, "apl", "Cannot be called as an active function.");
40 return;
41 end;
42
43 autoload_ws = "continue";
44 autoload_lock = "";
45 devicename = "";
46 temporary_segments_dir = get_pdir_ ();
47
48 string (command_options.flags) = ""b;
49 command_options.user_number = 100;
50
51 do argno = 1 to cu_$arg_count ();
52
53 call cu_$arg_ptr (argno, argp, argl, code);
54 if code ^= 0
55 then go to nomoreargsIguess;
56
57 if arg = "-db" | arg = "-debug"
58 then flags.debug_mode = "1"b;
59
60 else if arg = "-nqh" | arg = "-no_quit_handler"
61 then flags.no_quit_handler = "1"b;
62
63 else if arg = "-bfe" | arg = "-brief_errors" | arg = "-bf" | arg = "-brief"
64
65 then flags.long_error_mode = "0"b;
66
67 else if arg = "-lge" | arg = "-long_errors" | arg = "-lg" | arg = "-long"
68
69 then flags.long_error_mode = "1"b;
70
71 else if arg = "-ck" | arg = "-check"
72 then flags.compatibility_check_mode = "1"b;
73
74 else if arg = "-meter"
75 then flags.meter_mode = "1"b;
76
77 else if arg = "-ttp" | arg = "-terminal_type"
78 then do;
79 argno = argno + 1;
80 call cu_$arg_ptr (argno, argp, argl, code);
81 if code ^= 0
82 then do;
83 call com_err_ (code, "apl", "-terminal_type must be followed by terminal name.
84 Possible names are: 1050, 2741, CORR2741, 1030, TEK4013, TEK4015, TN300,
85 ARDS, ASCII, TTY33, TTY38, TYPEPAIRED, BITPAIRED, TELERAY11, LA36.");
86 return;
87 end;
88
89 devicename = arg;
90 end;
91
92 else if arg = "-user_number"
93 then do;
94 argno = argno + 1;
95 call cu_$arg_ptr (argno, argp, argl, code);
96 if code ^= 0
97 then do;
98 call com_err_ (code, "apl", "-user_number must be followed by a decimal integer.");
99 return;
100 end;
101
102 command_options.user_number = cv_dec_check_ (arg, code);
103 if code ^= 0 | command_options.user_number <= 0
104 then do;
105 call com_err_ (0, "apl", "Invalid user number. ^a", arg);
106 return;
107 end;
108 end;
109
110 else if arg = "-temp_dir" | arg = "-td"
111 then do;
112 argno = argno + 1;
113 call cu_$arg_ptr (argno, argp, argl, code);
114 if code ^= 0
115 then do;
116 call com_err_ (code, "apl", "-temp_dir must be followed by directory pathname.");
117 return;
118 end;
119
120 call absolute_pathname_ (arg, temporary_segments_dir, code);
121 if code ^= 0
122 then do;
123 call com_err_ (code, "apl", "^a", arg);
124 return;
125 end;
126 end;
127
128 else if substr (arg, 1, 1) = "-"
129 then do;
130 call com_err_ (error_table_$badopt, "apl", "^a", arg);
131 return;
132 end;
133
134 else do;
135 autoload_ws = before (arg, ":");
136 autoload_lock = after (arg, ":");
137 end;
138 end;
139
140 nomoreargsIguess:
141 save_ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr;
142
143
144 on cleanup
145 call clean_up;
146
147 apl_static_$immediate_input_prompt = byte (13) || (6)" ";
148
149 call initialize_apl (temporary_segments_dir, devicename, code);
150
151 if code ^= 0
152 then do;
153 call com_err_ (code, "apl", "Unable to initialize apl.");
154 apl_static_$ws_info_ptr.static_ws_info_ptr = save_ws_info_ptr;
155
156 return;
157 end;
158
159 ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr;
160
161 string (ws_info.switches) = string (command_options.flags);
162 ws_info.user_number = command_options.user_number;
163
164 call ioa_$ioa_switch (apl_static_$apl_output, "apl ^a^/", apl_static_$version_number);
165
166 call apl_load_command_$autoload (autoload_ws, autoload_lock, code);
167 if code ^= 0 & code ^= apl_error_table_$cant_autoload
168 then do;
169 call com_err_ (code, "apl", "^a", autoload_ws);
170 call clean_up;
171 return;
172 end;
173
174 call apl_parse_;
175
176 if ws_info.signoff_lock ^= ""
177 then call ioa_$ioa_switch (apl_static_$apl_output, "apl: signoff lock ignored.");
178
179 call clean_up;
180 return;
181 ^L
182 clean_up:
183 procedure ();
184
185 call apl_file_system_$untie_all_files;
186
187 if detach_streams
188 then do;
189 call apl_detach_streams_ (code);
190
191 if code ^= 0
192 then call com_err_ (code, "apl", "While detaching apl I/O streams.");
193 end;
194
195 if apl_static_$ws_info_ptr.static_ws_info_ptr ^= null
196 then call apl_dispose_of_storage_ ();
197
198 apl_static_$ws_info_ptr.static_ws_info_ptr = save_ws_info_ptr;
199
200 end;
201 ^L
202 initialize_apl:
203 procedure (a_temp_dir, a_devicename, a_code);
204
205 declare (
206 a_devicename char (*),
207 a_temp_dir char (*),
208 a_code fixed bin (35)
209 ) parameter;
210
211
212 call apl_segment_manager_$set_temp_dir (a_temp_dir);
213 call apl_attach_streams_ (a_devicename, a_code);
214 if a_code = error_table_$ionmat
215 then do;
216 detach_streams = "0"b;
217 a_code = 0;
218 end;
219 else detach_streams = "1"b;
220
221 if a_code ^= 0
222 then return;
223
224 call apl_create_workspace_ ();
225
226 end initialize_apl;
227 ^L
228
229
230 apl_subsystem_:
231 entry (a_user_number, a_switches, a_initial_ws, a_initial_ws_lock, a_terminal_type, a_temporary_segments_dir,
232 a_signoff_lock, a_result);
233
234 dcl a_user_number fixed bin (35) parameter,
235 a_switches bit (*) aligned parameter,
236 a_initial_ws char (*) parameter,
237 a_initial_ws_lock char (*) parameter,
238 a_terminal_type char (*) parameter,
239 a_temporary_segments_dir
240 char (*) parameter,
241 a_signoff_lock char (*) parameter,
242 a_result fixed bin parameter;
243
244
245
246
247
248 Note
249
250
251 save_ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr;
252
253 on cleanup
254 call clean_up;
255
256 if a_temporary_segments_dir = ""
257 then temporary_segments_dir = get_pdir_ ();
258 else temporary_segments_dir = a_temporary_segments_dir;
259
260 apl_static_$immediate_input_prompt = (6)" ";
261
262 call initialize_apl (temporary_segments_dir, a_terminal_type, code);
263 if code ^= 0
264 then do;
265 a_result = code;
266 return;
267 end;
268
269 ws_info_ptr = apl_static_$ws_info_ptr.static_ws_info_ptr;
270
271 ws_info.user_number = a_user_number;
272 string (ws_info.switches) = a_switches;
273 ws_info.switches.transparent_to_signals = "0"b;
274
275 if a_initial_ws = ""
276 then autoload_ws = "continue";
277 else autoload_ws = a_initial_ws;
278
279 call apl_load_command_$autoload (autoload_ws, a_initial_ws_lock, code);
280
281
282
283
284 if code ^= 0
285 then if ^(code = apl_error_table_$cant_autoload & a_initial_ws = "")
286 then do;
287 a_result = code;
288 call clean_up;
289 return;
290 end;
291
292 call ioa_$ioa_switch (apl_static_$apl_output, "apl ^a^/", apl_static_$version_number);
293
294 call apl_parse_ ();
295
296 a_signoff_lock = ws_info.signoff_lock;
297
298 if ws_info.off_hold
299 then a_result = apl_error_table_$off_hold;
300 else a_result = 0;
301
302 call clean_up;
303 return;
304 ^L
305
306
307 declare absolute_pathname_ entry (char (*), char (*), fixed bin (35)),
308 apl_create_workspace_
309 entry (),
310 apl_load_command_$autoload
311 entry (char (*), char (*), fixed bin (35)),
312 apl_segment_manager_$set_temp_dir
313 entry (char (*)),
314 get_pdir_ entry () returns (char (168) aligned),
315 cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin),
316 cu_$af_arg_count entry (fixed bin, fixed bin(35)),
317 cu_$arg_count entry () returns (fixed bin),
318 cu_$arg_ptr entry (fixed bin, ptr, fixed bin (24), fixed bin (35)),
319 active_fnc_err_ entry() options(variable),
320 com_err_ entry options (variable),
321 ioa_$ioa_switch entry options (variable),
322 apl_file_system_$untie_all_files
323 entry,
324 (apl_parse_, apl_dispose_of_storage_)
325 entry (),
326 apl_attach_streams_ entry (char (*), fixed bin (35)),
327 apl_detach_streams_ entry (fixed bin (35));
328
329
330
331
332 declare cleanup condition;
333
334
335
336 declare (after, before, null, string, substr)
337 builtin;
338
339
340
341 declare argno fixed bin,
342 argp ptr,
343 argl fixed bin (24),
344 autoload_lock char (32),
345 autoload_ws char (168),
346 code fixed bin (35),
347 detach_streams bit (1) aligned initial ("1"b),
348 devicename char (16),
349 save_ws_info_ptr ptr unaligned,
350 temporary_segments_dir
351 char (168),
352 1 command_options aligned,
353 2 flags unaligned like ws_info.switches,
354 2 user_number fixed bin (35);
355
356
357
358 declare arg char (argl) unaligned based (argp);
359
360
361
362 declare (
363 apl_error_table_$cant_autoload
364 fixed bin (35),
365 apl_error_table_$off_hold
366 fixed bin (35),
367 apl_static_$immediate_input_prompt
368 char (32) varying,
369 error_table_$not_act_fnc fixed bin (35),
370 error_table_$badopt fixed bin (35),
371 error_table_$ionmat fixed bin (35),
372 apl_static_$version_number
373 char (5),
374 apl_static_$apl_output
375 pointer
376 ) external static;
377
378
379
380 %include apl_number_data;
381 %include apl_ws_info;
382
383 end;