1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22 analyze_multics: azm: procedure () options (variable);
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40 dcl abbrev_sw bit (1);
41 dcl al fixed bin (21);
42 dcl amu_ptr ptr;
43 dcl ap pointer;
44 dcl arg char (al) based (ap);
45 dcl argno fixed bin;
46 dcl 1 azm_info_automatic aligned like azm_info automatic;
47 dcl code fixed bin (35);
48 dcl cond_uid bit(36) aligned;
49 dcl debug_sw bit (1) aligned;
50 dcl dirname char(168);
51 dcl ename char(32);
52 dcl info_dir char (168);
53 dcl my_uid bit(36) aligned;
54 dcl nargs fixed bin;
55 dcl profile_len fixed bin(21);
56 dcl profile_ptr ptr;
57 dcl profile_str char(profile_len) based(profile_ptr);
58 dcl prompt_len fixed bin(21);
59 dcl prompt_ptr ptr;
60 dcl prompt_string char(prompt_len) based (prompt_ptr);
61 dcl quit_sw bit (1);
62 dcl request_line char(request_line_len) based (request_line_ptr);
63 dcl request_line_len fixed bin(21);
64 dcl request_line_ptr ptr;
65 dcl rq_sw bit (1) aligned;
66 dcl startup_sw bit(1);
67 dcl temp_ptr ptr;
68 dcl where_ami_dir char (168);
69 dcl where_ami_ptr ptr;
70 dcl why_sw bit (1);
71 dcl sci_ptr pointer;
72
73
74 dcl ssu_request_tables_$standard_requests
75 bit(36) aligned external;
76 dcl ssu_info_directories_$standard_requests char (168) external;
77
78
79
80 dcl azm_request_table_$azm_request_table_ fixed bin external static;
81 dcl (
82 error_table_$bad_arg,
83 error_table_$badopt,
84 error_table_$noarg,
85 ssu_et_$null_request_line,
86 ssu_et_$program_interrupt,
87 ssu_et_$request_line_aborted,
88 ssu_et_$subsystem_aborted
89 ) fixed bin (35) external static;
90
91 dcl amu_$terminate_translation entry (ptr),
92 com_err_ entry options (variable),
93 continue_to_signal_ entry (fixed bin (35)),
94 cu_$arg_count entry (fixed bin, fixed bin (35)),
95 cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)),
96 expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)),
97 find_condition_frame_ entry (ptr) returns(ptr),
98 hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
99 hcs_$get_uid_seg entry (ptr, bit(36) aligned, fixed bin(35)),
100 hcs_$make_ptr entry (ptr, char(*), char(*), ptr, fixed bin(35)),
101 initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)),
102 ioa_ entry () options (variable),
103 ioa_$nnl entry() options(variable),
104 ssu_$add_info_dir entry (ptr, char(*), fixed bin, fixed bin(35)),
105 ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin(35)),
106 ssu_$create_invocation entry (char (*), char (*), pointer, pointer, char (*), pointer, fixed bin (35)),
107 ssu_$destroy_invocation entry (pointer),
108 ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)),
109 ssu_$execute_start_up entry () options (variable),
110 ssu_$get_area entry (ptr, ptr, char(*), ptr),
111 ssu_$get_default_rp_options entry (ptr, char(8), ptr, fixed bin(35)),
112 ssu_$listen entry (pointer, pointer, fixed bin (35)),
113 ssu_$set_debug_mode entry (ptr, bit(1) aligned),
114 ssu_$set_ec_suffix entry (ptr, char(32)),
115 ssu_$set_info_ptr entry (pointer, pointer),
116 ssu_$set_prompt entry (pointer, char (*) varying),
117 ssu_$set_prompt_mode entry (ptr, bit(*)),
118 ssu_$set_request_processor_options
119 entry (ptr, ptr, fixed bin(35));
120
121
122
123 dcl (False bit(1) init("0"b),
124 True bit(1) init("1"b)) int static options(constant);
125 dcl WHOAMI char (32) internal static options (constant) init ("analyze_multics");
126 dcl CURRENT_VERSION char(4) init ("2.4 ") int static options(constant);
127
128
129
130 dcl (cleanup, record_quota_overflow) condition;
131
132
133
134
135 dcl (addr, after, char, codeptr,
136 index, null, substr, unspec) builtin;
137 %page;
138
139 where_ami_ptr, amu_ptr, sci_ptr, azm_info_ptr, amu_info_ptr, profile_ptr, request_line_ptr, prompt_ptr = null ();
140 abbrev_sw, debug_sw, startup_sw, why_sw, quit_sw = "0"b;
141 prompt_len = -1;
142 profile_len, request_line_len = 0;
143
144
145 where_ami_ptr = codeptr (analyze_multics);
146 call hcs_$get_uid_seg(where_ami_ptr, my_uid, code);
147
148 on condition (cleanup)
149 begin;
150 call clean_up();
151 end;
152
153 on condition (record_quota_overflow)
154 begin;
155
156 sp = find_condition_frame_ (null());
157 code = 0;
158
159 call hcs_$get_uid_seg(sp->stack_frame.entry_ptr, cond_uid, code);
160 if code ^= 0 then do;
161 call continue_to_signal_(code);
162 return;
163 end;
164
165 if cond_uid ^= my_uid then do;
166
167
168 call hcs_$make_ptr (null(), "amu_", "", amu_ptr, code);
169 if amu_ptr = null() then do;
170 call continue_to_signal_(code);
171 return;
172 end;
173 call hcs_$get_uid_seg(amu_ptr, my_uid, code);
174 if code ^= 0 then do;
175 call continue_to_signal_(code);
176 return;
177 end;
178 if cond_uid ^= my_uid then do;
179 call continue_to_signal_(code);
180 return;
181 end;
182 end;
183
184
185
186 call ioa_$nnl ("Record_quota_overflow:^2x");
187 if azm_info_ptr = null () then do;
188
189 call ioa_ ();
190 call continue_to_signal_ (code);
191 end;
192 amu_info_ptr = azm_info_automatic.aip;
193 temp_ptr = null;
194 if amu_info_ptr ^= null () then do;
195
196 if amu_info.chain.prev = null () then do;
197
198 if amu_info.chain.next ^= null () then do;
199
200 temp_ptr = amu_info_ptr;
201 amu_info_ptr = amu_info.chain.next;
202 end;
203 else do;
204
205 call continue_to_signal_ (code);
206 end;
207 end;
208 else do;
209
210 temp_ptr = amu_info_ptr;
211 do while (temp_ptr -> amu_info.chain.prev ^= null ());
212 temp_ptr = temp_ptr -> amu_info.chain.prev;
213 end;
214 amu_info_ptr = temp_ptr;
215 temp_ptr = null;
216 end;
217 if amu_info.type = FDUMP_PROCESS_TYPE then
218 call ioa_ ("Will try deleting ERF ^a and continue...",fdump_info.erf_name);
219 else call ioa_ ("Deleting SAVE_PROC");
220 call amu_$terminate_translation (amu_info_ptr);
221
222 if amu_info_ptr = null () then call continue_to_signal_ (code);
223 end;
224 end;
225
226
227 call cu_$arg_count (nargs, code);
228 if code ^= 0 then do;
229 call com_err_ (code, WHOAMI);
230 return;
231 end;
232
233 ARGUMENT_LOOP:
234 do argno = 1 to nargs;
235 call cu_$arg_ptr (argno, ap, al, (0));
236 if arg = "-request" | arg = "-rq" then do;
237 call get_next_arg("request line", request_line_ptr, request_line_len);
238 rq_sw = True;
239 end;
240
241 else if arg = "-profile" | arg = "-pf" then do;
242 call get_next_arg ("profile path", profile_ptr, profile_len);
243 call expand_pathname_$add_suffix(profile_str,"profile",dirname,ename,code);
244 if code ^= 0 then call report_error(code, "^a",profile_str,"");
245 call initiate_file_ (dirname, ename, R_ACCESS, profile_ptr, (0), code);
246 if profile_ptr = null() then do;
247 call com_err_(code, WHOAMI, " -profile ^a^[>^]^a ", dirname, ename^=">", ename);
248 goto AZM_RETURN;
249 end;
250 abbrev_sw = True;
251 end;
252
253 else if arg = "-ab" | arg = "-abbrev" then do;
254 abbrev_sw = True;
255 end;
256
257 else if arg = "-nab" | arg = "-no_abbrev" then do;
258 abbrev_sw = False;
259 end;
260
261 else if arg = "-start_up" | arg = "-su" then do;
262 startup_sw = True;
263 end;
264
265 else if arg = "-nsu" | arg = "-no_start_up" then do;
266 startup_sw = False;;
267 end;
268
269 else if arg = "-prompt" then do;
270 call get_next_arg ("prompt string", prompt_ptr, prompt_len);
271 end;
272
273 else if arg = "-no_prompt" then do;
274 prompt_len = 0;
275 end;
276
277 else if arg = "-db" | arg = "-debug" then debug_sw = "1"b;
278 else if arg = "-ndb" | arg = "-no_debug" then debug_sw = "0"b;
279 else if (arg = "-quit") then quit_sw = "1"b;
280
281 else do;
282 if char(arg,1) = "-" then code = error_table_$badopt;
283 else code = error_table_$bad_arg;
284 call com_err_ (code, WHOAMI, "^a", arg);
285 goto AZM_RETURN;
286 end;
287 end ARGUMENT_LOOP;
288
289
290 call ssu_$create_invocation ("azm", CURRENT_VERSION, (null ()), addr (azm_request_table_$azm_request_table_),
291 ">documentation>subsystem>analyze_multics", sci_ptr, code);
292
293 if code ^= 0 then call report_error(code,"^/While creating analyze_multics invocation.","", "");
294
295 call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests,
296 9999, code);
297 if code ^= 0 then call report_error(code,"^/While adding standard ssu_ info directory.","", "");
298
299 call hcs_$fs_get_path_name (where_ami_ptr, where_ami_dir, 0, "", code);
300 if index( after( substr( where_ami_dir, 2 ), ">" ), ">" ) > 0 then do;
301
302
303 call ssu_$add_info_dir (sci_ptr, where_ami_dir, 0, code);
304 if code ^= 0 then
305 call report_error(code,"^/While adding -referencing_dir info directory: ^a", where_ami_dir, "");
306 end;
307
308 call ssu_$add_request_table(sci_ptr, addr(ssu_request_tables_$standard_requests), 100000, code);
309 if code ^= 0 then call report_error(code,"^/While adding standard ssu_ request table.","", "");
310
311 if (prompt_len = 0) then call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT);
312
313 else if prompt_len >0 then do;
314 call ssu_$set_prompt(sci_ptr, (prompt_string));
315 end;
316 else do;
317 call ssu_$set_prompt (sci_ptr, "^/azm^[ (^d)^]:^2x");
318 call ssu_$set_prompt_mode (sci_ptr, PROMPT | PROMPT_AFTER_NULL_LINES | DONT_PROMPT_IF_TYPEAHEAD);
319 end;
320
321 call ssu_$set_ec_suffix (sci_ptr, "azmec");
322
323 if abbrev_sw then do;
324 call ssu_$get_default_rp_options(sci_ptr, RP_OPTIONS_VERSION_1, addr(local_rpo), (0));
325 local_rpo.abbrev_info.expand_request_lines = True;
326 local_rpo.abbrev_info.default_profile_ptr = profile_ptr;
327 local_rpo.abbrev_info.profile_ptr = profile_ptr;
328 call ssu_$set_request_processor_options(sci_ptr, addr(local_rpo), (0));
329 end;
330
331 azm_info_ptr = addr (azm_info_automatic);
332
333 unspec (azm_info) = ""b;
334 azm_info.version = AZM_INFO_VERSION_2;
335 azm_info.aip = amu_info_ptr;
336 call ssu_$get_area (sci_ptr, null (), "azm_area", azm_info.area_ptr);
337 if amu_info_ptr ^= null () then do;
338 if amu_info.type = FDUMP_TYPE | amu_info.type = FDUMP_PROCESS_TYPE then azm_info.flags.in_erf = "1"b;
339 end;
340
341 call ssu_$set_info_ptr (sci_ptr, azm_info_ptr);
342 debug
343 if debug_sw then call ssu_$set_debug_mode(sci_ptr, debug_sw);
344
345 if startup_sw then do;
346 call ssu_$execute_start_up (sci_ptr, code);
347 if code ^= 0 then call report_error(code,"^/While executing start_up.","", "");
348 end;
349
350 if rq_sw then do;
351 call ssu_$execute_line (sci_ptr, request_line_ptr, request_line_len, code);
352 if code ^= 0 then do;
353 if code = ssu_et_$request_line_aborted | code = ssu_et_$program_interrupt | code = ssu_et_$null_request_line
354 then goto INVOKE_LISTEN;
355 if code = ssu_et_$subsystem_aborted then goto AZM_RETURN;
356 call report_error(code,"^/While executing the request ^a.", (request_line), "");
357 end;
358 end;
359
360 if quit_sw then goto AZM_RETURN;
361
362 INVOKE_LISTEN:
363
364 call ssu_$listen(sci_ptr, null(),code);
365 if code ^= ssu_et_$subsystem_aborted then call com_err_ (code,WHOAMI,"^/Calling subsystem listener.");
366
367 AZM_RETURN:
368 call clean_up ();
369
370 return;
371
372 %page;
373
374
375 clean_up:
376 proc ();
377
378 if azm_info_ptr ^= null() then do;
379 amu_info_ptr = azm_info.aip;
380 do while (amu_info_ptr ^= null);
381
382 call amu_$terminate_translation (amu_info_ptr);
383 end;
384 end;
385
386 if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
387
388 return;
389
390 end clean_up;
391 %page;
392
393
394
395 get_next_arg: proc(Arg_expected, ap1, al1);
396
397
398
399 dcl Arg_expected char(*);
400 dcl (ap1 ptr,
401 al1 fixed bin(21));
402
403 if (argno + 1) > nargs then do;
404 call report_error(error_table_$noarg, "A ^a expected after ^a.", Arg_expected, arg);
405 return;
406 end;
407
408 argno = argno + 1;
409 call cu_$arg_ptr (argno, ap1, al1, (0));
410
411 end get_next_arg;
412 %page;
413
414
415 report_error: proc(ecode, message, str1, str2);
416
417
418
419 dcl ecode fixed bin(35),
420 (message, str1, str2) char(*);
421
422 call com_err_(ecode, WHOAMI, message, str1, str2);
423 goto AZM_RETURN;
424
425 end report_error;
426 %page;%include access_mode_values;
427 %page;%include amu_fdump_info;
428 %page;%include amu_info;
429 %page;%include azm_info;
430 %page;%include ssu_rp_options;
431
432 dcl 1 local_rpo like rp_options;
433 %page;%include ssu_prompt_modes;
434 %page;%include stack_frame;
435
436 end analyze_multics;