1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1983 *
  4    *                                                         *
  5    *********************************************************** */
  6 
  7 
  8 
  9 
 10 
 11 /****^  HISTORY COMMENTS:
 12   1) change(2022-09-25,GDixon), approve(2023-01-16,MCR10129),
 13      audit(2023-02-20,Swenson), install(2023-02-28,MR12.8-1054):
 14       azm version 2.4:
 15       A) When debugging azm, add its containing dir to info directory
 16          search list.
 17                                                    END HISTORY COMMENTS */
 18 
 19 
 20 
 21 
 22 analyze_multics: azm: procedure () options (variable);
 23 
 24 /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */
 25 
 26 /* Main procedure for Multics Online Analysis subsystem
 27    09/07/80 W. Olin Sibert
 28 
 29    Modified 06/23/83 by B. Braun to update user interface as per MTB-624
 30 
 31    Modified 03 Nov 83 by B. Braun to fix reference thru null pointer when it
 32    encounters an unrecognized variable (phx16285).
 33 
 34    Modified 22 Oct 84 by B. Braun to add the ssu_ standard requests info dir, and the azm version number.
 35    Modified 27 Oct 84 by B. Braun to get rid of amu_arglist_ references as it was never used.
 36    Modified 13 Nov 84 by B. Braun to fix the RQO handler (phx17544).
 37    Modified 06 Dec 84 by B. Braun to call its start_up after initialization is complete. (phx18527).
 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 /* External Static */
 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 /* Internal Static */
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 /* Condition Handlers */
129 
130 dcl  (cleanup, record_quota_overflow)   condition;
131 
132 
133 /*  Builtins */
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);              /* get UID of me for RQO on-unit, and below       */
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        /* Did azm signal this?  */
156        sp = find_condition_frame_ (null());
157        code = 0;
158                                                             /* get UID of owner of condition frame  */
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;            /* Not ours to handle                                       */
166                                                   /* But it is ours if signaled by amu_                       */
167                                                   /* get ptr to amu_                                          */
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);     /* Get UID of amu_                                */
174           if code ^= 0 then do;
175              call continue_to_signal_(code);
176              return;
177              end;
178           if cond_uid ^=  my_uid then do;                   /* Not ours to handle                             */
179              call continue_to_signal_(code);
180              return;
181              end;
182           end;
183 
184        /* We called it, We'll handle it */
185 
186        call ioa_$nnl ("Record_quota_overflow:^2x");
187        if azm_info_ptr = null () then do;
188           /* ok time to punt */
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           /* is current the first */
196           if amu_info.chain.prev = null () then do;
197              /* is there a second */
198              if amu_info.chain.next ^= null () then do;
199                 /* ok try this one */
200                 temp_ptr = amu_info_ptr;
201                 amu_info_ptr = amu_info.chain.next;
202                 end;
203              else do;
204                 /* we are realy out of luck */
205                 call continue_to_signal_ (code);
206                 end;
207              end;
208           else do;
209              /* find the first */
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;                                                 /* end record_quota_overflow condition */
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                                                             /* azm_invocation_list                            */
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                                                             /* If debugging azm, include its directory first  */
302                                                             /*  when searching for subsystem info segments.   */
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                                                             /* Do not prompt                                  */
313     else if prompt_len >0 then do;                          /* set the user specified prompt                  */
314             call ssu_$set_prompt(sci_ptr, (prompt_string));
315             end;
316     else do;                                                /* set the default prompt                         */
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     /* 6/24/83 currently debug mode does nothing, but it may in the future. -B. Braun */
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;                             /* just one request line specified                */
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;                          /* enter request loop                   */
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);               /* amu_$terminate_translation should reset the              */
381                                                             /* amu_info_chain and set amu_info_ptr to that value */
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 /*  This guy gets the next argument from the argument string, complaining if it's not there  */
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 /* reports error messages and aborts the line */
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;