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 deckfile_manager:
31 dfm: proc ();
32
33
34
35
36 dcl ab_sw bit (1) aligned;
37 dcl argl fixed bin (21);
38 dcl argp ptr;
39 dcl arg_num fixed bin;
40 dcl code fixed bin (35);
41 dcl debug_sw bit (1) aligned;
42 dcl deckfile_length fixed bin (21);
43 dcl deckfile_ptr ptr;
44 dcl nargs fixed bin;
45 dcl profile_dir char (168);
46 dcl profile_entry char (32);
47 dcl profile_length fixed bin (21);
48 dcl profile_ptr ptr;
49 dcl profile_sw bit (1);
50 dcl prompt_length fixed bin (21);
51 dcl prompt_ptr ptr;
52 dcl prompt_sw bit (1);
53 dcl quit_sw bit (1);
54 dcl request_loop_sw bit (1);
55 dcl ready_sw bit (1) aligned;
56 dcl request_sw bit (1);
57 dcl request_line_length fixed bin (21);
58 dcl request_line_ptr ptr;
59 dcl sci_ptr ptr;
60 dcl startup_sw bit (1);
61
62
63
64 dcl arg char (argl) based (argp);
65 dcl deckfile_string char (deckfile_length) based (deckfile_ptr);
66 dcl free_area area based (get_system_free_area_ ());
67 dcl profile_string char (profile_length) based (profile_ptr);
68 dcl prompt_string char (prompt_length) aligned based (prompt_ptr);
69
70
71
72
73 dcl addr builtin;
74 dcl codeptr builtin;
75 dcl null builtin;
76
77
78
79
80 dcl cleanup condition;
81
82
83
84
85 dcl dfm_version_1 char (4) int static options (constant) init ("1.0a");
86 dcl false bit (1) int static options (constant) init ("0"b);
87 dcl last_position fixed bin int static options (constant) init (9999);
88 dcl max_prompt_length fixed bin int static options (constant) init (64);
89 dcl myname char (3) int static options (constant) init ("dfm");
90 dcl true bit (1) int static options (constant) init ("1"b);
91
92
93
94 dcl active_fnc_err_ entry options (variable);
95 dcl com_err_ entry () options (variable);
96 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
97 dcl cu_$arg_list_ptr entry () returns (ptr);
98 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
99 dcl cu_$generate_call entry (entry, ptr);
100 dcl dfm_$clean_up entry (ptr, ptr);
101 dcl dfm_$pi_handler entry;
102 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
103 dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
104 dcl get_system_free_area_ entry () returns (ptr);
105 dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
106 dcl ssu_$add_info_dir entry (ptr, char (*), fixed bin, fixed bin (35));
107 dcl ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35));
108 dcl ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35));
109 dcl ssu_$destroy_invocation entry (ptr);
110 dcl ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35));
111 dcl ssu_$execute_start_up entry () options (variable);
112 dcl ssu_$get_temp_segment entry (ptr, char (*), ptr);
113 dcl ssu_$listen entry (ptr, ptr, fixed bin (35));
114 dcl ssu_$record_usage entry (ptr, ptr, fixed bin (35));
115 dcl ssu_$release_temp_segment entry (ptr, ptr);
116 dcl ssu_$set_abbrev_info entry (ptr, ptr, ptr, bit (1) aligned);
117 dcl ssu_$set_debug_mode entry (ptr, bit (1) aligned);
118 dcl ssu_$set_ec_suffix entry (ptr, char (32));
119 dcl ssu_$set_procedure entry (ptr, char (*), entry, fixed bin (35));
120 dcl ssu_$set_prompt entry (ptr, char (64) var);
121 dcl ssu_$set_prompt_mode entry (ptr, bit (*));
122 dcl ssu_$set_ready_mode entry (ptr, bit (1) aligned);
123
124
125
126 dcl dfm_request_table_$dfm_request_table_ fixed bin ext static;
127 dcl error_table_$active_function fixed bin (35) ext static;
128 dcl error_table_$badopt fixed bin (35) ext static;
129 dcl error_table_$bigarg fixed bin (35) ext static;
130 dcl error_table_$inconsistent fixed bin (35) ext static;
131 dcl error_table_$not_act_fnc fixed bin (35) ext static;
132 dcl ssu_et_$subsystem_aborted fixed bin (35) ext static;
133 dcl ssu_et_$program_interrupt fixed bin (35) ext static;
134 dcl ssu_et_$null_request_line fixed bin (35) ext static;
135 dcl ssu_et_$request_line_aborted fixed bin (35) ext static;
136 dcl ssu_info_directories_$standard_requests char (168) external;
137 dcl ssu_request_tables_$standard_requests bit (36) aligned external;
138
139
140 %page;
141
142 call cu_$af_return_arg (nargs, null (), 0, code);
143 if code ^= error_table_$not_act_fnc then do;
144 if code = 0 then call active_fnc_err_ (error_table_$active_function, myname);
145 else call com_err_ (code, myname);
146 return;
147 end;
148
149 call dfm_init ();
150
151 on cleanup call deckfile_manager_cleanup ();
152
153 do arg_num = 1 to nargs;
154 call cu_$arg_ptr (arg_num, argp, argl, code);
155 if code ^= 0 then call complain (code, myname, "Getting arg ptr.");
156
157 if arg = "-abbrev" | arg = "-ab" then ab_sw = true;
158
159 else if arg = "-debug" | arg = "-db" then debug_sw = true;
160
161 else if arg = "-deckfile" | arg = "-dkf" then do;
162 call next_arg (deckfile_ptr, deckfile_length, code);
163 if code ^= 0 then call complain (code, myname, "Getting deckfile pathname.");
164 call expand_pathname_ (deckfile_string, dfm_info.deckfile_dir,
165 dfm_info.deckfile_entry, code);
166 if code ^= 0 then call complain (code, myname, "Expanding deckfile pathname.");
167 end;
168
169 else if arg = "-no_abbrev" | arg = "-nab" then ab_sw = false;
170
171 else if arg = "-no_debug" | arg = "-ndb" then debug_sw = false;
172
173 else if arg = "-no_prompt" then prompt_sw = false;
174
175 else if arg = "-no_startup" | arg = "-nsu" then startup_sw = false;
176
177 else if arg = "-profile" | arg = "-pf" then do;
178 call next_arg (profile_ptr, profile_length, code);
179 if code ^= 0 then call complain (code, myname, "Getting profile pathname.");
180 call expand_pathname_$add_suffix (profile_string, "profile", profile_dir, profile_entry, code);
181 if code ^= 0 then call complain (code, myname, "Expanding profile pathname.");
182 call initiate_file_ (profile_dir, profile_entry, R_ACCESS, profile_ptr, 0, code);
183 if profile_ptr = null () then call complain (code, myname,
184 "Initiating the profile ^a>^a.", profile_dir, profile_entry);
185
186 ab_sw, profile_sw = true;
187 end;
188
189 else if arg = "-prompt" then do;
190 call next_arg (prompt_ptr, prompt_length, code);
191 if code ^= 0 then call complain (code, myname, "Getting prompt string");
192 if prompt_length > max_prompt_length then
193 call complain (error_table_$bigarg, myname,
194 "The prompt may be a maximum of ^d characters", max_prompt_length);
195 prompt_sw = true;
196 end;
197
198 else if arg = "-quit" | arg = "-q" then
199 quit_sw, dfm_info.flags.force_quit = true;
200
201 else if arg = "-ready_off" | arg = "-rdf" then ready_sw = false;
202
203 else if arg = "-ready_on" | arg = "-rdn" then ready_sw = true;
204
205 else if arg = "-request" | arg = "-rq" then do;
206 if request_sw then call complain (error_table_$inconsistent,
207 myname, "Only one request per invocation");
208 call next_arg (request_line_ptr, request_line_length, code);
209 if code ^= 0 then call complain (code, myname, "Getting request line");
210 request_sw = true;
211 end;
212
213 else if arg = "-request_loop"
214 | arg = "-rql" then request_loop_sw = true;
215
216 else if arg = "-startup" | arg = "su" then startup_sw = true;
217
218 else call complain (error_table_$badopt, myname, "^a", arg);
219
220 end;
221
222 call ssu_$create_invocation (myname, dfm_version_1, dfm_infop,
223 addr (dfm_request_table_$dfm_request_table_), ">doc>subsystem>dfm", sci_ptr, code);
224 if code ^= 0 then call complain (code, myname, "Creating subsystem invocation.");
225
226 call ssu_$record_usage (sci_ptr, codeptr (dfm), 0);
227
228 call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests, last_position, code);
229 if code ^= 0 then call complain (code, myname, "Adding ssu info dir.");
230
231 call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests), last_position, code);
232 if code ^= 0 then call complain (code, myname, "Adding ssu request table.");
233
234 call ssu_$set_procedure (sci_ptr, "program_interrupt", dfm_$pi_handler, code);
235 if code ^= 0 then call complain (code, myname, "Adding pi handler.");
236
237 call ssu_$set_ec_suffix (sci_ptr, "dfmec");
238
239 call ssu_$get_temp_segment (sci_ptr, "dfm_data", dfm_info.dfm_data_ptr);
240
241 call ssu_$set_abbrev_info (sci_ptr, profile_ptr, profile_ptr, ab_sw);
242
243 call ssu_$set_debug_mode (sci_ptr, debug_sw);
244
245 if prompt_sw & prompt_length > 0 then
246 call ssu_$set_prompt (sci_ptr, (prompt_string));
247
248 call ssu_$set_prompt_mode (sci_ptr, ^prompt_sw);
249
250 call ssu_$set_ready_mode (sci_ptr, ready_sw);
251
252 if startup_sw then do;
253 call ssu_$execute_start_up (sci_ptr, code);
254 if code ^= 0 then call complain (code, myname, "Executing ssu startup.");
255 end;
256
257 if request_sw then do;
258 call ssu_$execute_line (sci_ptr, request_line_ptr, request_line_length, code);
259 if code ^= 0 then do;
260 if (code = ssu_et_$null_request_line
261 | code = ssu_et_$program_interrupt
262 | code = ssu_et_$request_line_aborted)
263 & request_loop_sw then goto listen;
264 else if code = ssu_et_$subsystem_aborted then goto subsystem_wrapup;
265 else call complain (code, myname, "Encountered while executing request line");
266 end;
267 end;
268
269 if quit_sw then goto subsystem_wrapup;
270
271
272 listen:
273 call ssu_$listen (sci_ptr, null (), code);
274 if code ^= ssu_et_$subsystem_aborted then
275 call com_err_ (code, myname, "Calling the listener.");
276
277 subsystem_wrapup:
278 call deckfile_manager_cleanup ();
279 return;
280 %page;
281
282
283
284
285 complain: proc () options (variable);
286
287 call cu_$generate_call (com_err_, cu_$arg_list_ptr ());
288 goto subsystem_wrapup;
289
290
291 end complain;
292
293
294
295 %page;
296
297
298
299
300 deckfile_manager_cleanup: proc ();
301
302 if dfm_infop ^= null then do;
303
304 if dfm_info.flags.request_active then call dfm_$clean_up (sci_ptr, dfm_infop);
305
306 if dfm_info.dfm_data_ptr ^= null () then
307 call ssu_$release_temp_segment (sci_ptr, dfm_info.dfm_data_ptr);
308
309 if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr);
310
311 free dfm_info in (free_area);
312 dfm_infop = null;
313 end;
314
315
316 end deckfile_manager_cleanup;
317 %page;
318
319
320
321 dfm_init: proc ();
322
323 dfm_infop = null;
324 allocate dfm_info in (free_area) set (dfm_infop);
325
326 ab_sw = false;
327 debug_sw = false;
328 dfm_info.deckfile_dir = "";
329 dfm_info.deckfile_entry = "";
330 dfm_info.dfm_data_ptr = null;
331 dfm_info.page_number = 0;
332 dfm_info.flags.request_active = false;
333 dfm_info.force_quit = false;
334 dfm_info.pad = "0"b;
335 dfm_info.version = dfm_info_version_1;
336 profile_ptr = null;
337 profile_sw = false;
338 prompt_length = 0;
339 prompt_ptr = null;
340 prompt_sw = true;
341 quit_sw = false;
342 request_loop_sw = false;
343 ready_sw = false;
344 request_sw = false;
345 request_line_length = 0;
346 request_line_ptr = null;
347 sci_ptr = null;
348 startup_sw = false;
349
350 end dfm_init;
351
352 %page;
353
354
355
356 next_arg: proc (nargp, nargl, nacode);
357
358 dcl nargp ptr;
359 dcl nacode fixed bin (35);
360 dcl nargl fixed bin (21);
361
362 arg_num = arg_num + 1;
363 call cu_$arg_ptr (arg_num, nargp, nargl, nacode);
364
365
366 end next_arg;
367
368 %page;
369 %include access_mode_values;
370 %page;
371 %include dfm_info;
372 %page;
373 %include ssu_prompt_modes;
374
375 end deckfile_manager;