



		    amu_.alm                        02/13/85  0937.5rew 02/13/85  0902.6       74736



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"	AMU_ --- Transfer vector for the Address Management Utilities
"
"	Coded 09/08/80 W. Olin Sibert
"
" 	Modified 01/18/85 by BLB to add vector get_l1dir_shortname.

	name	amu_

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2
	&end

	ext_transfer	terminate_translation,amu_info_$destroy
	ext_transfer        create_translation,amu_info_$create
	ext_transfer        print_text,amu_print_text_$amu_print_text_
	ext_transfer        print_text_offset,amu_print_text_$real_offset
	ext_transfer        print_text_format,amu_print_text_$format
	ext_transfer        print,amu_print_$amu_print_
	ext_transfer        print_apte,amu_print_$apte
        	ext_transfer        print_apte_bf,amu_print_$apte_bf
	ext_transfer        print_char_dump,amu_print_$char_dump
	ext_transfer        print_char_dump_af,amu_print_$af_char_dump
	ext_transfer        print_dump_oct,amu_print_$dump_oct
	ext_transfer        print_dump_pptr,amu_print_$dump_pptr
	ext_transfer        print_dump_pptr_exp,amu_print_$dump_pptr_exp
	ext_transfer        print_dump_ptr,amu_print_$dump_ptr
	ext_transfer        print_dump_ptr_exp,amu_print_$dump_ptr_exp
	ext_transfer        print_inst_dump,amu_print_$inst_dump
	ext_transfer        replace_trans,amu_replace_trans_$amu_replace_trans_
	ext_transfer        return_val,amu_return_val_$amu_return_val_
	ext_transfer        return_val_cpu_from_dbr,amu_return_val_$cpu_tag_from_dbr
	ext_transfer        return_val_cpu_from_idx,amu_return_val_$cpu_tag_from_idx
	ext_transfer        return_val_dbr_from_idx,amu_return_val_$dbr_from_idx
	ext_transfer        return_val_idx_from_dbr,amu_return_val_$idx_from_dbr
	ext_transfer        return_val_per_process,amu_return_val_$per_process
	ext_transfer        return_val_phcs_ok,amu_return_val_$phcs_ok
	ext_transfer        search_path,amu_search_path_$amu_search_path_
	ext_transfer        search_path_get_dump,amu_search_path_$get_dump_paths
	ext_transfer        search_path_get_object,amu_search_path_$get_object_paths
	ext_transfer        search_path_set_dump,amu_search_path_$set_dump_paths
	ext_transfer        search_path_set_object,amu_search_path_$set_object_paths
	ext_transfer        search_seg,amu_search_seg_$amu_search_seg_
	ext_transfer        slt_search_first_sup_seg,amu_slt_search_$get_first_sup_seg
	ext_transfer        slt_search_last_sup_seg,amu_slt_search_$get_last_sup_seg
	ext_transfer        slt_search_seg_num,amu_slt_search_$get_seg_num
	ext_transfer        slt_search_seg_ptr,amu_slt_search_$get_seg_ptr
	ext_transfer        slt_search_init_seg_ptr,amu_slt_search_$get_init_seg_ptr
	ext_transfer        tc_data,amu_tc_data_$amu_tc_data_
	ext_transfer        tc_data_tcq,amu_tc_data_$tcq
	ext_transfer        tc_data_find_apte,amu_tc_data_$find_apte
	ext_transfer        tc_data_print_this_apte,amu_tc_data_$print_this_apte
	ext_transfer        tc_data_find_first_running,amu_tc_data_$find_first_running
	ext_transfer        tc_data_get_apt_entry,amu_tc_data_$get_apt_entry
	ext_transfer        tc_data_get_dbr,amu_tc_data_$get_dbr
	ext_transfer        temp_seg,amu_temp_seg_$amu_temp_seg_
	ext_transfer	temp_seg_get,amu_temp_seg_$get
	ext_transfer        temp_seg_release_all,amu_temp_seg_$release_all
	ext_transfer        translate,amu_translate_$amu_translate_
	ext_transfer        translate_add,amu_translate_$add
	ext_transfer        translate_allocate,amu_translate_$allocate
	ext_transfer        translate_get,amu_translate_$get
	ext_transfer        translate_force_add,amu_translate_$force_add
	ext_transfer        get_l1dir_shortname,amu_get_name_$get_l1dir_shortname
	ext_transfer        get_va_args,amu_parse_ptr_args_$get_va_args
	ext_transfer        get_va_args_given_start,amu_parse_ptr_args_$get_va_args_given_start
	ext_transfer        get_segno_from_name,amu_parse_ptr_args_$get_segno
	ext_transfer        resolve_virtual_addr,amu_parse_ptr_args_$resolve_va
	ext_transfer        deadproc,amu_deadproc_$amu_deadproc_
	ext_transfer        dp_create_uid_hash,amu_deadproc_$create_uid_hash
	ext_transfer        current_deadproc,amu_deadproc_$cur_dp
	ext_transfer        dp_segno_to_name,amu_deadproc_$segno_to_name
	ext_transfer        dp_name_to_segno,amu_deadproc_$name_to_segno
	ext_transfer        deadproc_name,amu_deadproc_$name_dp
	ext_transfer        deadproc_name_af,amu_deadproc_$name_dp_af
	ext_transfer        deadproc_init,amu_deadproc_$init_deadproc
	ext_transfer        deadproc_term,amu_deadproc_$term_deadproc
	ext_transfer        dp_expand_to_ptr,amu_deadproc_$expand_to_ptr
	ext_transfer        definition_get_prn,amu_definition_$get_prn
	ext_transfer        definition_set_prn_name,amu_definition_$set_prn_name
	ext_transfer        definition_set_prn,amu_definition_$set_prn
	ext_transfer        definition_set_from,amu_definition_$set_from
	ext_transfer        definition_ptr,amu_definition_$ptr
	ext_transfer        definition_offset,amu_definition_$offset
	ext_transfer        do_translation,amu_do_translation_$amu_do_translation_
	ext_transfer        do_translation_segno,amu_do_translation_$ptr_given_segno
	ext_transfer        do_translation_by_ptr,amu_do_translation_$by_ptr
	ext_transfer        do_translation_hunt_ptr,amu_do_translation_$hunt_ptr
	ext_transfer        do_translation_hunt,amu_do_translation_$hunt
	ext_transfer        error,amu_error_$amu_error_
	ext_transfer        error_for_caller,amu_error_$for_caller
	ext_transfer        error_info,amu_error_$info
	ext_transfer        find_system_fdump,amu_find_system_dump_$fdump
	ext_transfer        find_system_pdir,amu_find_system_dump_$pdir
	ext_transfer        list_system_dumps,amu_find_system_dump_$list
	ext_transfer        fdump_mgr_cur_erf,amu_fdump_mgr_$cur_erf
	ext_transfer        fdump_mgr_terminate_fdump,amu_fdump_mgr_$terminate_fdump
          ext_transfer	fdump_mgr_really_terminate,amu_fdump_mgr_$really_terminate_fdump
	ext_transfer        fdump_mgr_name_erf,amu_fdump_mgr_$name_erf 
	ext_transfer        fdump_mgr_list_fdump,amu_fdump_mgr_$list_fdump
	ext_transfer        fdump_mgr_init_fdump,amu_fdump_mgr_$init_fdump
	ext_transfer        fdump_mgr_find_fdump,amu_fdump_mgr_$find_fdump
	ext_transfer        fdump_mpt,amu_fdump_mpt_$amu_fdump_mpt_
          ext_transfer        fdump_mpt_change_idx,amu_fdump_mpt_$change_idx
          ext_transfer        fdump_mpt_temp_change_idx,amu_fdump_mpt_$temp_change_idx
	ext_transfer        fdump_mpt_current_process,amu_fdump_mpt_$current_process
	ext_transfer        fdump_mpt_terminate,amu_fdump_mpt_$terminate
	ext_transfer        fdump_mpt_revert_idx,amu_fdump_mpt_$revert_idx
	ext_transfer        fdump_mpt_fill_proc_table,amu_fdump_mpt_$fill_proc_table
	ext_transfer        fdump_mpt_current_process_af,amu_fdump_mpt_$current_process_af
	ext_transfer        fdump_translate_contiguous,amu_fdump_translate_$contiguous
	ext_transfer        fdump_translate_to_temp_seg,amu_fdump_translate_$to_temp_seg
	ext_transfer        fdump_translate_get_translation,amu_fdump_translate_$get_translation
	ext_transfer        fdump_translate_get_seg_lth,amu_fdump_translate_$get_seg_lth
	ext_transfer        get_name,amu_get_name_$amu_get_name_
	ext_transfer        get_name_for_structure,amu_get_name_$for_structure
	ext_transfer        get_name_ptr_count,amu_get_name_$get_ptr_count
	ext_transfer        get_name_no_comp,amu_get_name_$no_comp
	ext_transfer        hardcore_info_deadproc,amu_hardcore_info_$deadproc
	ext_transfer        hardcore_info_set_cur_ptrs,amu_hardcore_info_$set_cur_ptrs
	ext_transfer        hardcore_info_fdump,amu_hardcore_info_$fdump
	ext_transfer        kst_util_expand_uid_path,amu_kst_util_$expand_uid_path
	ext_transfer        kst_util_segno_to_uid,amu_kst_util_$segno_to_uid
	ext_transfer        kst_util_segno_to_uid_path,amu_kst_util_$segno_to_uid_path
	ext_transfer        kst_util_uid_to_uid_path,amu_kst_util_$uid_to_uid_path
	ext_transfer        kst_util_uid_to_kstep,amu_kst_util_$uid_to_kstep
	ext_transfer        check_info_hard,amu_check_info_$hard
	ext_transfer        check_info,amu_check_info_$amu_check_info_
	end




		    amu_check_info_.pl1             11/19/84  1144.9rew 11/15/84  1445.3       19242



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_check_info_: proc (P_amu_info_ptr);

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* Minor procedure used to validate an amu_info */

dcl  P_amu_info_ptr pointer parameter;

dcl  amu_error_ entry options (variable);

dcl  (null, substr, unspec) builtin;

%page;

	call ck_amu;
	return;					/* nothing appears wrong */



amu_check_info_$hard:
     entry (P_amu_info_ptr);
	call ck_amu;
	call ck_hard;

	return;					/* nothing appears wrong */

ERROR_RET:					/* somting was wrong and the error was printed */
	return;


ck_amu:
     proc;
	if substr (unspec (P_amu_info_ptr), 31, 6) ^= "43"b3 then do;
	     call amu_error_ ((null ()), 0, "amu_check_info_: Invalid amu_info pointer: ^w ^w",
		substr (unspec (P_amu_info_ptr), 1, 36), substr (unspec (P_amu_info_ptr), 37, 36));
	     goto ERROR_RET;
	     end;
	amu_info_ptr = P_amu_info_ptr;
	if amu_info_ptr = null () then do;
	     call amu_error_ (amu_info_ptr, 0, "amu_check_info_: Null amu_info pointer.");
	     goto ERROR_RET;
	     end;
	if amu_info.version ^= AMU_INFO_VERSION_2 then do;
	     call amu_error_ (amu_info_ptr, 0, "amu_check_info_: Invalid amu_info version ""^8a"" at ^p.",
		amu_info.version, amu_info_ptr);

	     goto ERROR_RET;
	     end;
     end ck_amu;



ck_hard:
     proc;
	if substr (unspec (hardcore_info_ptr), 31, 6) ^= "43"b3 then do;
	     call amu_error_ ((null ()), 0, "amu_check_info_: Invalid hardcore_info pointer: ^w ^w",
		substr (unspec (hardcore_info_ptr), 1, 36), substr (unspec (hardcore_info_ptr), 37, 36));
	     goto ERROR_RET;

	     end;


	if hardcore_info_ptr = null () then do;
	     call amu_error_ (hardcore_info_ptr, 0, "amu_check_info_: Null hardcore_info pointer.");

	     goto ERROR_RET;
	     end;

     end ck_hard;

%include amu_info;
     end amu_check_info_;




		    amu_deadproc_.pl1               07/28/87  0939.7r w 07/28/87  0927.6      264519



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_deadproc_:
     proc;

/*  Modified August 84 by B. Braun to correctly analyze dead processes.
    Modified 10 Jan 85 by B. Braun to add entry $name_to_segno.	
    Modified 11 Jan 85 by B. Braun to
      1) Provide more informative error messages in $init_deadproc and $create_uid_hash.
      2) initialize and correctly assign the release_id in old_uid_table.sys_release.
      3) Get rid of double quotes of the pdir name in the id string.
    Modified 12 Jan 85 by B. Braun to call amu_$kst_util_expand_uid_path and delete the internal proc expand_it.
    Modified 13 Jan 85 by B. Braun to make the uid_hash_table per invocation of selecting the 
      deadproc so users don't write into uid_hash_table in the pdir.
    Modified 18 Jan 85 by B. Braun to store short names of level 1 dirs in the hash table
      via a call to amu_$get_l1dir_shortname.
    Modified 24 Jan 85 by B. Braun to $segno_to_name to inititate P_name to "CANNOT-GET-PATH". 
    Modified 02 Feb 85 by B. Braun to have the dp_dir and dp_name set in $init_deadproc and NOT in $create_uid_hash.
*/

/* parameters */

dcl P_amu_info_ptr			ptr;
dcl P_bt				fixed bin (24);
dcl P_caller			char(*);
dcl P_code			fixed bin (35);
dcl P_dir				char (168);
dcl P_name			char (*);
dcl P_ptr				ptr;
dcl P_segno			fixed bin;

/* External Entries */

dcl amu_$create_translation		entry (ptr, fixed bin);
dcl amu_$do_translation_segno	entry (ptr, fixed bin, ptr, fixed bin (35));
dcl amu_$error_for_caller		entry options (variable);
dcl amu_$hardcore_info_deadproc	entry (char(*), ptr, char (168), fixed bin (35));
dcl amu_$kst_util_expand_uid_path	entry (ptr, (16) bit (36) aligned, char(*), fixed bin(35));
dcl amu_$kst_util_segno_to_uid	entry (ptr, fixed bin, bit (36) aligned, fixed bin (35));
dcl amu_$kst_util_segno_to_uid_path	entry (ptr, fixed bin, (16) bit (36) aligned, fixed bin (35));
dcl amu_$kst_util_uid_to_kstep	entry (ptr, bit (36) aligned, fixed bin (18), fixed bin (35));
dcl  amu_$temp_seg_get		entry (pointer, char (*), pointer, pointer);
dcl amu_$temp_seg_release_all		entry (ptr);
dcl amu_$terminate_translation          entry (ptr);
dcl amu_$translate_allocate		entry (ptr, fixed bin);
dcl amu_$translate_add		entry (ptr, ptr, fixed bin, fixed bin (35));
dcl amu_$translate_get		entry (ptr, fixed bin, ptr, fixed bin (35));
dcl cv_oct_check_			entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl expand_pathname_		entry (char (*), char (*), char (*), fixed bin (35));
dcl get_system_free_area_		entry returns (ptr);
dcl get_temp_segment_		entry (char (*), ptr, fixed bin (35));
dcl hash_$opt_size			entry (fixed bin) returns (fixed bin);
dcl hcs_$make_seg			entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35));
dcl hcs_$star_			entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35));
dcl hcs_$status_long		entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
dcl initiate_file_			entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl ioa_				entry () options (variable);
dcl iox_$attach_name		entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl iox_$close			entry (ptr, fixed bin (35));
dcl iox_$detach_iocb		entry (ptr, fixed bin (35));
dcl iox_$get_line			entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl iox_$open			entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl pathname_			entry (char(*), char(*)) returns(char(168));
dcl phcs_$initiate			entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl phcs_$ring_0_peek		entry (ptr, ptr, fixed bin);
dcl phcs_$terminate_noname		entry (ptr, fixed bin (35));
dcl release_temp_segment_		entry (char (*), ptr, fixed bin (35));
dcl ring0_get_$segptr		entry (char (*), char (*), ptr, fixed bin (35));
dcl terminate_file_		entry (ptr, fixed bin(24), bit(*), fixed bin(35));

/* External Static  */

dcl (
     amu_et_$make_uid_hash,
     amu_et_$no_amu_ptr,
     amu_et_$no_kst,
     amu_et_$no_uid_hash,
     amu_et_$no_sl1_in_kst,
     amu_et_$no_sl1_uid,
     error_table_$action_not_performed,
     error_table_$end_of_info,
     error_table_$noentry
    )				fixed bin (35) ext static;

/* Automatic */

dcl af_lth			fixed bin (21);
dcl af_ptr			ptr;
dcl af_sw				bit(1);
dcl attach_desc			char (200);
dcl bitcount			fixed bin (24);
dcl code				fixed bin (35);
dcl cur_state			char (1);
dcl deadproc_dir			char (168);
dcl deadproc_name			char (32);
dcl dlen				fixed bin;
dcl dp_dir_path			char(168);
dcl dseg_ptr			ptr;
dcl expand_path			char (168);
dcl i				fixed bin;
dcl ignore			fixed bin(24);
dcl iocbp				ptr;
dcl 1 info,
      2 char_uid char (12),
      2 name char (32),
      2 newline char(1);
dcl info_ptr			ptr;
dcl kste_offset			fixed bin (18);
dcl look_kst			bit (1);
dcl n_read			fixed bin (21);
dcl old_uid			fixed bin (35);
dcl (rzdp, rzdsp)			ptr;
dcl sl1_uid			bit(36) aligned;
dcl system_area_ptr			ptr;
dcl t_kst_path			char(168);
dcl temp_dir			char (168);
dcl temp_name			char (32);
dcl temp_ptr			ptr;
dcl 1 temp_translation		like translation;
dcl temp_uid_table_ptr		ptr;
dcl 1 tsdw			like sdw aligned;
dcl uid_basep			ptr;
dcl uid_path (16)			bit (36) aligned;

/* Based */

dcl af_str			char (af_lth) varying based (af_ptr);
dcl based_uid			bit (36) aligned based (uid_basep);
dcl data				char (n_read) based (info_ptr);

/* Areas */

dcl system_area			area based (system_area_ptr);

/* Internal Static */

dcl who_ami			char (32) init ("amu_deadproc_") int static options(constant);

/* Builtins */

dcl (addr, addrel, after,
     baseno, binary, convert,
     divide, fixed, hbound, index,
     lbound, max, null, ptr,
     reverse, rtrim, size, sum,
     substr, unspec)		builtin;

/* Conditions */

dcl cleanup			condition;
%page;
/*****************************************************************************/

amu_deadproc_$create_uid_hash: entry(P_dir, P_code);

    amu_info_ptr, status_ptr, kstp, old_uid_table_ptr = null ();
    t_kst_path = "";
    code = 0;

    on cleanup begin;
       if status_ptr ^= null() then free status_branch in (amu_area);
       if kstp ^= null() then call terminate_file_(kstp, ignore, "0010"b, (0));
       if old_uid_table_ptr ^= null() then call terminate_file_(old_uid_table_ptr, ignore, "0010"b, (0));
       if amu_info_ptr ^= null () then call amu_$terminate_translation (amu_info_ptr);
       end;

    call expand_pathname_ (P_dir, deadproc_dir, deadproc_name, code);
    if code ^= 0 then goto END_CREATE;

    dp_dir_path = pathname_ (deadproc_dir, deadproc_name);
    t_kst_path = pathname_ (dp_dir_path, "kst");
    call initiate_file_ (dp_dir_path, "kst", R_ACCESS, kstp, (0), code);
    if kstp = null () then do;
       code = amu_et_$no_kst;
       goto END_CREATE;
       end;

    call amu_$create_translation (amu_info_ptr,SAVED_PROC_TYPE);
    if amu_info_ptr = null () then do;
       code = amu_et_$no_amu_ptr;
       goto END_CREATE;
       end;

    allocate status_branch in (amu_area) set (status_ptr);
    call hcs_$status_long (">", "sl1", 0, status_ptr, null (), code);
    if code ^= 0 then do;
       code = amu_et_$no_sl1_uid;
       goto CREATE_UID_ERR;
       end;

    sl1_uid = status_branch.long.uid;

    call hcs_$make_seg (dp_dir_path, "uid_hash_table", "", RW_ACCESS_BIN, old_uid_table_ptr, code);
    if code ^= 0 then do;
       code = amu_et_$make_uid_hash;
       goto CREATE_UID_ERR;
       end;

    allocate_uid_hash = hash_$opt_size (max((kst.highseg - kst.lowseg), divide(fixed("7777"b3,17),3,17)));
    old_uid_table.max_uid_ind = allocate_uid_hash;
    old_uid_table.hash_factor = 3;
    old_uid_table.uid_array (*).uid = ""b;
    old_uid_table.uid_array (*).seg_name,
       old_uid_table.dp_name,
       old_uid_table.dp_dir,
       old_uid_table.sys_release = "";

    call add_sl1_segs_to_hash (sl1_uid, code);
    if code ^= 0 then  goto CREATE_UID_ERR;

CREATE_UID_ERR:

    if status_ptr ^= null () then free status_branch in (amu_area);
    if kstp ^= null() then call terminate_file_(kstp, ignore, "0010"b, (0));
    if old_uid_table_ptr ^= null() then call terminate_file_(old_uid_table_ptr, ignore, "0010"b, (0));
    if amu_info_ptr ^= null () then call amu_$terminate_translation (amu_info_ptr);

END_CREATE:
    P_code = code;    
    return;
%page;
/*****************************************************************************/

amu_deadproc_$cur_dp:
	entry (P_amu_info_ptr);

	cur_state = ">";
	af_sw = "0"b;
	goto COMMON_NAME;	

/*****************************************************************************/

amu_deadproc_$name_dp:
	entry (P_amu_info_ptr);
	cur_state = " ";
	af_sw = "0"b;
	goto COMMON_NAME;

/*****************************************************************************/

amu_deadproc_$name_dp_af:
	entry (P_amu_info_ptr, af_ptr, af_lth);

	cur_state = " ";
	af_sw = "1"b;

COMMON_NAME:

	amu_info_ptr = P_amu_info_ptr;
	old_uid_table_ptr = amu_info.fdump_info_ptr;
	if af_sw then af_str =  rtrim(old_uid_table.dp_dir) || ">" || rtrim(old_uid_table.dp_name);
	else call ioa_ ("^1a DP ""^a"" from directory ^a Sys-Release ^a",cur_state,
	     old_uid_table.dp_name,old_uid_table.dp_dir,
	     old_uid_table.sys_release);
	return;
%page;
/*****************************************************************************/

amu_deadproc_$init_deadproc:
     entry (P_caller, P_dir, P_amu_info_ptr, P_code);

     call amu_$create_translation (amu_info_ptr, SAVED_PROC_TYPE);
     if amu_info_ptr = null () then do;
        P_code = error_table_$action_not_performed;
        call amu_$error_for_caller (amu_info_ptr, P_code, P_caller, "Unable to create the amu_ translation for ^a.", P_dir);
        return;
        end;
     P_amu_info_ptr = amu_info_ptr;
    amu_info.process_info_ptr = null();
    amu_info.fdump_info_ptr = null();
    amu_info.copy_chain = null();
    old_uid_table_ptr = null();
    dseg_ptr, iocbp, temp_ptr, temp_uid_table_ptr = null();

    on cleanup begin;   
       if iocbp ^= null() then do;
          call iox_$close (iocbp, (0));
          call iox_$detach_iocb (iocbp, (0));
	end;
       if temp_uid_table_ptr ^= null() then call terminate_file_(temp_uid_table_ptr, (0), "0010"b, (0));
       if amu_info_ptr ^= null() then call amu_deadproc_$term_deadproc (amu_info_ptr, (0));
     end;

    allocate process_info in (amu_area) set (amu_info.process_info_ptr);
    call amu_$translate_allocate (amu_info_ptr, 25);

    dp_dir_path = P_dir;
    call expand_pathname_ (P_dir, deadproc_dir, deadproc_name, code);
    if code ^= 0 then do;
       call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Expanding the pathname ^a.", P_dir);
       P_code = code;
       return;
       end;
    call amu_$hardcore_info_deadproc (P_caller, amu_info_ptr, dp_dir_path, code);
    if code ^= 0 then do;
       P_code = code;
       return;
       end;
    

    kstp = process_info.kst.local_ptr; 

    /* setup uid_hash_table */

    call initiate_file_ (dp_dir_path, "uid_hash_table", R_ACCESS, temp_uid_table_ptr, (0), code);    
    if temp_uid_table_ptr = null () then do;
       code = amu_et_$no_uid_hash;
       call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Initiating ^a.", pathname_(dp_dir_path, "uid_hash_table"));
       P_code = code;
       if amu_info_ptr ^= null() then call amu_deadproc_$term_deadproc (amu_info_ptr, (0));
       goto END_INIT;
       end;

    call amu_$temp_seg_get (amu_info_ptr, "DP " || rtrim(deadproc_name), amu_info.copy_chain, old_uid_table_ptr);
    
    /* copy old_uid_hash contents to the user process area. */

    allocate_uid_hash =  temp_uid_table_ptr -> old_uid_table.max_uid_ind;
    old_uid_table_ptr -> old_uid_table = temp_uid_table_ptr -> old_uid_table;

    amu_info.fdump_info_ptr = old_uid_table_ptr;

    /* set name and dir in old_uid_table */
    old_uid_table.dp_dir = deadproc_dir;
    old_uid_table.dp_name = deadproc_name;

    info_ptr = addr (info);
    uid_basep = addr (old_uid);
    attach_desc = "vfile_ " || rtrim (dp_dir_path) || ">pdir_info";
    call iox_$attach_name ("amu_dp_sw", iocbp, attach_desc, null (), code);
    if code ^= 0 then do;
       call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Attaching switch ^a to read ^a.", 
			    attach_desc, pathname_(dp_dir_path, "pdir_info"));
       P_code = code;
       if amu_info_ptr ^= null() then call amu_deadproc_$term_deadproc (amu_info_ptr, (0));
       goto END_INIT;
       end;

    call iox_$open (iocbp, 1, "0"b, code);
    if code ^= 0 then do;
       call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Reading ^a.", pathname_(dp_dir_path, "pdir_info"));
       P_code = code;
       call iox_$detach_iocb (iocbp, code);
       if amu_info_ptr ^= null() then call amu_deadproc_$term_deadproc (amu_info_ptr, (0));
       goto END_INIT;
       end;

    /* First line is the system release_id */
    call iox_$get_line (iocbp, info_ptr, 45, n_read, code);
    if code ^= 0 then do;
       call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Reading ^a.", pathname_(dp_dir_path, "pdir_info"));
       if amu_info_ptr ^= null() then call amu_deadproc_$term_deadproc (amu_info_ptr, (0));
       goto ERROR;
       end;

    old_uid_table.sys_release = rtrim (info.char_uid);
    translation_ptr = addr(temp_translation);
    /* get dseg ptr */
    call amu_$do_translation_segno(amu_info_ptr, 0, dseg_ptr, code);
    if code ^= 0 then do;
       call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Getting dseg ptr ^a.", pathname_(dp_dir_path, "dseg"));
       if amu_info_ptr ^= null() then call amu_deadproc_$term_deadproc (amu_info_ptr, (0));
       goto ERROR;
       end;
    
    /* get next line to begin loop */

    call iox_$get_line (iocbp, info_ptr, 45, n_read, code);
    if code ^= 0 then do;
       call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Reading ^a.", pathname_(dp_dir_path, "pdir_info"));
       if amu_info_ptr ^= null() then call amu_deadproc_$term_deadproc (amu_info_ptr, (0));
       goto ERROR;
       end;

    do while (code = 0);
       old_uid = cv_oct_check_ (info.char_uid, code);
       temp_name = info.name;
       call initiate_file_ (dp_dir_path, temp_name, R_ACCESS, temp_ptr, bitcount, code);
       if temp_ptr = null () then do;
          call ioa_ ("Cannot initiate ^a", pathname_(dp_dir_path, temp_name));
	code = 0;
	goto NEXT;
          end;
       call check_name (temp_name, temp_ptr, look_kst);
       if look_kst then do;
	call amu_$kst_util_uid_to_kstep (kstp, based_uid, kste_offset, code);
	if code ^= 0 then do;
	   if code = error_table_$noentry then do;
	      call ioa_ ("Cannot translate ^a with uid ^a.", temp_name, char_uid);
	      code = 0;
	      end;
	  else do; 
	     call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Unable to get the kst entry for ^a with uid ^a.",
				  temp_name, char_uid);
	     code = 0;
	     end;
	  end;
	else do;
	   kstep = addrel (kstp, kste_offset);
	   call add_hash (old_uid, (temp_name),"1"b);
	   call add_trans (temp_ptr, (kste.segno), dseg_ptr, code);
	   if code ^= 0 then do;
                call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Unable to add ^a (segno ^o) to uid_hash_table.",
				   rtrim(temp_name), kste.segno);
	      if amu_info_ptr ^= null() then call amu_deadproc_$term_deadproc (amu_info_ptr, (0));
	      goto ERROR;
	      end;
	   end;
	end;
NEXT:  
       call iox_$get_line (iocbp, info_ptr, 45, n_read, code);
       if (code ^= 0) & (code ^= error_table_$end_of_info) then do;
	call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Getting next line of ^a.",
			       pathname_(dp_dir_path, "pdir_info"));
          if amu_info_ptr ^= null() then call amu_deadproc_$term_deadproc (amu_info_ptr, (0));
          goto ERROR;
	end;
       end;

    code = 0;
    
    call get_stack_base(dp_dir_path, dseg_ptr, code);
ERROR:
    P_code = code;
    call iox_$close (iocbp, (0));
    call iox_$detach_iocb (iocbp, (0));

END_INIT:
    if temp_uid_table_ptr ^= null() then call terminate_file_(temp_uid_table_ptr, (0), "0010"b, (0));
    return;
%page;	
/*****************************************************************************/

amu_deadproc_$segno_to_name:
     entry (P_amu_info_ptr, P_segno, P_name, P_code);

/*  Given a segment number, finds the name of the segment by comparing the uid
    of the segment number with the uids in the kst until a match is found.

    P_amu_info_ptr     pointer to amu_info structure (input).
    P_segno	   segment number (input).
    P_name	   name of the segment (output).
    P_code	   standard error code (output).
*/
    amu_info_ptr = P_amu_info_ptr;
    P_name, expand_path = "CANNOT-GET-PATH";
    P_code, code = 0;

    /* first check to see if one of those "special segnos" */
    if P_segno = hardcore_info.stack_0 then do;
       P_name = "stack_0";
       goto RET_NAME;
       end;

    old_uid_table_ptr = amu_info.fdump_info_ptr;
    kstp = process_info.kst.local_ptr;
    uid_basep = addr (old_uid);

    call amu_$kst_util_segno_to_uid (kstp, P_segno, based_uid, code);  /* get the uid */
    if code ^= 0 then goto RET_NAME;
    call get_name_from_hash (based_uid, expand_path);	/* see if its already in the hash table		*/
    if expand_path = "" then do;			/* Not in the hash table			*/
       call amu_$kst_util_segno_to_uid_path (kstp, P_segno, uid_path, code);
       if code ^= 0 then goto RET_NAME;
       call amu_$kst_util_expand_uid_path (kstp, uid_path, expand_path, code);
       if code ^= 0 then goto RET_NAME;
       else do;
          call add_hash (old_uid, expand_path, "0"b);
	end;
       end;

RET_NAME: 
    P_name = expand_path;
    P_code = code;
    return;
%page;	
/*****************************************************************************/

amu_deadproc_$name_to_segno:
     entry (P_amu_info_ptr, P_name,  P_segno, P_code);

/*  Given a segment name, finds the segment number by looping through the
    uid_hash_table until finding the uid which corressponds with the given
    name. Then, we loop through the kst matching on uids to get the segment 
    number.

    P_amu_info_ptr     pointer to amu_info structure (input).
    P_name	   name of the segment (input).
    P_segno	   segment number (output).
    P_code	   standard error code (output).
*/
dcl no_match bit(1);
dcl segno fixed bin;
dcl match_name char(256) var;

    amu_info_ptr = P_amu_info_ptr;
    P_segno, segno = -1;
    P_code, code = 0;

    old_uid_table_ptr = amu_info.fdump_info_ptr;
    kstp = process_info.kst.local_ptr;
    uid_basep = addr (old_uid);
    match_name = rtrim(P_name);
    if index (match_name, ">" ) > 0 then 		/* In this case match on entryname only		*/
       match_name = reverse(substr(reverse(match_name), 1, index(reverse(match_name), ">") -1));
    
    /* Loop through the uid_hash_table until a match on the names is found. */

    no_match = "1"b;
    do i = 0 to old_uid_table.max_uid_ind while (no_match);
       if index(old_uid_table.uid_array (i).seg_name, match_name) > 0 then do;
          no_match = "0"b;
	based_uid = old_uid_table.uid_array (i).uid;
	end;
       end;

    if no_match then do;
       code = error_table_$noentry;
       goto RET_SEGNO;
       end;

    /* Now, with the uid get its kste which contains the segno. */

    kste_offset = 0;
    call amu_$kst_util_uid_to_kstep (kstp, based_uid, kste_offset, code); 
    kstep = addrel (kstp, kste_offset);
    if code = 0 then segno = kste.segno;

RET_SEGNO: 
    P_segno = segno;
    P_code = code;
    return;
%page;
/*****************************************************************************/

amu_deadproc_$expand_to_ptr:
     entry (P_amu_info_ptr, P_segno, P_ptr, P_bt);
	amu_info_ptr = P_amu_info_ptr;
	old_uid_table_ptr = amu_info.fdump_info_ptr;
	P_ptr = null ();
	P_bt = 0;
	kstp = process_info.kst.local_ptr;
	call amu_$kst_util_segno_to_uid_path (kstp, P_segno, uid_path, code);
	if code ^= 0 then return;

          call amu_$kst_util_expand_uid_path (kstp, uid_path, expand_path, code);
	if code ^= 0 then return;

	call expand_pathname_ (expand_path, temp_dir, temp_name, code);
	if code ^= 0 then return;
	call initiate_file_ (temp_dir, temp_name, R_ACCESS, temp_ptr, bitcount, code);
	P_ptr = temp_ptr;
	P_bt = bitcount;
	return;
%page;
/*****************************************************************************/

amu_deadproc_$term_deadproc:
     entry (P_amu_info_ptr, P_code);

    amu_info_ptr = P_amu_info_ptr;		/* terminate all translated segs */
    if amu_info.translation_table_ptr ^= null then do;
       do i = lbound (translation_table.array, 1) to hbound (translation_table.array, 1);
	if (translation_table.used (i) = "1"b) & (translation_table.array (i).flags.in_dp_dir) then do;
	   temp_ptr = translation_table.array (i).part1.ptr;
	   if temp_ptr ^= null() then call terminate_file_(temp_ptr, (0), "0010"b, (0));
	   end;
	end;
       free translation_table in (amu_area);
       amu_info.translation_table_ptr = null ();
       end;

    if amu_info.process_info_ptr ^= null () then do;
       free process_info in (amu_area);
       amu_info.process_info_ptr = null ();
       end;	
				/* release all temp segs known in copy_chain */
    call amu_$temp_seg_release_all (amu_info.copy_chain);
    return;
%page;
/*****************************************************************************/

add_hash:
     proc (fixed_uid, name,pd_sw);
dcl fixed_uid fixed bin (35);
dcl in_uid bit (36);
dcl name char (168);
dcl ind fixed bin;
dcl pd_sw bit (1);
dcl short_path char(168);
dcl code fixed bin(35);
dcl amu_$get_l1dir_shortname  entry(char(*), char(*), fixed bin(35));  

    short_path = "";
    code = 0;
    ind = hash_uid (fixed_uid);
    in_uid = unspec (fixed_uid);
    old_uidep = addr (old_uid_table.uid_array (ind));
    if old_uide.uid = ""b then goto FILL_TABLE;
    else do;
       if old_uide.uid = in_uid then goto END_ADD_HASH;
       do ind = (ind + 1) to old_uid_table.max_uid_ind;     /* check it sequentially			*/
	old_uidep = addr (old_uid_table.uid_array (ind));
	if old_uide.uid = in_uid then goto END_ADD_HASH;
	if old_uide.uid = ""b then goto FILL_TABLE;
	end;
       end;

FILL_TABLE:
    old_uide.uid = in_uid;
    if pd_sw then old_uide.seg_name = "[pd]>" || rtrim (name);
    else do;
       call amu_$get_l1dir_shortname (name, short_path, code);
       if code = 0 then old_uide.seg_name = short_path;
       else  old_uide.seg_name = rtrim (name);
       end;

END_ADD_HASH:
    return;

end add_hash;
%page;
/*****************************************************************************/

add_sl1_segs_to_hash:   proc (sl1_uid, code);

dcl sl1_uid bit(36) aligned;
dcl code fixed bin(35);

dcl seg_ind fixed bin;
dcl got_one bit(1);

    got_one = "0"b;
    do seg_ind = kst.highseg to kst.lowseg by -1;
       code = 0;
       call amu_$kst_util_segno_to_uid_path (kstp, seg_ind, uid_path, code);
       if code ^= 0 then goto NEXT_ONE;
       if uid_path (2) = sl1_uid then do;
          call amu_$kst_util_expand_uid_path (kstp, uid_path, expand_path, code);
          if code ^= 0 then goto END_ADD_SL1;
          got_one = "1"b;
	call add_hash (fixed(kst_entry(seg_ind).uid,35), expand_path, "0"b);
	end;
NEXT_ONE:
       end;    /* loop */
END_ADD_SL1:
  
    if ^(got_one) then code = amu_et_$no_sl1_in_kst;
    else code = 0;

end add_sl1_segs_to_hash;
%page;
/*****************************************************************************/

add_trans:
     proc (seg_ptr, segnum, dseg_ptr, code);

dcl code fixed bin(35);
dcl  segnum fixed bin;
dcl  seg_ptr ptr;
dcl sdwp ptr;
dcl bound fixed bin(19);
dcl dseg_ptr ptr;

          code = 0;
				/* get a pointer to the SDW for the segment */
          sdwp = addrel(dseg_ptr, 2*segnum);
	
          bound = (binary (sdwp->sdw.bound, 14) +1) * 16; /* get number of words */

	translation.segno = segnum;
	translation.flags = "0"b;
	translation.flags.in_perm_seg = "1"b;
	translation.flags.in_dp_dir = "1"b;
	translation.part1.ptr = seg_ptr;
	translation.part1.lth = bound;
	translation.part2.ptr = null ();
	translation.part2.lth = 0;
	call amu_$translate_add (amu_info_ptr, translation_ptr, (translation.segno), code);
	if code ^= 0 then do;
	     call ioa_ ("translation error segment ^o ^a", segnum, data);
	     call amu_$translate_get (amu_info_ptr,segnum,translation_ptr,code);
	     if code ^= 0 then do;
		call ioa_ ("No trans (get trans)");
		return;
	     end;
	     call ioa_ ("translation is: segno ^o ^[two_part^1x]^[in_dump^x]^[in_temp_seg^x]^[in_perm_seg^x]^[in_dp_dir]",
		     translation.segno, translation.two_part,translation.in_dump,translation.in_temp_seg,
		     translation.in_perm_seg,translation.in_dp_dir);
	     call ioa_ ("Part1.ptr = ^p lth = ^o (oct)",translation.part1.ptr,translation.part1.lth);
	     call ioa_ ("Part2.ptr = ^p lth = ^o (oct)",translation.part2.ptr,translation.part2.lth);
	     return;
	     end;
     end add_trans;
%page;
/*****************************************************************************/

check_name:
     proc (name, seg_ptr, look);
dcl  name char (32);
dcl  seg_ptr ptr;
dcl  look bit (1);

	look = "0"b;
	if name = "dseg" then return;
	if name = "pds" then return;
	if name = "prds" then return;
	if name = "kst" then return;
	if name = "stack_0" then return;
	look = "1"b;
     end check_name;
%page;
/*****************************************************************************/

get_name_from_hash:
     proc (in_uid, segname);

dcl  in_uid bit (36) aligned;
dcl  segname char (*);
dcl  ind fixed bin;

    ind = hash_uid (fixed (in_uid, 35));
    old_uidep = addr (old_uid_table.uid_array (ind));
    if old_uide.uid = in_uid then do;
       segname = old_uide.seg_name;
       return;
       end;
    else if old_uide.uid ^= ""b then do;
       do ind = (ind + 1) to old_uid_table.max_uid_ind while (old_uide.uid ^= ""b);
	old_uidep = addr (old_uid_table.uid_array (ind));
	if old_uide.uid = in_uid then do;
	   segname = old_uide.seg_name;
	   return;
	   end;
	end;
       end;
    segname = "";
    return;
end get_name_from_hash;
%page;
/*****************************************************************************/

get_stack_base: proc (dirname, dseg_ptr, code);

dcl dirname char(*);
dcl code fixed bin (35);
dcl dseg_ptr ptr;
dcl stackbase  char(32);
dcl stackno fixed bin;
dcl sb_ptr ptr;

    code = 0;
    star_entry_ptr = null ();
    star_names_ptr = null ();
    sb_ptr = null();
    system_area_ptr = get_system_free_area_();
    on condition (cleanup) begin;
       if star_names_ptr ^= null () then free star_names in (system_area);
       if star_entry_ptr ^= null () then free star_entries in (system_area);
       end;

    call hcs_$star_ (dirname, "stack_base_*", star_BRANCHES_ONLY, system_area_ptr, star_entry_count, star_entry_ptr, 
		star_names_ptr, code);

    if code ^= 0 | star_entry_count = 0 then do;
       call amu_$error_for_caller (amu_info_ptr, 0, P_caller, "Unable to determine the stack base.");
       code = error_table_$action_not_performed;
       goto END_STACK_BASE;
       end;

    stackbase = "";
    stackbase = after(star_names(1), "stack_base_");
    if stackbase ^= "" then do;
       /* get stack base seg number */
       stackno = convert(stackno, rtrim(stackbase));

       hardcore_info.segno.stack_0 = stackno;
       call initiate_file_ (dirname, "stack_0", R_ACCESS, sb_ptr, (0), code);
       if sb_ptr = null() then do;
          call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Initiating ^a.", pathname_(dirname, "stack_0"));
	code = 0;  /* non-fatal error */
	goto END_STACK_BASE;
	end;
       call add_trans (sb_ptr, stackno, dseg_ptr, code);
       if code ^= 0 then do;
          call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Unable to add ^a (segno ^o) to uid_hash_table.", 
			       pathname_(dirname, "stack_0"), stackno);
          code = 0;
          goto END_STACK_BASE;
          end;
       end;
END_STACK_BASE:
    if star_names_ptr ^= null () then free star_names in (system_area);
    if star_entry_ptr ^= null () then free star_entries in (system_area);
    revert cleanup;

end get_stack_base;
%page;
/*****************************************************************************/

hash_uid:
     proc (in_uid) returns (fixed bin);
dcl  in_uid fixed bin (35);
dcl  rev_uid bit (12);
dcl  hash_ind fixed bin;
	rev_uid = reverse (substr (unspec (in_uid), 25, 12));
	hash_ind = divide (fixed (rev_uid, 17), hash_factor, 17);
	if hash_ind > old_uid_table.max_uid_ind then do;
	     call ioa_ ("hash_ind = ^d  old_uid_table.max_uid_ind = ^d (dec) uid = ^12.3b", 
		     hash_ind, old_uid_table.max_uid_ind, unspec(in_uid));
	end;
	return (hash_ind);
     end hash_uid;
%page;%include access_mode_values;
%page;%include amu_hardcore_info;
%page;%include amu_info;
%page;%include amu_old_uid_table;
%page;%include amu_process_info;
%page;%include amu_translation;
%page;%include dir_entry;
%page;%include dir_header;
%page;%include dir_name;
%page;%include kst;
%page;%include sdw;
%page;%include star_structures;
%page;%include status_structures;


     end amu_deadproc_;




		    amu_definition_.pl1             11/19/84  1144.9rew 11/15/84  1445.3       84420



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_definition_: proc;
	return;

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */


dcl  P_amu_info_ptr ptr,
     P_entrypoint_name char (*),
     P_prn_name char (*),
     P_seg_ptr ptr,
     P_segno fixed bin,
     P_offset fixed bin (18),
     P_seg_name char (*),
     P_data_ptr ptr,
     P_code fixed bin (35);


dcl  data_ptr ptr;
dcl  ptr_data (0:7) ptr based (data_ptr);
dcl  ptr_entry bit (1);
dcl  prn_name char (6);
dcl  def_name char (72) varying;
dcl  temp_def_name char (72);
dcl  def_offset fixed bin (18);
dcl  d_type fixed bin;
dcl  seg_ptr pointer;
dcl  def_ptr pointer;
dcl  last_name_entry_ptr pointer;
dcl  hash_index fixed bin;
dcl  code fixed bin (35);
dcl  name_entry_ptr pointer;
dcl  name_entry_lth fixed bin;

dcl  1 name_entry aligned based (name_entry_ptr),
       2 next pointer unaligned,
       2 seg_ptr pointer unaligned,
       2 name_lth fixed bin,
       2 name char (name_entry_lth refer (name_entry.name_lth));

dcl  1 cur_ptrs like hardcore_cur;

dcl  ring0_get_$definition_given_slt
	entry (ptr, char (*), char (*), fixed bin (18), fixed bin, fixed bin (35), ptr, ptr, ptr);
dcl  amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  ioa_ entry () options (variable);


dcl  (
     error_table_$bad_arg
     ) fixed bin (35) external static;


dcl  (addr, addrel, baseptr, dimension, 
      fixed, length, mod, null, pointer,
      rank, rel, rtrim, search, substr) builtin;

%page;

amu_definition_$ptr:
     entry (P_amu_info_ptr, P_seg_name, P_entrypoint_name, P_code) returns (ptr);
	ptr_entry = "1"b;
	goto comm_code;

amu_definition_$offset:
     entry (P_amu_info_ptr, P_seg_name, P_entrypoint_name, P_code) returns (fixed bin (18));
	ptr_entry = "0"b;
comm_code:
	amu_info_ptr = P_amu_info_ptr;
	if search (P_seg_name, "<>") ^= 0 then do;	/* it's a pathname, reject it */
	     P_code = error_table_$bad_arg;		/* best code I could find */
	     if ptr_entry then
		return (null ());
	     else return (0);
	     end;
	call cr_def_name;

	call lookup (temp_def_name);			/* sets name_entry_ptr, last_name_entry_ptr, hash_index */
	call find_def;
	if name_entry_ptr = null () then do;		/* not there already, we must find it */


	     if code ^= 0 then do;
		P_code = code;			/* Nope. */
		if ptr_entry then
		     return (null ());
		else return (0);
		end;
	     def_ptr = addrel (seg_ptr, def_offset);	/* generate a pointer to the actual definition */
	     call insert (temp_def_name, def_ptr);	/* insert it */
	     end;

	else def_ptr = name_entry.seg_ptr;		/* otherwise, copy it from the found name_entry */
	P_code = 0;
	if ptr_entry then
	     return (def_ptr);
	else return (fixed (rel (def_ptr), 18));

amu_definition_$set_prn_name:
     entry (P_amu_info_ptr, P_prn_name, P_seg_name, P_entrypoint_name, P_code);
	amu_info_ptr = P_amu_info_ptr;
	prn_name = P_prn_name;
	code, P_code = 0;
	call set_t_idx;
	if code ^= 0 then do;
	     P_code = code;
	     return;
	end;
	call cr_def_name;
	call lookup (temp_def_name);
	if name_entry_ptr = null () then do;
	     call find_def;
	     if code ^= 0 then do;
		P_code = code;
		return;
		end;
	     end;
	definitions_info.t_ptrs (t_ptr_indx).val = pointer (def_ptr, def_offset);
	P_code = 0;
	return;

amu_definition_$set_prn:
     entry (P_amu_info_ptr, P_prn_name, P_segno, P_offset, P_code);
	amu_info_ptr = P_amu_info_ptr;
	prn_name = P_prn_name;
	code, P_code = 0;
	call set_t_idx;
	if code ^= 0 then do;
	     P_code = code;
	     return;
	end;
	definitions_info.t_ptrs (t_ptr_indx).val = pointer (baseptr (P_segno), P_offset);
	return;

amu_definition_$get_prn:
     entry (P_amu_info_ptr, P_prn_name, P_seg_ptr, P_code);
	amu_info_ptr = P_amu_info_ptr;
	prn_name = P_prn_name;
	code, P_code = 0;
	call set_t_idx;
	if code ^= 0 then do;
	     P_code = code;
	     return;
	     end;


	P_seg_ptr = definitions_info.t_ptrs (t_ptr_indx).val;
	return;


amu_definition_$set_from:
     entry (P_amu_info_ptr, P_prn_name, P_data_ptr, P_code);
	amu_info_ptr = P_amu_info_ptr;
	prn_name = P_prn_name;
	data_ptr = P_data_ptr;
	code, P_code = 0;
	if prn_name = "prs" then do;
	     do t_ptr_indx = 0 to 7;
		if addr (ptr_data (t_ptr_indx)) -> its.its_mod = ITS_MODIFIER then
		     definitions_info.t_ptrs (t_ptr_indx).val = ptr_data (t_ptr_indx);
		else call ioa_ ("^2w not its ^a not set", ptr_data (t_ptr_indx),
			definitions_info.t_ptrs (t_ptr_indx).name);
	     end;
	     end;
	else do;
	     call set_t_idx;
	     if t_ptr_indx = 8 then do;
		if addr (ptr_data (6)) -> its.its_mod = ITS_MODIFIER then
		     definitions_info.t_ptrs (t_ptr_indx).val = ptr_data (6);
						/* special case prfr */
		else call ioa_ ("^2w not its ^a not set", ptr_data (6), definitions_info.t_ptrs (t_ptr_indx).name);
		return;
		end;
	     if t_ptr_indx = 9 then do;
		call ioa_ ("prmc can not be set from");
		return;
		end;
	     if addr (ptr_data (t_ptr_indx)) -> its.its_mod = ITS_MODIFIER then
		definitions_info.t_ptrs (t_ptr_indx).val = ptr_data (t_ptr_indx);
	     else call ioa_ ("^2w not its ^a not set", ptr_data (t_ptr_indx), definitions_info.t_ptrs (t_ptr_indx).name)
		     ;
	     end;
	return;


%page;
set_t_idx:
     proc;
	code = 0;
	if prn_name = "frame" | prn_name = "fr" then do;
	     t_ptr_indx = 8;
	     return;
	     end;

	if prn_name = "mcp" then do;
	     t_ptr_indx = 9;
	     return;
	     end;


	if substr (prn_name, 1, 2) = "pr" then do;
	     t_ptr_indx = cv_oct_check_ (substr (prn_name, 3, 1), code);
	     if code ^= 0 then do;
		if prn_name = "prfr" then do;
		     t_ptr_indx = 8;
		     code = 0;
		     return;
		     end;
		if prn_name = "prmc" then do;
		     t_ptr_indx = 9;
		     code = 0;
		     return;
		     end;
		P_code = code;
		return;
		end;
	     end;
	else do;
	     code = 0;
	     do t_ptr_indx = 0 to 9;
		if prn_name = definitions_info.t_ptrs (t_ptr_indx).name then return;
	     end;
	     end;
	if t_ptr_indx > 9 then do;
	     code = error_table_$bad_arg;
	     return;
	     end;
     end set_t_idx;

cr_def_name:
     proc;
	def_name = rtrim (P_seg_name);		/* construct lookup name */
	def_name = def_name || "$";
	def_name = def_name || rtrim (P_entrypoint_name);
	temp_def_name = def_name;
     end cr_def_name;

find_def:
     proc;
	seg_ptr = null ();				/* indicate that this should be an output argument */
	hardcore_cur_ptr = addr (cur_ptrs);
	call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr);
	call ring0_get_$definition_given_slt (seg_ptr, P_seg_name, P_entrypoint_name, def_offset, d_type, code,
	     hardcore_cur.sltp, hardcore_cur.sltntp, hardcore_cur.defp);
     end find_def;

lookup:
     proc (P_name);

/* *	This procedure looks up P_name in the internal name hash table, and sets
   *	hash_index, name_entry_ptr, and last_name_entry_ptr appropriately. It will
   *	always set hash_index correctly. If P_name is found, name_entry_ptr points
   *	to the name_entry block for it, and last_name_entry_ptr will be invalid.
   *	If P_name is not found, name_entry_ptr will be null, and last_name_entry_ptr
   *	will either point to the last name_entry block in the chain, or be null if
   *	the chain is empty. */

dcl  P_name char (*) parameter;

dcl  hash_sum fixed bin;
dcl  idx fixed bin;

	hash_sum = 43;				/* This is just to start it somewhere other than zero */
						/* The choice of 43 is completely arbitrary */
	do idx = 1 to length (rtrim (P_name));
	     hash_sum = hash_sum + rank (substr (P_name, idx, 1));
	end;

	hash_index = 1 + mod (hash_sum, dimension (hash_buckets, 1));

	last_name_entry_ptr = null ();
	do name_entry_ptr = hash_buckets (hash_index) repeat (name_entry_ptr -> name_entry.next)
	     while (name_entry_ptr ^= null ());

	     last_name_entry_ptr = name_entry_ptr;

	     if name_entry.name = P_name then return;	/* jackpot */
	end;					/* of loop through name_entry blocks */

	return;					/* all done. the pointers are set appropriately by the loop */
     end lookup;

%page;

insert:
     proc (P_name, P_ptr);

/* *	This procedure adds another name_entry block to the appropriate chain for
   *	the association of P_name and P_ptr. It assumes that hash_index and
   *	last_name_entry_ptr have already been set properly (presumably by lookup). */

dcl  (
     P_name char (*),
     P_ptr pointer
     ) parameter;


	name_entry_lth = length (rtrim (P_name));

	allocate name_entry in (amu_area) set (name_entry_ptr);

	name_entry.next = null ();			/* initialize values */
	name_entry.seg_ptr = P_ptr;
	name_entry.name_lth = name_entry_lth;
	name_entry.name = P_name;

	if last_name_entry_ptr ^= null () then		/* and string in -- after last one, if there was such; */
	     last_name_entry_ptr -> name_entry.next = name_entry_ptr;
	else hash_buckets (hash_index) = name_entry_ptr;

	return;					/* all done */
     end insert;

%page;
%include sdw;
%page;
%include amu_info;
%page;
%include amu_definitions;
%page;
%include amu_hardcore_info;
%page;
%include its;
     end amu_definition_;				/* External procedure */




		    amu_do_translation_.pl1         07/28/87  0939.7r w 07/28/87  0927.5       80991



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_do_translation_:
     proc (P_amu_info_ptr, P_segno, P_buf_ptr, P_offset, P_range, P_code);

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

dcl  P_amu_info_ptr ptr;
dcl  P_segno fixed bin;
dcl  P_offset fixed bin (18);
dcl  P_range fixed bin (18);
dcl  P_buf_ptr ptr;
dcl  P_code fixed bin (35);
dcl  P_seg_ptr ptr;
dcl  P_ret_ptr ptr;


dcl  error_table_$out_of_bounds fixed bin (35) ext;

dcl  old_proc_idx fixed bin;
dcl  segno fixed bin;
dcl  seg_base_ptr ptr;
dcl  offset fixed bin (18);
dcl  range fixed bin (18);
dcl  buf_ptr ptr;
dcl  dump_data_ptr ptr;
dcl  buf_size fixed bin (24);
dcl  buf char (buf_size) based (buf_ptr);
dcl  code fixed bin (35);
dcl  (range_1, range_2) fixed bin;
dcl  total_length fixed bin (24);
dcl  (hunt_entry, by_ptr_entry, ptr_entry) bit (1);
dcl  temp_ptr ptr;
dcl  bit_count fixed bin (24);
dcl  1 trans_space like translation;

dcl  amu_$dp_expand_to_ptr entry (ptr, fixed bin, ptr, fixed bin (24));
dcl  amu_$translate_get entry (ptr, fixed bin, ptr, fixed bin (35));
dcl  amu_$translate_add entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  amu_$fdump_translate_get_translation entry (ptr, ptr, ptr, fixed bin (35));
dcl  amu_$fdump_mpt_change_idx entry (ptr, fixed bin);
dcl  amu_$return_val_per_process entry (ptr, fixed bin) returns (bit (1));
dcl  amu_$get_name_ptr_count entry (ptr, ptr, ptr, fixed bin (24));

dcl  (addr, addrel, baseno, baseptr, 
      divide, fixed, null, rel)	builtin;

dcl  (
     error_table_$seg_not_found,
     amu_et_$invalid_segno,
     amu_et_$no_translation
     ) fixed bin (35) ext;

%page;

	by_ptr_entry = "0"b;
	hunt_entry = "0"b;
	ptr_entry = "0"b;
	goto common_do;

amu_do_translation_$hunt:
     entry (P_amu_info_ptr, P_segno, P_buf_ptr, P_offset, P_range, P_code);

	hunt_entry = "1"b;
	ptr_entry = "0"b;
	by_ptr_entry = "0"b;
	goto common_do;

amu_do_translation_$hunt_ptr:
     entry (P_amu_info_ptr, P_seg_ptr, P_ret_ptr, P_code);
	hunt_entry = "1"b;
	ptr_entry = "1"b;
	by_ptr_entry = "1"b;
	goto common_do;

amu_do_translation_$ptr_given_segno:
     entry (P_amu_info_ptr, P_segno, P_ret_ptr, P_code);

/* Given a segno, returns the ptr of the segment. */

	hunt_entry = "1"b;
	ptr_entry = "1"b;
	by_ptr_entry = "0"b;
	amu_info_ptr = P_amu_info_ptr;
	P_code = 0;
	if P_segno >= 4096 then do;
	   P_code = amu_et_$invalid_segno;
	   return;
	   end;
          offset, range = 0;
	segno = P_segno;
	P_ret_ptr, buf_ptr = null();
	goto GET_IT;

amu_do_translation_$by_ptr:
     entry (P_amu_info_ptr, P_seg_ptr, P_range, P_buf_ptr, P_code);
	hunt_entry = "0"b;
	ptr_entry = "0"b;
	by_ptr_entry = "1"b;
	goto common_do;


common_do:
	amu_info_ptr = P_amu_info_ptr;
	P_code = 0;
	if ^by_ptr_entry then do;
	     if P_segno >= 4096 then do;
		P_code = amu_et_$invalid_segno;
		return;
	     end;
	end;
	else do;
	     if fixed(baseno(P_seg_ptr),17) >= 4096 then do;
		P_code = amu_et_$invalid_segno;
		return;
	     end;
	end;

	if ^ptr_entry then do;
	     range = P_range;
	     buf_ptr = P_buf_ptr;
	     if ^by_ptr_entry then do;
		segno = P_segno;
		offset = P_offset;
		end;
	     else do;
		segno = fixed (baseno (P_seg_ptr), 17);
		offset = fixed (rel (P_seg_ptr), 18);
		end;
	     end;
	else do;
	     range = 0;
	     segno = fixed (baseno (P_seg_ptr), 17);
	     offset = fixed (rel (P_seg_ptr), 18);
	     buf_ptr = null;
	     end;


GET_IT:	
	translation_ptr = addr (trans_space);
	old_proc_idx = -1;
	if ^amu_$return_val_per_process (amu_info_ptr, segno) then do;
	     old_proc_idx = amu_info.process_idx;
	     if amu_info.type ^= SAVED_PROC_TYPE then call amu_$fdump_mpt_change_idx (amu_info_ptr, 0);
	     end;

	call amu_$translate_get (amu_info_ptr, segno, translation_ptr, code);
	if code ^= 0 then do;
	     if code = amu_et_$no_translation then do;
		translation_ptr = addr (trans_space);
		seg_base_ptr = baseptr (segno);
		if amu_info.type = FDUMP_TYPE | amu_info.type = FDUMP_PROCESS_TYPE then do;
		     call amu_$fdump_translate_get_translation (amu_info_ptr, seg_base_ptr, translation_ptr, code);

		     if code ^= 0 then do;
			if hunt_entry then do;
			     call hunt_for_seg;
			     if code = 0 then goto add_trans;
			     end;

			if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
			P_code = code;
			return;
			end;
		     end;

		if amu_info.type = SAVED_PROC_TYPE then do;
		     if hunt_entry then do;
			call hunt_for_seg;
			if code = 0 then goto add_trans;
			end;
		     P_code = code;
		     return;
		     end;


		end;
add_trans:
	     call amu_$translate_add (amu_info_ptr, translation_ptr, segno, code);
	     if code = 0 then
		goto start_do;
	     else do;
		if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
		P_code = code;
		return;
		end;
	     end;

start_do:
	if ^translation.two_part | translation.in_temp_seg then do;
	     if offset > translation.part1.lth then do;
		if ^ptr_entry then
		     P_range = 0;
		else P_ret_ptr = null ();
		P_code = error_table_$out_of_bounds;
		if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
		return;
		end;
	     if ptr_entry then do;
		P_ret_ptr = addrel (translation.part1.ptr, offset);
		P_code = 0;
		if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
		return;
		end;


	     if offset = translation.part1.lth then range = 1;
	     else if (offset + range) > translation.part1.lth then range = translation.part1.lth - offset;
	     buf_size = 4 * range;
	     dump_data_ptr = addrel (translation.part1.ptr, offset);
	     buf = dump_data_ptr -> buf;
	     P_code = 0;
	     if ^ptr_entry then P_range = range;
	     if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
	     return;
	     end;
	else do;
	     total_length = (translation.part1.lth + translation.part2.lth);
	     if offset > total_length then do;
		if ^ptr_entry then
		     P_range = 0;
		else P_ret_ptr = null ();
		P_code = error_table_$out_of_bounds;
		if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
		return;
		end;
	     if ptr_entry then do;
		if offset > translation.part1.lth then
		     P_ret_ptr = addrel (translation.part2.ptr, (offset - translation.part1.lth));
		else P_ret_ptr = addrel (translation.part1.ptr, offset);
		if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
		P_code = 0;
		return;
		end;


	     if offset = total_length then range = 1;
	     else if (offset + range) > total_length then range = total_length - offset;
	     if offset <= translation.part1.lth then do;
		if (offset + range) <= translation.part1.lth then do;
		     buf_size = 4 * range;
		     dump_data_ptr = addrel (translation.part1.ptr, offset);
		     buf = dump_data_ptr -> buf;
		     P_code = 0;
		     P_range = range;
		     if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
		     return;
		     end;
		else do;
		     range_1 = translation.part1.lth - offset;
		     range_2 = range - range_1;
		     buf_size = range_1 * 4;
		     dump_data_ptr = addrel (translation.part1.ptr, offset);
		     buf = dump_data_ptr -> buf;
		     buf_size = range_2 * 4;
		     buf_ptr = addrel (buf_ptr, range_1);
		     dump_data_ptr = translation.part2.ptr;
		     buf = dump_data_ptr -> buf;
		     P_code = 0;
		     P_range = range;
		     if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
		     return;
		     end;
		end;
	     else do;
		offset = offset - translation.part1.lth;
		buf_size = range * 4;
		buf = addrel (translation.part2.ptr, offset) -> buf;
		P_code = 0;
		P_range = range;
		if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
		return;
		end;
	     end;
	if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);

hunt_for_seg:
     proc;

	code = 0;
	translation_ptr = addr (trans_space);
	translation.segno = segno;
	translation.flags = ""b;
	translation.part2.ptr = null ();
	translation.part2.lth = 0;
	if amu_info.type = FDUMP_PROCESS_TYPE then
	     call amu_$get_name_ptr_count (amu_info_ptr, baseptr (segno), temp_ptr, bit_count);
	else call amu_$dp_expand_to_ptr (amu_info_ptr, (segno), temp_ptr, bit_count);
	if temp_ptr = null () then do;
	     code = error_table_$seg_not_found;
	     return;
	     end;
	translation.part1.ptr = temp_ptr;
	translation.part1.lth = divide (bit_count, 36, 19);
	translation.flags.in_perm_seg = "1"b;
	return;
     end hunt_for_seg;
%page;
%include amu_translation;
%page;
%include amu_info;


     end amu_do_translation_;








		    amu_error_.pl1                  11/19/84  1144.9rew 11/15/84  1445.4       57717



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_error_: proc ();

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* *	This procedure is used to print "internal" error messages for amu_, and
   *	signal amu_error to indicate that an error has occurred, in case there is
   *	some procedure which wishes to handle it.
   *
   *	Cribbed from ssu_error_, 08/25/80 W. Olin Sibert */

dcl  arg_count fixed bin;
dcl  args_needed fixed bin;
dcl  entry fixed bin;
dcl  arg_list_ptr pointer;

dcl  error_code fixed bin (35);
dcl  caller_name char (72) varying;
dcl  aligned_error_message char (100) aligned;
dcl  error_message char (100) varying;
dcl  user_message_buffer char (1500);
dcl  user_message_lth fixed bin (21);
dcl  user_message char (user_message_lth) based (addr (user_message_buffer));

dcl  1 auto_error_info aligned like amu_error_info automatic;
dcl  1 cond_info aligned like condition_info;

dcl  iox_$error_output pointer external static;

dcl  arg_assign_$from_arg entry options (variable);
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_list_ptr entry (pointer);
dcl  cu_$cl entry (bit (1) aligned);
dcl  cu_$caller_ptr entry (pointer);
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned);
dcl  ioa_$ioa_switch entry options (variable);
dcl  signal_ entry options (variable);
dcl  sub_err_ entry options (variable);
dcl  (
     ERROR init (1),
     ERROR_WITH_INFO init (2),
     FOR_CALLER init (3)
     ) fixed bin internal static options (constant);

dcl  (addr, length, null, rtrim, size, string, unspec) builtin;

%page;
/* amu_error_: procedure options (variable);		primary entry -- no info structure */
	entry = ERROR;
	args_needed = 2;
	goto COMMON;


amu_error_$info:					/* entry which also includes an info_ptr */
     entry options (variable);

	entry = ERROR_WITH_INFO;
	args_needed = 3;				/* call amu_error_$info (aip, info_ptr, code, [optional args]) */
	goto COMMON;


amu_error_$for_caller:				/* Entry for com_err_ like messages with a caller-name */
     entry options (variable);

	entry = FOR_CALLER;
	args_needed = 3;
	goto COMMON;


COMMON:
	call cu_$arg_count (arg_count);
	if arg_count < args_needed then do;
INVALID_ERROR_CALL:
	     call sub_err_ (0, "amu_error_", "s", (null ()), 0,
		"Invalid argument list argument missing or type mismatch. ^d arguments needed.", args_needed);
	     end;

	call cu_$arg_list_ptr (arg_list_ptr);

	call arg_assign_$from_arg (arg_list_ptr, 1, amu_info_ptr);
						/* first two arguments are always amu_info_ptr, code */
	call arg_assign_$from_arg (arg_list_ptr, 2, error_code);

	if entry = FOR_CALLER then
	     call arg_assign_$from_arg (arg_list_ptr, 3, caller_name);
	else caller_name = "";
	caller_name = rtrim (caller_name);		/* because assign_$computational_ is too lazy to do it */

	if entry = ERROR_WITH_INFO then
	     call arg_assign_$from_arg (arg_list_ptr, 3, amu_error_info_ptr);
	else amu_error_info_ptr = null ();

	if error_code ^= 0 then do;			/* get the error message */
	     call convert_status_code_ (error_code, (""), aligned_error_message);
	     error_message = rtrim (aligned_error_message);
	     error_message = error_message || " ";
	     end;
	else error_message = "";

	if arg_count > args_needed then		/* pick up optional ioa_ arguments */
	     call ioa_$general_rs (arg_list_ptr, (args_needed + 1), (args_needed + 2), user_message_buffer,
		user_message_lth, ("1"b), ("0"b));

	else user_message_lth = 0;			/* otherwise, no user message */

	if (length (user_message) = 0) & (length (error_message) = 0) then error_message = "Error occurred.";

	if length (caller_name) = 0 then
	     caller_name = "amu_: ";
	else caller_name = caller_name || ": ";

	if amu_error_info_ptr = null () then do;	/* use our automatic copy */
	     amu_error_info_ptr = addr (auto_error_info);
	     unspec (amu_error_info) = ""b;
	     amu_error_info.mc_ptr = null ();
	     end;

	amu_error_info.length = size (amu_error_info);	/* fill in the standard header */
	amu_error_info.version = 1;
	string (amu_error_info.action_flags) = ""b;
	amu_error_info.action_flags.default_restart = "1"b;
						/* restart this by default */
	amu_error_info.status_code = error_code;
	amu_error_info.info_string = caller_name;
	amu_error_info.info_string = amu_error_info.info_string || error_message;
	amu_error_info.info_string = amu_error_info.info_string || user_message;

	amu_error_info.aip = amu_info_ptr;		/* now, fill in some variables */
	call cu_$caller_ptr (amu_error_info.caller_ptr);

	if amu_info_ptr = null () then /* don't signal if nothing there, either */ goto PRINT_MESSAGE;

	if ^amu_info.handler_exists then /* don't bother signalling, since there's nobody there */ goto PRINT_MESSAGE;

	unspec (cond_info) = ""b;
	cond_info.version = 1;			/* fill in everything not copied from the error_info */
	cond_info.condition_name = AMU_ERROR_NAME;
	cond_info.info_ptr = amu_error_info_ptr;
	cond_info.wc_ptr = null ();

	cond_info.mc_ptr = amu_error_info.mc_ptr;
	cond_info.loc_ptr = amu_error_info.caller_ptr;
	cond_info.user_loc_ptr = amu_error_info.caller_ptr;

RESIGNAL_ERROR:
	call signal_ (AMU_ERROR_NAME, amu_error_info.mc_ptr, addr (cond_info), null ());

	if amu_error_info.must_restart then return;

	if amu_error_info.cant_restart then goto RESIGNAL_ERROR;

PRINT_MESSAGE:
	if ^amu_error_info.dont_print_message then	/* default case, where handler did nothing */
	     call ioa_$ioa_switch (iox_$error_output, "^a", amu_error_info.info_string);

	if entry = FOR_CALLER then /* these messages are always nonfatal */ return;

	if ^amu_error_info.amu_handled then do;		/* if not set, wasn't fixed up by amu_ */
	     call ioa_$ioa_switch (iox_$error_output, "amu_error_: Returning to command level.");
	     call cu_$cl ("0"b);
	     end;

	return;					/* all done */

%page;
%include amu_info;
%page;
%include amu_error_info;
%page;
/* %include std_descriptor_types;*/
%page;
%include condition_info;

     end amu_error_;				/* external procedure */




		    amu_et_.alm                     11/05/86  1351.4r w 11/04/86  1039.3       37863



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"	Modified 20 Jan 85 by BLB to add error codes used by amu_deadproc_.

	include et_macros
	et	amu_et_
	ec	apte_not_found,anf,(Process with apte offset not found in fdump.)
	ec	bad_bit_off,bbo,(Pointer has bit offset and should not.)
	ec	bad_segno,bad_seg,(Segment number is not in the correct range.)
	ec	bad_thread_ptr,btp,(A stack thread, next or prev, is in error.)
	ec	big_idx,big_idx,(Process_idx is larger than number of processes in fdump.)
	ec	dbr_not_found,dnf,(Process with dbr specified not found in fdump.)
	ec	end_of_seg_in_dump,eosid,(Reference beyond end of segment in dump.)
	ec	entry_not_found,enf,(Entry not found.)
	ec	erf_trans_exists,et_exsts,(ERF is already translated.)
	ec	error_indirect,err_ind,(Indirection must be part of the virtual address.)
	ec	free_core,fcore,(Page is in free core.)
	ec	invalid_dump,invd,(Selected ERF is invalid.)
	ec	invalid_operator,invo,(Operator for general address is invalid.)
	ec	invalid_segno,invalseg,(Segment number is invalid.)
	ec	invalid_seq,invseq,(Virtual address argument list is in error.)
	ec	looping_problem,lp,(Could be in a loop or deadly embrace.)
	ec	make_uid_hash,uidhash,(Trying to create the segment uid_hash_table.)
	ec	neg_range,nr,(Resulting range is negative.)
	ec	negative_offset,neg_offs,(Resulting offset is negative.)
	ec	no_amu_ptr,namup,(Unable to create an amu_ translation.)
	ec	no_kst,nokst,(Unable to initiate the kst segment in the pdir.)
	ec	no_uid_hash,nohash,(Unable to initiate the uid_hash_table segment in the pdir.)
	ec	no_va_specified,nvasp,(No valid virtual address found on request line.)
          ec	no_segname,noseg,(Segment specified by name is not found in the dump.)
	ec	no_sl1_uid,nosl1uid,(Unable to get the status of '>sl1' to obtain the UID.)
          ec	no_sl1_in_kst,nosl1,(No uid found for 'sl1' in the kst. Probable cause: Process is from a previous boot of the system.)
          ec        no_def,nodef,(No definitions_ segment found in the dead process directory.)
	ec	no_slt,noslt,(No slt segment found in the dead process directory.)
	ec	no_dseg,nodseg,(No dseg segment found in the dead process directory.)
	ec	no_sltnt,nont,(No name_table segment found in the dead process directory.)
	ec	no_translation,no_trans,(Segment is not in the given translation table.)	
	ec	no_valid_stacks,no_val_s,(There are no valid frames.)
	ec	non_existant_mem,nem,(Invalid or Non-existent memory address.)
	ec	non_its,nits,(Pointer is not an ITS pair.)
	ec	not_fdump,nofdump,(Current amu_info is not an fdump type.)
	ec	not_implemented,not_yet,(Function is not yet implemented.)
	ec	not_stack_seg,nsn,(Segment does not appear to be a stack seg.)
	ec	not_octal_range,nor,(The specified range must be an octal number.)
	ec	not_octal_off_mod,nofm,(The offset modifier must be an octal number.)
	ec	not_octal_offset,nof,(The offset specified must be octal.)
	ec	not_octal_segno,nos,(The segment number must be octal.)
	ec	not_octal,noct,(Not octal number.)
	ec	not_its_ptr,no_its,(The indirection specified must be an ITS pair.)
	ec	npdx_dbr,npdx_dbr,(Could not set process index.)
	ec	null_sstp,no_sst,(Could not get pointer to SST.)
	ec	null_sstnt,nosstnt,(Cannot get pointer to the SST name table.)
	ec	null_sltp,noslt,(Could not get pointer to the slt.)
	ec	null_sltnt,nosltnt,(Cannot get pointer to the slt name segment.)
	ec	null_ptr,nptr,(The pointer specified is null.)
	ec	proc_not_dumped,p_no_d,(Process was not dumped.)
	ec	range_too_small,rts,(Range too small.)
	ec	stop_trans,s_trans,(Unable to continue translation.)
	ec	trans_exists,tr_exsts,(Segment translation already exists.)
	ec	two_level_indirect,tli,(Operand has two levels of indirection.)
	ec 	seg_not_dumped,segnot_d,(Segment is not in the fdump.)
	ec 	specified_modifier,spmod,(The offset modifier is specified more than once.)
	ec	modifier_before_range,mbr,(An offset modifier must be specified before a range.)

	end




		    amu_fdump_mgr_.pl1              07/12/88  1444.6rew 07/12/88  1432.2      172836



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-01-19,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-17,Fawcett), install(87-07-28,MR12.1-1049):
     Corrected the ioa_ control string on line 149 to correctly format error
     msg. (phx20262).
  2) change(87-09-03,Parisek), approve(88-03-09,MCR7861),
     audit(88-07-08,Farley), install(88-07-12,MR12.2-1055):
     Check for inconsistent dump segment components and print the
     inconsistencies if found.
                                                   END HISTORY COMMENTS */


amu_fdump_mgr_: procedure options (separate_static);


	return;					/* not an entrypoint */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* This procedure is in charge of initiating and terminating segments which
   make up FDUMP images. It also manages a chain of previously initiated FDUMPs,
   in order to make the whole process more efficient. It is not, however, in any
   way associated with address translation; that is the province of
   amu_fdump_translate_.

   09/06/80 -- WOS, from earlier version by CAH
   07/30/81 -- RAF, to add search dir
   08/18/81 -- RAF, to call amu_$hardcore_fdump
   06/30/82 -- RAF, to add find_fdump
   08/31/84 -- BLB, to modify find_fdump and init_fdump to use system_dump_info structure.
   11/08/84 -- BLB, to ignore non-entries when initializing best_bet values.
*/						/* 

/* Parameters */

dcl  (
     P_amu_info_ptr pointer,
     P_caller char (*),
     P_code fixed bin (35),
     P_dirname char (*),
     P_dump_info_ptr ptr,
     P_dump_name char (*),
     P_new fixed bin
     ) parameter;

/* Automatic */

dcl  1 best_bet,
       2 ftime fixed bin (71),
       2 list_idx fixed bin;
dcl  bc fixed bin (24);
dcl  1 branch aligned like status_branch automatic;
dcl  code fixed bin (35);
dcl  cur_dump_time fixed bin (71);
dcl  cur_state char (1);
dcl  dirname char (168);
dcl  ename char (32);
dcl  ename_prefix varying char (32);
dcl  ename_suffix varying char (32);
dcl  1 fdi aligned like fdump_info automatic;
dcl  first_seg_ename char (32);
dcl  found bit(1);
dcl  idx fixed bin;
dcl  ignore_code fixed bin (35);
dcl  ignore_bc fixed bin (24);
dcl  path_idx fixed bin;
dcl  rs_length fixed bin;
dcl  starname char (32);
dcl  system_area_ptr ptr;
dcl  ttime fixed bin(71);

/* Based */

dcl  system_area area based (system_area_ptr);

/* Entry and External  */

dcl  amu_$error_for_caller entry options (variable);
dcl  amu_$list_system_dumps	entry (character (*), character (8) aligned, fixed bin, pointer, pointer, 
			fixed binary (35));
dcl  amu_et_$invalid_dump fixed bin (35) external static;
dcl  amu_$fdump_mpt entry (pointer, char(*), fixed bin (35));
dcl  amu_$fdump_mpt_current_process entry (ptr);
dcl  amu_$fdump_mpt_terminate entry (ptr);
dcl  amu_$create_translation entry (pointer, fixed bin);
dcl  amu_$search_path_get_dump entry (ptr, fixed bin (35));
dcl  amu_$temp_seg_release_all entry (pointer);
dcl  error_table_$nomatch fixed bin (35) external static;
dcl  error_table_$noentry fixed bin (35) external static;
dcl  error_table_$translation_failed fixed bin (35) external static;
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), pointer, fixed bin, pointer, pointer, fixed bin (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), pointer, pointer, fixed bin (35));
dcl  initiate_file_		entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$rsnnl		entry() options(variable);
dcl pathname_			entry (char(*), char(*)) returns(char(168));
dcl terminate_file_		entry (ptr, fixed bin(24), bit(*), fixed bin(35));

dcl  cleanup condition;

dcl  (addr, after, divide, hbound, lbound,
      max, reverse, rtrim, sum,
      null, unspec)			builtin;

dcl  zero_bc fixed bin (24) int static options (constant) init (0);

%page;

ERROR_RETURN:					/* general error exit */
	P_code = code;
	return;


/*****************************************************************************/

amu_fdump_mgr_$cur_erf:
     entry (P_amu_info_ptr);

	amu_info_ptr = P_amu_info_ptr;
	cur_state = ">";
	call what_erf ("0"b);
	return;
%page;
/*****************************************************************************/

amu_fdump_mgr_$find_fdump:
     entry (P_caller, P_amu_info_ptr, P_dump_name, P_new, P_dump_info_ptr, P_code);

/* This entry finds the fdump specified by P_new; 

   P_caller		who called me (input),
   P_amu_info_ptr		amu_info pointer (input),
			This can be null() if there is no current fdump.
   P_dump_name		absolute pathname of the current fdump, if there 
			is one (input),
   P_new			number specifying the action to be taken to find 
			the fdump (input)
   P_dump_info_ptr		pointer to system_dump_info structure (input). 
			The structure is filled in with the dump found (output)
   P_code			standard error code (output).
*/

    P_code, code = 0;
    amu_info_ptr = P_amu_info_ptr;
    system_dump_info_ptr = P_dump_info_ptr;
    system_area_ptr = get_system_free_area_();
    system_dump_list_ptr = null();

    ename, dirname,
    system_dump_info.dump_dir_name, system_dump_info.dump_seg_prefix, 
        system_dump_info.dump_name, system_dump_info.dump_entry_format = "";

    on cleanup begin;
       if system_dump_list_ptr ^= null() then free system_dump_list in (system_area);
       end;
    
    call amu_$list_system_dumps ("*", SYSTEM_DUMP_LIST_VERSION_1, LIST_FDUMPS, system_area_ptr, system_dump_list_ptr, code);
    if code ^= 0 then do;
       call amu_$error_for_caller ((null ()), code, P_caller,
           "Selecting the ^[first^;^[last^;^[previous^;^[next^]^]^]^] fdump.", P_new=0, P_new=1, P_new=2, P_new=3);
       goto ERROR_RETURN;
       end;

    ttime = -1;					/* We loop to skip non-existant entries 	*/
    do idx = 1 to system_dump_list.n_dumps while (ttime = -1);
       call get_fdump_time (system_dump_list.per_dump(idx).dir_name, system_dump_list.per_dump(idx).full_entryname, ttime);
       best_bet.ftime = ttime;
       best_bet.list_idx = idx;
       end;

    if P_new >= 2 then do;   /* next */
       call expand_pathname_(P_dump_name, dirname, ename,code);
       if code ^= 0 then do;
          call amu_$error_for_caller (null(), code, P_caller, "Could not expand fdump name ^a", P_dump_name);
	goto ERROR_RETURN;
          end;
       call get_fdump_time (dirname, ename, ttime);
       cur_dump_time = fdump_info.dump_seg_ptr (0) -> dump.dump_header.time;
       best_bet.ftime = 10**15;  /* larger that 52 bit clock */
       end;

    do idx = 1 to system_dump_list.n_dumps;
       found = "0"b;
       call find_erf (system_dump_list.dir_name(idx), system_dump_list.full_entryname(idx), P_new, best_bet.ftime, 
		 cur_dump_time, found);
       if found then best_bet.list_idx = idx;
       end;

    if P_dump_name = pathname_ (system_dump_list.dir_name (best_bet.list_idx), 
		            system_dump_list.full_entryname (best_bet.list_idx)) then do;
						/* Nothing was found			*/
       /* this should only happen if next or previous specified */
       code = error_table_$noentry;
       call amu_$error_for_caller (null(), 0, P_caller, 
           "There is no ^[previous^;next^] fdump. The current fdump ^[^a^;^s^] is the ^[first^;last^] one.",
	 P_new=2,  P_dump_name^="", P_dump_name, P_new=2);
       goto ERROR_RETURN;
       end;

    else do;  /* fill in structure and return */
       system_dump_info.dump_dir_name = system_dump_list.dir_name (best_bet.list_idx);
       system_dump_info.dump_seg_prefix = 
          reverse (after (after (reverse (system_dump_list.full_entryname (best_bet.list_idx)), "."), "."));
       system_dump_info.dump_name = system_dump_list.minimal_entryname (best_bet.list_idx);
       call ioa_$rsnnl ("^a.^^d.^a", system_dump_info.dump_entry_format, rs_length, 
            system_dump_info.dump_seg_prefix, system_dump_info.dump_name);
       end;
  
    if system_dump_list_ptr ^= null() then free system_dump_list in (system_area);
    P_code = code;
    return;
%page;
/*****************************************************************************/

amu_fdump_mgr_$init_fdump:
     entry (P_caller, P_dump_info_ptr, P_amu_info_ptr, P_code);

/* This entry initializes a translation for a given fdump.

   P_caller                 who called me (input)
   P_dump_info_ptr   ptr to system_dump_info structure which contains the fdump info (input)
   P_amu_info_ptr	        pointer to amu_info (output)
   P_code		        standard error code (output)
*/

dcl bif bit (1);
dcl bidx fixed bin;
dcl bstring char (64);

	P_code = 0;
	amu_info_ptr = P_amu_info_ptr;
	system_dump_info_ptr = P_dump_info_ptr;
          dirname = system_dump_info.dump_dir_name;
						/* get the primary name */
          call ioa_$rsnnl (system_dump_info.dump_entry_format, ename, rs_length, 0);
	call hcs_$status_long (dirname, ename, 1, addr (branch), (null ()), code);
	if code ^= 0 then do;			/* This code wil malfunction if a dump is renamed */
	   call amu_$error_for_caller ((null ()), code, P_caller, "^a^[>^]^a", dirname, (dirname ^= ">"), ename);
	     goto ERROR_RETURN;
	     end;

	first_seg_ename = ename;

	ename_prefix = system_dump_info.dump_seg_prefix;
	ename_suffix = system_dump_info.dump_name;

	fdi.dump_seg_ptr (*) = null ();
	fdi.dump_seg_lth (*) = 0;
	bidx = 0;
	bif = "0"b;

	do idx = lbound (fdi.dump_seg_ptr, 1) to hbound (fdi.dump_seg_ptr, 1);
						/* initiate the dump segments */
             call ioa_$rsnnl (system_dump_info.dump_entry_format, ename, rs_length, idx);
	   call initiate_file_ (dirname, ename, R_ACCESS,  fdi.dump_seg_ptr (idx), bc, code);
	   if (fdi.dump_seg_ptr (idx) = null ()) then
	      if code = error_table_$noentry then do;
	         if idx ^= 0 then do;
		    if bidx > 0 then do;
		         idx = idx-1;
		         goto GOT_ALL_DUMP_SEGMENTS;
		    end;
		    bidx = idx;
		    goto next_idx;
	         end;
	         else do;
	            call amu_$error_for_caller (null(), code, P_caller, "FDUMP ^a.", pathname_(dirname, ename));
		  goto ERROR_RETURN;
		  end;
	         end;
	   else do;				/* some error initiating the segment */
	      call amu_$error_for_caller (amu_info_ptr, code, P_caller, "^a^[>^]^a", dirname, (dirname ^= ">"),
		 ename);
	      goto ERROR_RETURN;
	   end;
 	   fdi.dump_seg_lth (idx) = divide (bc, 36, 19, 0);
	   if bidx > 0 then do;
	        bif = "1"b;
	        code = error_table_$translation_failed;
	        call ioa_$rsnnl (rtrim(system_dump_info.dump_entry_format) || " dump segment missing.", bstring, (0), bidx);
	        call amu_$error_for_caller (amu_info_ptr, code, P_caller, bstring);
	        goto ERROR_RETURN;
	   end;
next_idx:	   
	   end;					/* of loop finding segments */

GOT_ALL_DUMP_SEGMENTS:

	code = 0;
          dumpptr = fdi.dump_seg_ptr (0);
	if (unspec (dump.dump_header.valid)) ^= "1"b then do;
						/* Is this a valid dump ?? */
	   code, P_code = amu_et_$invalid_dump;
	   call amu_$error_for_caller (amu_info_ptr, code, P_caller, "ERF ^a", ename);
	   return;
	   end;

	if idx < 1 then do;				/* found nothing at all */
	   call amu_$error_for_caller (amu_info_ptr, code, P_caller, "^a^[>^]^a", dirname, (dirname ^= ">"), ename);
	   goto ERROR_RETURN;			/* not that code was still set */
	   end;

	call amu_$create_translation (amu_info_ptr, FDUMP_TYPE); /* get a fresh amu_info */

	allocate fdump_info in (amu_area) set (amu_info.fdump_info_ptr);
						/* make a new fdump_info */
	fdump_info = fdi;				/* copy in what we already have */
	fdump_info.version = AMU_FDUMP_INFO_VERSION_1;
	fdump_info.dump_seg_0_uid = branch.uid;
	fdump_info.dump_dname = dirname;
	fdump_info.dump_ename = first_seg_ename;
	fdump_info.erf_name = system_dump_info.dump_name;	/* strip off the leading period */
	fdump_info.ref_count = 1;
	fdump_info.n_dump_segs = idx;
	fdump_info.copy_block_ptr = null ();
	fdump_info.system_id, fdump_info.version_id = "";
	cur_state = ">";
	amu_info.process_idx = 0;
						/* fill in the process table */
	call amu_$fdump_mpt (amu_info_ptr, P_caller, code); 
	if code ^= 0 then do;			/* msg already printed */
	   goto ERROR_RETURN;
	   end;

	P_amu_info_ptr = amu_info_ptr;		/* return the fruits of our labors */

	return;					/* end of code for this entrypoint */
%page;
/*****************************************************************************/

amu_fdump_mgr_$name_erf:
     entry (P_amu_info_ptr);
	amu_info_ptr = P_amu_info_ptr;
	cur_state = "";
	call what_erf ("1"b);
	return;
%page;
/*****************************************************************************/

amu_fdump_mgr_$really_terminate_fdump:
     entry (P_amu_info_ptr, P_code);

/* This entry is used to "really" terminate an FDUMP, and free any
   temporaries that may have been allocated for it.
*/

	amu_info_ptr = P_amu_info_ptr;
	if amu_info.fdump_info_ptr = null then return;
	call amu_$fdump_mpt_terminate (amu_info_ptr);
	do idx = 1 to fdump_info.n_dump_segs;		/* terminate the dump */
               call terminate_file_(fdump_info.dump_seg_ptr (idx - 1), zero_bc, TERM_FILE_TERM, ignore_code);
	end;

	call amu_$temp_seg_release_all (fdump_info.copy_block_ptr);

	free fdump_info in (amu_area);

	amu_info.fdump_info_ptr = null ();
	return;					/* end of code for this entrypoint */
%page;
/*****************************************************************************/

amu_fdump_mgr_$terminate_fdump:
     entry (P_amu_info_ptr, P_code);

/* This entry is used to "terminate" an FDUMP. All this means, though, is
   that its reference count is decremented. To really terminate it (that is,
   to reuse its temporary segments and segno's), the really_terminate_fdump
   entrypoint must be used.
*/

	amu_info_ptr = P_amu_info_ptr;

	fdump_info.ref_count = max ((fdump_info.ref_count - 1), 0);

	P_code = 0;
	return;					/* There. Simple, wasn't it? */
%page;
/*****************************************************************************/

find_erf:
     proc (dirname, ename, which, best_fdump_time, cur_dump_time, found);

dcl best_fdump_time fixed bin (71);
dcl cur_dump_time  fixed bin (71);
dcl (dirname, ename) char(*);
dcl found bit(1);
dcl which fixed bin;

dcl ttime fixed bin (71);

    found = "0"b;
    ttime = -1;
    call get_fdump_time (dirname, ename, ttime);
    if ttime = -1 then return;    /* couldn't look at this one, so skip */

    goto case(which);
    
case(0):	/* look for oldest, want the first */

    if ttime < best_fdump_time then do;
       found = "1"b;
       best_fdump_time = ttime;
       end;
    return;

case(1): 	/* look for newest, want the last */

    if ttime > best_fdump_time then do;
       found = "1"b;
       best_fdump_time = ttime;
       end;
    return;

case(2):   /* look for next oldest, want previous */

    if ttime < cur_dump_time then do;
       if ttime > best_fdump_time then do;
          found = "1"b;
	best_fdump_time = ttime;
	end;
       end;
    return;

case(3):   /* look for next newest, want next */
    
    if ttime > cur_dump_time then do;
       if (ttime - cur_dump_time) < best_fdump_time then do;
          found = "1"b;
	best_fdump_time = ttime - cur_dump_time;
	end;
       end;
    return;

end find_erf;
%page;
/*****************************************************************************/

get_fdump_time:
     proc (dirname, fdump_name, dtime);

dcl  dirname char(*);
dcl  fdump_name char (*);

dcl  code fixed bin(35);
dcl  dtime fixed bin (71);

    code = 0;
    call initiate_file_ (dirname, fdump_name, R_ACCESS, dumpptr, ignore_bc, code);
    if dumpptr = null() then return;
    dtime = dump.dump_header.time;
    call terminate_file_(dumpptr, zero_bc, TERM_FILE_TERM, ignore_code);

%include access_mode_values;

end get_fdump_time;
%page;
/*****************************************************************************/

amu_fdump_mgr_$list_fdump:
     entry (P_caller, P_dirname, P_amu_info_ptr, P_code);

	P_code, code = 0;
	amu_info_ptr = P_amu_info_ptr;

	if P_dirname = "" then do;
	     call amu_$search_path_get_dump (sl_info_p, code);
	     if code ^= 0 then do;
		call amu_$error_for_caller ((null ()), code, P_caller, "Getting dump search paths.");
		goto ERROR_RETURN;
		end;
	     do path_idx = 1 to sl_info.num_paths;
		dirname = sl_info.paths (path_idx).pathname;
		call list_all_erf;
	     end;
	     return;
	     end;


	else dirname = P_dirname;			/* Use the callers */
	call list_all_erf;
	return;
%page;
/*****************************************************************************/

list_all_erf:
     proc;
	starname = "*.*.0.*";

	star_entry_ptr = null ();
	star_names_ptr = null ();
	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup)
	     begin;
		if star_names_ptr ^= null () then free star_names in (system_area);
		if star_entry_ptr ^= null () then free star_entries in (system_area);
	     end;

	call hcs_$star_ (dirname, starname, star_ALL_ENTRIES, addr (system_area), star_entry_count, star_entry_ptr,
	     star_names_ptr, code);

	if code = error_table_$nomatch then do;
	     call ioa_ ("No  ERF  found in ^a", dirname);
	     return;
	     end;

	else if code ^= 0 then do;
	     call amu_$error_for_caller ((null ()), code, P_caller, "^a^[>^]^a", dirname, (dirname ^= ">"), starname);
	     goto ERROR_RETURN;
	     end;
	call ioa_ ("ERF LIST FOR ^a", dirname);
	do idx = 1 to star_entry_count;
	     call ioa_ ("^-^a", star_names (idx));
	end;

	free star_names in (system_area);
	free star_entries in (system_area);

	revert condition (cleanup);
	return;
     end list_all_erf;
%page;
/*****************************************************************************/

what_erf:
     proc (print_sys_vid);

dcl  date_time_ entry (fixed bin (71), char (*)),
     dump_date char (32),
     print_sys_vid bit (1);

	dumpptr = fdump_info.dump_seg_ptr (0);
	call date_time_ (dump.dump_header.time, dump_date);
	if amu_info.early_dump then
	     call ioa_ ("This is an early dump.^/");
	call ioa_ ("^1a ERF ^3a in directory ^a dumped at ^a.^[^[^/  System-ID ^a^;^s^]^[ Version-ID ^a^;^s^]^]", 
		cur_state, fdump_info.erf_name, fdump_info.dump_dname, dump_date, print_sys_vid, fdump_info.system_id ^= "", 
		fdump_info.system_id, fdump_info.version_id ^= "", fdump_info.version_id);
	if print_sys_vid then call amu_$fdump_mpt_current_process (amu_info_ptr);
	return;
     end what_erf;
%page;%include access_mode_values;
%page;%include amu_fdump_info;
%page;%include amu_info;
%page;%include bos_dump;
%page;%include sl_info;
%page;%include star_structures;
%page;%include status_structures;
%page;%include system_dump_info;
%page;%include terminate_file;

     end amu_fdump_mgr_;




		    amu_fdump_mpt_.pl1              07/28/87  0939.7rew 07/28/87  0924.4      184698



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-07-09,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-17,Fawcett), install(87-07-28,MR12.1-1049):
     Eliminate garbage in displaying process states.
                                                   END HISTORY COMMENTS */


amu_fdump_mpt_: proc (P_amu_info_ptr, P_caller, P_code);

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* This procedure allocates and fills in the process_table for an
   FDUMP. It is heavily dependent on the silly way that BOS (BCE) constructs
   FDUMP images. The name stands for "Make (Manage) Process Table"
   09/06/80 W. Olin Sibert

   Changed by RAF SEPT 81
   Modified  by B. Braun 06/29/83 to add brief_sw parameter to amu_$fdump_mpt_fill_proc_table.

   This proc has 5 entries
   dcl amu_fdump_mpt_ entry (ptr);
   call amu_fdump_mpt_ (amu_info_ptr)
   where
   amu_info_ptr is the pointer to the main info for this erf.


   This entry point will create the fdump_process_table and init the process_info
   for each process in the fdump.

   dcl amu_$fdump_mpt_current_process entry (ptr);
   call amu_$fdump_mpt_current_process (amu_info_ptr);
   where
   amu_info_ptr is the main info pointer for this erf.


   This entry only prints the FDUMP process index and the dbr of the
   current process


   dcl amu_$fdump_mpt_temp_change_idx entry (ptr,fixed bin);
   call amu_$fdump_mpt_temp_change_idx (amu_info_ptr,new_index);
   where
   amu_info_pointer is a pointer to the maun info.
   new_index is the value of the index into fdump_process_table.array
   of the new process.
   This entry will change the amu_info data to reflect the new process. It is
   intended to be only a temp change the old index is stored in
   amu_info.proc_idx_hold to be used by amu_$fdump_mpt_revert_idx.

   dcl amu_$fdump_mpt_revert_idx entry (ptr);
   call amu_$fdump_mpt_revert_idx (amu_info_ptr);
   where
   amu_info_ptr is the same as above.

   This entry point will revert the amu_info data to the process indicated by
   amu_info.proc_idx_hold. This should have been set by the temp_change_idx entry.


*/
dcl  com_err_ entry () options (variable);
dcl  ioa_ entry () options (variable);
dcl  ioa_$rsnnl		entry() options(variable);
dcl  P_amu_info_ptr pointer parameter;
dcl  P_idx fixed bin;
dcl  P_dbr fixed bin (24);
dcl  P_cpu char (1);
dcl  P_caller char(*);
dcl  P_code fixed bin (35);
dcl  brief_sw bit(1);
dcl  t_ptr ptr;
dcl  temp_ptr ptr;
dcl  t_segno fixed bin;
dcl  based_char char (32) based (t_ptr);
dcl  af_str char (af_len) var based (af_ptr);
dcl  ignore  fixed bin (21);
dcl  af_sw bit(1);
dcl  index_changed bit (1) init ("0"b);
dcl  range fixed bin (18);
dcl  data_buf_ptr ptr;
dcl  t_data (8) fixed bin (35);
dcl  t_offset fixed bin (18);
dcl  pid char(36) var;
dcl  code fixed bin (35);
dcl  prev_segno fixed bin;
dcl  af_ptr ptr;
dcl  af_len fixed bin(21);
dcl  segx fixed bin;
dcl  process_idx fixed bin;
dcl  n_processes fixed bin;
dcl  segment_ptr ptr;
dcl  based_dbr bit (24) based;
dcl  total_offset fixed bin (71);
dcl  search_dbr fixed bin (24);
dcl  cpu_name char (1);
dcl  cpu_no fixed bin (3) based;
dcl  cpu_tag_offset fixed bin (18);
dcl  tag (0:7) char (1) int static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  1 temp_translation like translation;
dcl  version_id char (8) based (data_buf_ptr);
dcl  system_id char (8) based (data_buf_ptr);
	      

dcl  RUNNING fixed bin init (1) static options (constant);

dcl  amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35));
dcl  amu_$definition_offset entry (ptr, char (*), char (*), fixed bin (35)) returns (fixed bin (18));
dcl  amu_$definition_ptr entry (ptr, char(*), char(*), fixed bin(35)) returns(ptr);
dcl  amu_$hardcore_info_fdump entry (ptr, char(*), fixed bin (35));
dcl  amu_$return_val_per_process entry (ptr, fixed bin) returns(bit(1));
dcl  amu_$translate_allocate entry (ptr, fixed bin (17));
dcl  amu_$tc_data_find_apte entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  amu_$fdump_mpt_revert_idx entry (ptr);
dcl  amu_$fdump_mpt_temp_change_idx entry (ptr, fixed bin);
dcl  amu_$fdump_translate_contiguous entry (ptr, ptr, ptr, fixed bin (35));
dcl  amu_$tc_data_find_first_running entry (ptr, fixed bin (24), fixed bin (35));
dcl  amu_$translate_add entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  amu_$translate_force_add entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  amu_$return_val_idx_from_dbr entry (ptr, fixed bin (24)) returns (fixed bin);
dcl  get_temp_segment_		entry (char(*), ptr, fixed bin(35));
dcl  release_temp_segment_	entry (char(*), ptr, fixed bin(35));
dcl  (amu_et_$apte_not_found,
     amu_et_$not_fdump,
     amu_et_$trans_exists,
     amu_et_$big_idx
     ) fixed bin (35) ext;

dcl  (addr, addrel, baseptr, divide, 
      fixed, null, binary, size, hbound,
      index, mod, pointer, lbound, baseno, rel)		builtin;

dcl cleanup condition;
%page;
	code = 0;
	amu_info_ptr = P_amu_info_ptr;
	fdump_info.fdump_process_table_ptr = null ();
	dumpptr = fdump_info.dump_seg_ptr (0);
	data_buf_ptr = null();
	on condition(cleanup) begin;
	   if data_buf_ptr ^= null() then call release_temp_segment_ ("amu_fdump_mpt_", data_buf_ptr, (0));
	   end;
	prev_segno = -1;				/* count the number of apparently separate process's in the */
	n_processes = 0;				/* FDUMP, by looping through the array of segnos and counting */
	do segx = 1 to dump.num_segs;			/* each decrease in segnos as a separate process, on the */
	     if binary (dump.segno (segx), 18) < prev_segno then
						/* grounds that all the segments in a process will */
		n_processes = n_processes + 1;	/* have been stored in monotonically increasing order. */
	     prev_segno = binary (dump.segno (segx));
	end;					/* After the loop is run through, add one to the process */
	n_processes = n_processes + 1;		/* count, since the end of last process isn't detected above */

	alloc_fdump_process_table_size = n_processes;

	allocate fdump_process_table in (amu_area) set (fdump_info.fdump_process_table_ptr);

	fdump_process_table.size = n_processes - 1;
	fdump_process_table.array.process_info_ptr (*) = null ();
	fdump_process_table.array.cpu_name (*) = "";
	fdump_process_table.array.dbr (*) = 0;
	fdump_process_table.array.apte_offset (*) = 0;

	process_idx = 0;				/* Now, loop through the array again, finding the bounds of */
	prev_segno = -1;				/* the dumped address space in each process. */
	fdump_process_table (process_idx).first_seg = 1;	/* first process starts with seg #1, of course */

	total_offset = size (dump);			/* set to the first segment in dump */

/* find where this seg starts this should be seg 0 of the process
   The first word of dseg should be the sdw for seg 0 hence the SDW.ADDR
   is the dbr add value
*/

	fp_table_ptr = addr (fdump_process_table.array (process_idx));
	fp_table.dmp_seg_indx = divide (total_offset, fdump_info.dump_seg_lth (0), 17, 0);
	fp_table.dmp_seg_offset = mod (total_offset, fdump_info.dump_seg_lth (0));
	fp_table.dbr =
	     fixed (pointer (fdump_info.dump_seg_ptr (fp_table.dmp_seg_indx), fp_table.dmp_seg_offset) -> based_dbr, 24);

	do segx = 1 to dump.num_segs;
	     if binary (dump.segno (segx), 18) < prev_segno then do;
						/* we've just switched processes */
		fp_table.last_seg = segx - 1;		/* last segment was previous iteration */
		process_idx = process_idx + 1;	/* get the new first segment number and increment the index */
		fp_table_ptr = addr (fdump_process_table.array (process_idx));
		fp_table.first_seg = segx;		/* get the dbr, we have the chance */
		fp_table.dmp_seg_indx = divide (total_offset, fdump_info.dump_seg_lth (0), 17, 0);
		if (fp_table.dmp_seg_indx = fdump_info.n_dump_segs) |
		   fdump_info.dump_seg_ptr (fp_table.dmp_seg_indx) = null then do;
						/* Problems */

		     call com_err_ (0, "amu_fdump_mpt_", "Cannot complete process ^d, no more dump segs.",
			process_idx);
		     fdump_process_table.size = process_idx - 1;
		     process_idx = process_idx - 1;
		     fp_table.dmp_seg_indx = fp_table.dmp_seg_indx -1;
		     fp_table.last_seg = segx - 1;
		     goto no_more_segs;
		     end;
		fp_table.dmp_seg_offset = mod (total_offset, fdump_info.dump_seg_lth (0));
		fp_table.dbr =
		     fixed (pointer (fdump_info.dump_seg_ptr (fp_table.dmp_seg_indx), fp_table.dmp_seg_offset)
		     -> based_dbr, 24);
		end;
	     total_offset = fixed (binary (dump.segs (segx).length, 18) * 64, 71, 0) + total_offset;
	     prev_segno = binary (dump.segno (segx), 18);
	end;
	fp_table.last_seg = dump.num_segs;		/* and last seg of last process is last seg in dump */
no_more_segs:
	process_idx = 0;
	amu_info.process_idx = process_idx;
	fp_table_ptr = addr (fdump_process_table.array (process_idx));
	call init_process_table;

	fp_table.process_info_ptr = amu_info.process_info_ptr;

	call amu_$translate_allocate (amu_info_ptr, 10);	/* default to 10 segs */
	process_info.address_map_ptr = amu_info.translation_table_ptr;
						/* now we have a place to keep the translations for */
						/* the interesting hardcore segs                  */
	call amu_$hardcore_info_fdump (amu_info_ptr, P_caller, code);
	if code ^= 0 then do;			/* msg already printed			*/
	     P_code = code;
	     return;	     
	     end;

	cpu_tag_offset = amu_$definition_offset (amu_info_ptr, "prds", "processor_tag", code);
	if code ^= 0 then return;

	amu_info.type = FDUMP_PROCESS_TYPE;
	
	do process_idx = 0 by 1 to fdump_process_table.size;
	     amu_info.process_idx = process_idx;
	     fp_table_ptr = addr (fdump_process_table.array (process_idx));
	     call create_proc_table();

	     if process_info.prds.foreign_ptr ^= null () then
		fp_table.cpu_name = tag (addrel (process_info.prds.foreign_ptr, cpu_tag_offset) -> cpu_no);
	     else if process_info.prds.local_ptr ^= null () then
		fp_table.cpu_name = tag (addrel (process_info.prds.local_ptr, cpu_tag_offset) -> cpu_no);
	     else fp_table.cpu_name = "";
	end;

				/* now fine the dbr of the first running process to use as default    */
	call amu_$tc_data_find_first_running (amu_info_ptr, search_dbr, code);
	if code ^= 0 then
	     process_idx = 0;
	else do;
	     process_idx = amu_$return_val_idx_from_dbr (amu_info_ptr, search_dbr);
	     if process_idx = -1 then process_idx = 0;
	     end;

	call set_for_proc (process_idx);		/* set the default to proc index one for now      */
	
	call get_temp_segment_ ("amu_fdump_mpt_", data_buf_ptr, code);
	if code ^= 0 then return;

	range = 2;
	temp_ptr = amu_$definition_ptr (amu_info_ptr, "active_all_rings_data",
	   "version_id", code);
	if code ^= 0 then go to RET;
	call get_data_ (data_buf_ptr, fixed (baseno (temp_ptr), 17), fixed (rel (temp_ptr), 18), range);

	fdump_info.version_id = version_id;

	temp_ptr = amu_$definition_ptr (amu_info_ptr, "active_all_rings_data",
	   "system_id", code);
	if code ^= 0 then go to RET;
	call get_data_ (data_buf_ptr, fixed (baseno (temp_ptr), 17), fixed (rel (temp_ptr), 18), range);
	fdump_info.system_id = system_id;	

RET:	
   if data_buf_ptr ^= null() then call release_temp_segment_ ("amu_fdump_mpt_", data_buf_ptr, code);
return;

amu_fdump_mpt_$current_process:
     entry (P_amu_info_ptr);
	amu_info_ptr = P_amu_info_ptr;
	af_sw = "0"b;
	call what_process;
	return;

amu_fdump_mpt_$current_process_af:
     entry (P_amu_info_ptr, af_ptr, af_len);
	amu_info_ptr = P_amu_info_ptr;
	af_sw = "1"b;
	call what_process;
	return;

amu_fdump_mpt_$temp_change_idx:
     entry (P_amu_info_ptr, P_idx);
	amu_info_ptr = P_amu_info_ptr;
	if amu_info.type = SAVED_PROC_TYPE then return;
	amu_info.proc_idx_hold = amu_info.process_idx;
	call set_for_proc (P_idx);
	return;

amu_fdump_mpt_$change_idx:
     entry (P_amu_info_ptr, P_idx);
	amu_info_ptr = P_amu_info_ptr;
	if amu_info.type = SAVED_PROC_TYPE then return;
	call set_for_proc (P_idx);
	return;


amu_fdump_mpt_$revert_idx:
     entry (P_amu_info_ptr);
	amu_info_ptr = P_amu_info_ptr;
	if amu_info.type = SAVED_PROC_TYPE then return;
	call set_for_proc (amu_info.proc_idx_hold);
	return;


amu_fdump_mpt_$fill_proc_table:
     entry (P_amu_info_ptr, P_dbr, P_idx, P_cpu, brief_sw, P_code);

	amu_info_ptr = P_amu_info_ptr;
	if amu_info.type = FDUMP_TYPE then amu_info.type = FDUMP_PROCESS_TYPE;
	if amu_info.type ^= FDUMP_PROCESS_TYPE then do;
	     P_code = amu_et_$not_fdump;
	     return;
	     end;
	code = 0;
	cpu_name = P_cpu;
	search_dbr = P_dbr;
	process_idx = P_idx;

	if search_dbr ^= 0 & process_idx = -1 then do;
	   do process_idx = lbound (fdump_process_table.array, 1) by 1 to hbound (fdump_process_table.array, 1)
	      while (search_dbr ^= fdump_process_table.array (process_idx).dbr);
	      end;
  	   if process_idx < lbound (fdump_process_table.array, 1) | process_idx > hbound (fdump_process_table.array, 1)
             then do;
	      P_code = amu_et_$apte_not_found;
	      return;
	      end;
             end;
	else if cpu_name ^= "" then do;
	     do process_idx = 0 by 1 to fdump_process_table.size;
		if cpu_name = fdump_process_table.array (process_idx).cpu_name then
		     if fdump_process_table.array (process_idx).process_info_ptr -> process_info.state = RUNNING then
			go to get_p;
	     end;
	     call ioa_ ("No running process for cpu ^a", cpu_name);
	     P_code = 0;
	     return;

	     end;
	if process_idx < lbound (fdump_process_table.array, 1) | process_idx > hbound (fdump_process_table.array, 1)
	then do;
	     P_code = amu_et_$big_idx;
	     return;
	     end;
get_p:
	call set_for_proc (process_idx);
	if ^brief_sw then call what_process_selected;
	return;


amu_fdump_mpt_$terminate:
     entry (P_amu_info_ptr);
dcl  i;
	amu_info_ptr = P_amu_info_ptr;
	if fdump_info.fdump_process_table_ptr ^= null () then do;
	     do i = lbound (fdump_process_table.array, 1) to hbound (fdump_process_table.array, 1);
		amu_info.process_info_ptr = fdump_process_table.array (i).process_info_ptr;
		if amu_info.process_info_ptr ^= null then free process_info in (amu_area);
	     end;
	     free fdump_process_table in (amu_area);
	     end;
	return;

%page;
get_data_:
     proc (data_ptr, seg, word, number);


dcl  data_ptr ptr;
dcl  seg fixed bin;
dcl  (word, number) fixed bin (18);

	if ^amu_$return_val_per_process (amu_info_ptr, seg) then do;
	     index_changed = "1"b;
	     call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, lbound (fdump_process_table.array, 1));
	     end;
	call amu_$do_translation (amu_info_ptr, seg, data_ptr, word, number, code);
	if index_changed = "1"b then do;
	     call amu_$fdump_mpt_revert_idx (amu_info_ptr);
	     index_changed = "0"b;
	     end;
     end get_data_;

%page;
what_process:
     proc;
dcl  process_st (0:6) char (9) varying int static options (constant)
	init ("empty", "running", "ready", "waiting", "blocked", "stopped", "ptlocking");
	t_ptr = addr (t_data);
	t_segno = hardcore_info.segno.pds;
	t_offset = amu_$definition_offset (amu_info_ptr, "pds", "process_group_id", code);

	call amu_$do_translation (amu_info_ptr, t_segno, t_ptr, t_offset, 8, code);

	if af_sw then do;
	   call ioa_$rsnnl ("^o", pid, ignore, fixed(process_info.pid));
	   af_str = af_str || " " || pid;
	   end;
	else do;
	   if index (based_char, ".") = 0 then based_char = "";  
	   if process_info.state = RUNNING then call ioa_ ("Proc ^3d DBR ^9o^[ running^39ton cpu ^a^]^3x^a", 
	          amu_info.process_idx, fdump_process_table.array (amu_info.process_idx).dbr, 
		(process_info.state = RUNNING), fdump_process_table.array (amu_info.process_idx).cpu_name, based_char);
  	   else call ioa_ ("Proc ^3d DBR ^9o ^9a last on cpu ^a^3x^a", amu_info.process_idx,
		fdump_process_table.array (amu_info.process_idx).dbr, process_st (process_info.state),
		fdump_process_table.array (amu_info.process_idx).cpu_name, based_char);
             end;

     end what_process;

what_process_selected:
     proc;

	t_ptr = addr (t_data);
	t_segno = hardcore_info.segno.pds;
	t_offset = amu_$definition_offset (amu_info_ptr, "pds", "process_group_id", code);

	call amu_$do_translation (amu_info_ptr, t_segno, t_ptr, t_offset, 8, code);
          call ioa_ ("Process ^3d, ^a, DBR ^9o", amu_info.process_idx, based_char, 
		fdump_process_table.array (amu_info.process_idx).dbr);

     end what_process_selected;


create_proc_table:
     proc;


	if fp_table.process_info_ptr = null () then do;
	     call init_process_table;
	     fp_table.process_info_ptr = amu_info.process_info_ptr;
	     end;
	else amu_info.process_info_ptr = fp_table.process_info_ptr;

	call amu_$tc_data_find_apte (amu_info_ptr, fp_table.dbr, segment_ptr, code);
	if code ^= 0 then do;
	     call ioa_ ("Could not find apte for process_idx ^d^/^5xdbr = ^o", process_idx, fp_table.dbr);
	     return;
	     end;
	if hardcore_info.pointers.tc_data.fptr ^= null () then do;
	     process_info.apte.foreign_ptr = segment_ptr;
	     process_info.apte.local_ptr = null ();
	     fp_table.apte_offset =
		fixed (rel (segment_ptr), 18) - fixed (rel (hardcore_info.pointers.tc_data.fptr), 18);
	     end;
	else do;
	     process_info.apte.foreign_ptr = null ();
	     process_info.apte.local_ptr = segment_ptr;
	     fp_table.apte_offset =
		fixed (rel (segment_ptr), 18) - fixed (rel (hardcore_info.pointers.tc_data.lptr), 18);


	     end;
	aptep = segment_ptr;
	process_info.dbr = apte.dbr;
	process_info.state = fixed (apte.flags.state, 17);
	process_info.pid = apte.processid;
	process_info.idx = process_idx;
	if process_info.address_map_ptr = null () then do;
	     call amu_$translate_allocate (amu_info_ptr, 10);
	     process_info.address_map_ptr = amu_info.translation_table_ptr;
	     end;
	else amu_info.translation_table_ptr = process_info.address_map_ptr;
	process_info.idx = process_idx;
	segment_ptr = baseptr (hardcore_info.prds);
	call fill_ptrs (addr (process_info.prds), segment_ptr);
	segment_ptr = baseptr (hardcore_info.dseg);
	call fill_ptrs (addr (process_info.dseg), segment_ptr);
	segment_ptr = baseptr (hardcore_info.pds);
	call fill_ptrs (addr (process_info.pds), segment_ptr);
	segment_ptr = baseptr (hardcore_info.kst);
	call fill_ptrs (addr (process_info.kst), segment_ptr);


	process_info.dump_segx.first = fp_table.first_seg;
	process_info.dump_segx.last = fp_table.last_seg;



	return;
     end create_proc_table;


init_process_table:
     proc;
	allocate process_info in (amu_area) set (amu_info.process_info_ptr);
	process_info.address_map_ptr = null ();
	process_info.apte.foreign_ptr = null ();
	process_info.apte.local_ptr = null ();
	process_info.prds = process_info.apte;
	process_info.dseg = process_info.apte;
	process_info.pds = process_info.apte;
	process_info.kst = process_info.apte;

     end init_process_table;


set_for_proc:
     proc (p_idx);					/* This proc should not change the amu_info.proc_idx_hold */
dcl  p_idx fixed bin;

	amu_info.type = FDUMP_PROCESS_TYPE;
	amu_info.process_idx = p_idx;
	amu_info.process_info_ptr = fdump_process_table.array (amu_info.process_idx).process_info_ptr;
	amu_info.translation_table_ptr = process_info.address_map_ptr;
     end set_for_proc;


fill_ptrs:
     proc (ppdp, dp);
dcl  1 proc_ptr_data like process_info.apte based (ppdp);
dcl  ppdp ptr;
dcl  dp ptr;
	call amu_$fdump_translate_contiguous (amu_info_ptr, dp, addr (temp_translation), code);
	if temp_translation.flags.in_dump = "1"b then do;
	     proc_ptr_data.foreign_ptr = temp_translation.part1.ptr;
	     proc_ptr_data.local_ptr = null ();
	     end;
	else do;
	     proc_ptr_data.local_ptr = temp_translation.part1.ptr;
	     proc_ptr_data.foreign_ptr = null ();
	     end;
	call amu_$translate_add (amu_info_ptr, addr (temp_translation), fixed (baseno (dp), 17), code);
	if code = amu_et_$trans_exists then
	     call amu_$translate_force_add (amu_info_ptr, addr (temp_translation), fixed (baseno (dp), 17), code);

     end fill_ptrs;

%page;
%include amu_translation;
%page;
%include amu_info;
%page;
%include amu_fdump_info;
%page;
%include amu_process_info;
%page;
%include amu_hardcore_info;
%page;
%include apte;
%page;
%include bos_dump;

     end amu_fdump_mpt_;




		    amu_fdump_translate_.pl1        07/28/87  0939.7rew 07/28/87  0924.4       81783



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(87-07-09,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-16,Fawcett), install(87-07-28,MR12.1-1049):
     Correct dump segment length reference.
                                                   END HISTORY COMMENTS */


/* Modified 02/20/86 by Paul Leatherman to make lth = lth - 1 */

amu_fdump_translate_: proc ();

	return;					/* not an entrypoint */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

dcl  (
     P_amu_info_ptr pointer,
     P_seg_ptr pointer,
     P_translation_ptr pointer,
     P_seg_lth fixed bin (19),
     P_code fixed bin (35)
     ) parameter;

dcl  (base, base_2) pointer;
dcl  (lth, lth_2) fixed bin (19);
dcl  segno fixed bin (15);
dcl  temp_seg_name char (32);
dcl  process_idx fixed bin;

dcl  copy_seg_ptr pointer;

dcl  1 copy_seg aligned based (copy_seg_ptr),
       2 part1 (lth) bit (36) aligned,
       2 part2 (lth_2) bit (36) aligned;

dcl  copy_part1 (lth) bit (36) aligned based (base);
dcl  copy_part2 (lth_2) bit (36) aligned based (base_2);

dcl  amu_et_$seg_not_dumped fixed bin (35) external;
dcl  amu_error_ entry options (variable);
dcl  amu_$temp_seg_get entry (pointer, char (*), pointer, pointer);
dcl  ioa_$rsnnl entry options (variable);

dcl  (addr, binary, baseno, divide, mod, null, pointer) builtin;
%page;

amu_fdump_translate_$get_translation:
     entry (P_amu_info_ptr, P_seg_ptr, P_translation_ptr, P_code);

/* This entry fills in a translation for the specified pointer, without regard
   to whether it is split across dump segment boundaries. It is used when initializing
   the translation array for the first time. */

	call get_amu_info ();			/* set up pointers and indexes */
	translation_ptr = P_translation_ptr;
	segno = binary (baseno (P_seg_ptr), 15);

	call locate_segment (segno, process_idx);	/* sets base & lth */
	if base = null () then do;
	     P_code = amu_et_$seg_not_dumped;
	     return;
	     end;
	translation.flags = "0"b;
	translation.segno = segno;
	translation.part1.ptr = base;
	translation.part1.lth = lth;
	translation.flags.in_dump = "1"b;
	translation.part2.ptr = base_2;
	if base_2 ^= null then do;
	     translation.part2.lth = lth_2;
	     translation.flags.two_part = "1"b;
	     end;
	else do;
	     translation.part2.lth = 0;

	     end;


	return;					/* end of code for this entrypoint */

%page;

amu_fdump_translate_$contiguous:
     entry (P_amu_info_ptr, P_seg_ptr, P_translation_ptr, P_code);

/* This entry fills in a translation for the specified pointer, copying the segment
   contents into a temp segment before doing so if it spans dump segment boundaries.
   This is used the first time it is necessary to have a contiguous segment to reference.
*/

	call get_amu_info ();			/* set up pointers and indexes */
	translation_ptr = P_translation_ptr;
	segno = binary (baseno (P_seg_ptr), 15);

	call locate_segment (segno, process_idx);	/* sets base & lth */
	if base = null () then do;
	     P_code = amu_et_$seg_not_dumped;
	     return;
	     end;
	translation.flags = "0"b;
	if base_2 = null () then do;			/* already contiguous or nonexistent */
	     translation.part1.ptr = base;
	     translation.part1.lth = lth;
	     translation.part2.ptr = null ();
	     translation.part2.lth = 0;
	     translation.segno = segno;
	     translation.flags.in_dump = "1"b;
	     return;
	     end;

	call ioa_$rsnnl ("ERF ^a: seg ^o, proc ^d", temp_seg_name, (0), fdump_info.erf_name, segno, process_idx);

	call amu_$temp_seg_get (amu_info_ptr, temp_seg_name, fdump_info.copy_block_ptr, copy_seg_ptr);

	copy_seg.part1 = copy_part1;			/* now, copy the info */
	copy_seg.part2 = copy_part2;
	translation.flags = "0"b;
	translation.part1.ptr = copy_seg_ptr;
	translation.part1.lth = lth + lth_2;
	translation.part2.ptr = null ();
	translation.part2.lth = 0;
	translation.segno = segno;
	translation.flags.in_temp_seg = "1"b;
	return;					/* all done */

%page;
amu_fdump_translate_$to_temp_seg:
     entry (P_amu_info_ptr, P_seg_ptr, P_translation_ptr, P_code);

/* This entry will translate a seg no from the ERF to a tempseg Put in for stacks */


	call get_amu_info ();			/* set up pointers and indexes */
	translation_ptr = P_translation_ptr;
	segno = binary (baseno (P_seg_ptr), 15);

	call locate_segment (segno, process_idx);	/* sets base & lth */
	if base = null () then do;
	     P_code = amu_et_$seg_not_dumped;
	     return;
	     end;

	call ioa_$rsnnl ("ERF ^a: seg ^o, proc ^d", temp_seg_name, (0), fdump_info.erf_name, segno, process_idx);

	call amu_$temp_seg_get (amu_info_ptr, temp_seg_name, fdump_info.copy_block_ptr, copy_seg_ptr);

	copy_seg.part1 = copy_part1;			/* now, copy the info */
	if base_2 ^= null then copy_seg.part2 = copy_part2;
	translation.flags = "0"b;
	translation.part1.ptr = copy_seg_ptr;
	translation.part1.lth = lth + lth_2;
	translation.part2.ptr = null ();
	translation.part2.lth = 0;
	translation.segno = segno;
	translation.flags.in_temp_seg = "1"b;
	return;					/* all done */

amu_fdump_translate_$get_seg_lth:
     entry (P_amu_info_ptr, P_seg_ptr, P_seg_lth, P_code);

/* This entrypoint returns the length of a segment in process 1. */

	call get_amu_info ();

	call locate_segment (binary (baseno (P_seg_ptr), 15), 1);
	if base = null () then do;
	     P_code = amu_et_$seg_not_dumped;
	     return;
	     end;

	P_code = 0;
	P_seg_lth = lth + lth_2;


	return;					/* all done for this entrypoint */

%page;

get_amu_info:
     proc ();

/* This procedure sets amu_info_ptr and process_idx, and also generates an error
   for any attempt to use an invalid amu_info. */

	amu_info_ptr = P_amu_info_ptr;

	if amu_info.type = FDUMP_TYPE then process_idx = 0;
	else if amu_info.type = FDUMP_PROCESS_TYPE then process_idx = amu_info.process_idx;
	else call amu_error_ (amu_info_ptr, 0, "Invalid type for FDUMP amu_info ^d.", amu_info.type);

	P_code = 0;				/* until something happens */

	return;
     end get_amu_info;

%page;

locate_segment:
     proc (P_segno, P_process_idx);

/* This procedure attempts to locate the specified segment from the set of segments dumped
   for the specified process. It sets base, lth, base_2, and lth_2 as its output.
*/

dcl  (
     P_segno fixed bin (15),
     P_process_idx fixed bin
     ) parameter;

dcl  segx fixed bin;
dcl  dump_seg_idx fixed bin;
dcl  offset fixed bin (24);
dcl  total_lth fixed bin (19);


	if (P_process_idx < 0) | (P_process_idx > fdump_process_table.size) then
	     call amu_error_ (amu_info_ptr, 0, "Process index out of range. ^d", P_process_idx);
	fp_table_ptr = addr (fdump_process_table.array (P_process_idx));

	dumpptr = fdump_info.dump_seg_ptr (0);		/* make the segment table addressable */

	offset = fp_table.dmp_seg_offset;		/* start the offset at the start of the process */

	do segx = fp_table.first_seg to fp_table.last_seg;
	     if binary (dump.segs (segx).segno, 15) = P_segno then /* found it */ goto FOUND_SEGMENT;
	     offset = offset + (64 * binary (dump.segs (segx).length, 18));
	end;

	base = null ();				/* didn't find it */
	base_2 = null ();
	return;

FOUND_SEGMENT:					/* KLUDGEY mechanism for resolving addresses */
	dump_seg_idx = fp_table.dmp_seg_indx + (divide (offset, fdump_info.dump_seg_lth (0), 17, 0));
						/* HIGHLY dependent on exact behaviour of BOS */
	offset = mod (offset, fdump_info.dump_seg_lth (0));

	base = pointer (fdump_info.dump_seg_ptr (dump_seg_idx), offset);

	total_lth = binary (dump.segs (segx).length) * 64;/* length of segment */

	if (offset + total_lth) <= fdump_info.dump_seg_lth (dump_seg_idx) then do;
	     lth = total_lth - 1;			/* image is whole in single dump segment */
	     base_2 = null ();
	     lth_2 = 0;
	     end;

	else do;					/* otherwise, it's split */
	     lth = fdump_info.dump_seg_lth (dump_seg_idx) - offset;
						/* First, use all that remains here */

	     dump_seg_idx = dump_seg_idx + 1;		/* go on to next segment */
	     if fdump_info.dump_seg_ptr (dump_seg_idx) = null then goto LOC_ERR;
	     base_2 = pointer (fdump_info.dump_seg_ptr (dump_seg_idx), 0);
						/* start at the base */
	     lth_2 = (total_lth - lth) - 1;			/* and use up the rest */
	     end;

	if dump_seg_idx > fdump_info.n_dump_segs then do;
LOC_ERR:	   call amu_error_ (amu_info_ptr, 0,
		"While resolving segment ^o in process ^d, referenced nonexistent dump segment ^d.", P_segno,
		P_process_idx, dump_seg_idx);
	     base = null;
	     end;
	return;
     end locate_segment;

%page;
%include amu_info;
%page;
%include amu_fdump_info;
%page;
%include amu_translation;
%page;
%include bos_dump;

     end amu_fdump_translate_;




		    amu_find_system_dump_.pl1       02/16/88  1453.7r w 02/16/88  1409.6      211131



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
amu_find_system_dump_:
     procedure ();

/* amu_find_system_dump_ -- wrapper for search_paths_ for FDUMPS and PDIRS 
   BIM 0783 
   Modified for pdir use by B. Braun 08/10/84
   Modified by BLB 11/08/84 to handle starnames better and absolute path + full component name (eg. >dumps>110184.2400.0.20)
*/


dcl Dump_name			char (*);
dcl Dump_info_ptr			pointer;
dcl Code				fixed bin (35);


/*   Dump_name    (input)
                  For FDUMPS: This can be an ERF number, or a pathname ending with an erf number,
	        or a pathname of the first segment of a dump (rel or abs) 
	        For PDIRS:  This can be the pdir name (with or without the suffix "pdir", or an absolute or relative
	        pathname ending with the pdir name.
    Dump_info_ptr (input)
                  pointer to system_dump_info structure that will be filled in.
    Code          (output)
	        error_table_$noentry or 0. For ambiguous requests, this program signals sub_err_. 
                  Catch the condition if you disapprove.
*/


/* External Entires */

dcl check_star_name_$entry		entry (character (*), fixed binary (35));
dcl expand_pathname_		entry (character (*), character (*), character (*), fixed binary (35));
dcl expand_pathname_$add_suffix	entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl get_system_free_area_		entry () returns (ptr);
dcl hcs_$star_			entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl hcs_$status_minf		entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), 
				fixed bin (35));
dcl ioa_$rsnnl			entry () options (variable);
dcl search_paths_$get		entry (char(*), bit(36), char(*), ptr, ptr, fixed bin, ptr,
				     fixed bin(35));
dcl sub_err_			entry () options (variable);

/* External Static */

dcl error_table_$nomatch		fixed bin (35) ext static;
dcl error_table_$unimplemented_version	fixed bin (35) ext static;
dcl error_table_$noentry		fixed bin (35) ext static;

/* Internal Static */

dcl DUMP_LIST			char (5) init ("dumps") internal static options (constant);
dcl PDIR_SUFFIX			char (4) init ("pdir") internal static options (constant);

/* Automatic */

dcl 1 match_star(3),
      2 name			char(32),
      2 pdir_sw			bit(1);
dcl search_dir_name			char (168);
dcl search_entryname		char (32);
dcl system_area_ptr			ptr;
dcl want_a_pdir			bit(1);
dcl what_to_list			fixed bin;

/* Conditions */

dcl cleanup			condition;

/* Based */

dcl system_area			area based (system_area_ptr);
     
/* Builtins */

dcl (after, before, 
     hbound, null,
     reverse, rtrim,
     search, sum)			builtin;

/*

 The strategy here is somewhat complicated. Analysis of the name
 given proceeds as follows:

   if there no <> in the pathname, then get a complete list of conventionally
   named dumps. apply the search technique described below to each
   directory's worth of dumps at a time.

   if there is <> in the pathname, then use expand_pathname_ to strip out
   directory, and use the search technique below to look for the entryname.

SEARCH TECHNIQUE:

For FDUMPS:
   if there are "."'s in the entryname, then demand that it is the complete
   entryname of segment zero of the dump. The name must match the entryname
   in the directory completely.

   If there are no "."'s, then the entryname is assumed to be a dump number.
   If there is only one segment with a name of the form ??????.????.*.NAME
   (the conventional form), then the search finds it. If there are more than
   one, sub_err_ is signalled. Caller can catch.

For PDIRS:
   if there are "."'s in the entryname, then demand that it is the complete
   entryname of the pdir directory. The name must match the entryname
   in the directory completely. The suffix "pdir" is assumed if not given.

   If there are no "."'s, then the entryname is assumed to be a NAME
   If there is only one segment with a name of the form NAME.pdir
   (the conventional form), then the search finds it. If there are more than
   one, sub_err_ is signalled. Caller can catch.
*/
%page;
/*****************************************************************************/

amu_find_system_dump_$pdir:
     entry (Dump_name, Dump_info_ptr, Code);

     want_a_pdir = "1"b;
     what_to_list = LIST_PDIRS;
     goto COMMON_FIND;

/*****************************************************************************/

amu_find_system_dump_$fdump:
     entry (Dump_name, Dump_info_ptr, Code);

     want_a_pdir = "0"b;
     what_to_list = LIST_FDUMPS;

COMMON_FIND:
     
    system_dump_info_ptr = Dump_info_ptr;
    if system_dump_info.version ^= SYSTEM_DUMP_INFO_VERSION_1 then
       call sub_err_ (error_table_$unimplemented_version, "amu_find_system_dump_", ACTION_CANT_RESTART, null (), (0),
	            "Invalid version ^a in system_dump_info structure.", system_dump_info.version);

    call setup();
    system_dump_info.dump_dir_name, system_dump_info.dump_seg_prefix, system_dump_info.dump_name,
       system_dump_info.dump_entry_format = "";

    Code = 0;
    if search (Dump_name, "<>") > 0 then call FIND_GIVEN_PATHNAME ();
    else call FIND_GIVEN_SEARCHNAME();

return;

/*****************************************************************************/

amu_find_system_dump_$list:
     entry (Dump_list_select_name, Dump_list_version, List_what, Dump_list_area_ptr, Dump_list_ptr, Code);

dcl Dump_list_select_name		char (*); 	/* Input - see below */
dcl Dump_list_version		char (8) aligned;	/* Input - Caller expected list version */
dcl List_what			fixed bin;          /* Inout - list fdumps, pdirs or both */
dcl Dump_list_area_ptr		pointer;		/* Input - area to allocate list */
dcl Dump_list_ptr			pointer;		/* Output - the usual */

/***** Code is non-zero when there is a problem with the search name */

/*  If there are <> in the select name, then there is a particular dir */
/*  to list. if not, then we list all dumps. The entryname part of */
/*  the select name is tacked onto the usual ??????.????.*. */

    if Dump_list_version ^= SYSTEM_DUMP_LIST_VERSION_1 then
       call sub_err_ (error_table_$unimplemented_version, "amu_find_system_dump_$search", ACTION_CANT_RESTART,
            null (), (0), "Unsupported version ^a supplied in call to amu_find_system_dump_$list.", Dump_list_version);

    call setup();
    want_a_pdir = "0"b;
    if search (Dump_list_select_name, "<>") > 0  then do;
       if List_what = LIST_PDIRS then call expand_pathname_$add_suffix (Dump_list_select_name, PDIR_SUFFIX, 
                                           search_dir_name, search_entryname, Code);
       else call expand_pathname_ (Dump_list_select_name, search_dir_name, search_entryname, Code);
       if Code ^= 0 then return;
       call determine_search_name (search_entryname, List_what, match_star);
       call get_one_dir (search_dir_name, match_star, Dump_list_area_ptr, Dump_list_ptr, Code);
       end;

    else do;
       call determine_search_name(Dump_list_select_name, List_what, match_star);
       call LIST_ALL_DIRS (match_star, Dump_list_area_ptr, Dump_list_ptr, Code);
       end;

    if Code = error_table_$nomatch then Code = error_table_$noentry;
    return;

/*****************************************************************************/

FIND_GIVEN_PATHNAME:
     procedure;

/* The difficulty here is that it is hard to know how many pathnames */
/* there are going to be for the whole search list. The expensive, */
/* but simple approach is to allocate a structure for each dir in the */
/* search list, then merge them all together. */

dcl dump_dir_name			char (168);
dcl dump_entryname			char (32);
dcl code				fixed bin (35);

/**** Called when Dump_name needs expanding */

    code = 0;
    if want_a_pdir then call expand_pathname_$add_suffix (Dump_name, PDIR_SUFFIX, dump_dir_name, dump_entryname, code);
    else call expand_pathname_ (Dump_name, dump_dir_name, dump_entryname, code);

    if code ^= 0 then
BAD_NAME:
       call sub_err_ (code, "amu_find_system_dump_", ACTION_CANT_RESTART, null (), (0), "Invalid search name ^a.", Dump_name);

    call check_star_name_$entry (dump_entryname, code);
    if code > 2 then go to BAD_NAME;
    if code = 0 then do;				/* perhaps no list needed? */
       if search (dump_entryname, ".") ^= 0 then do;	/* Really simple, absolute */
	call hcs_$status_minf (dump_dir_name, dump_entryname, 1, (0), (0), code);
	Code = code;
          /* fill in structure */
	system_dump_info.dump_dir_name = dump_dir_name;
	if ^want_a_pdir then do;
	   system_dump_info.dump_name = reverse(before(reverse(dump_entryname), "."));
	   system_dump_info.dump_seg_prefix = reverse (after (after (reverse (dump_entryname), "."), "."));
             call ioa_$rsnnl ("^a.^^d.^a", system_dump_info.dump_entry_format, (0), 
             system_dump_info.dump_seg_prefix, system_dump_info.dump_name);
             end;
          else system_dump_info.dump_name = dump_entryname;

	return;
	end;
       end;

    call determine_search_name (dump_entryname, what_to_list, match_star);
    call get_one_dir (dump_dir_name, match_star, system_area_ptr, system_dump_list_ptr, code);
    if code ^= 0 then do;
       Code = code;
       return;
       end;

RETURN_INFO:
/**** At this point, there better be just one. However, for now, */
/**** we will return the first one, unless there is ambiguity. */

    if system_dump_list.n_dumps > 1 & system_dump_list.duplicate (1)
    then begin;
       dcl bad_dump_name	 char (32);
       dcl bad_dump_dir	 char (168);

       bad_dump_name = system_dump_list.minimal_entryname (1);
       bad_dump_dir = system_dump_list.dir_name (1);
       free system_dump_list in (system_area);
       call sub_err_ ((0), "amu_find_system_dump_", ACTION_CANT_RESTART, null (), (0),
	  "Multiple dumps numbered ^a in ^a.", bad_dump_name, bad_dump_dir);
       end;

    system_dump_info.dump_dir_name = system_dump_list.dir_name (1);
    if ^want_a_pdir then system_dump_info.dump_seg_prefix =
       reverse (after (after (reverse (system_dump_list.full_entryname (1)), "."), "."));
       system_dump_info.dump_name = system_dump_list.minimal_entryname (1);
    if ^want_a_pdir then call ioa_$rsnnl ("^a.^^d.^a", system_dump_info.dump_entry_format, (0), 
       system_dump_info.dump_seg_prefix, system_dump_info.dump_name);
    free system_dump_list in (system_area);
    return;


FIND_GIVEN_SEARCHNAME:
     entry ();

	dump_entryname = Dump_name;
          call determine_search_name (dump_entryname, what_to_list, match_star);
	call LIST_ALL_DIRS (match_star, system_area_ptr, system_dump_list_ptr, code);
	if code ^= 0
	then do;
		Code = code;
		return;
	     end;

	go to RETURN_INFO;

     end FIND_GIVEN_PATHNAME;

/*****************************************************************************/

LIST_ONE_DIR:
     procedure (dir_name, star_name, area_ptr, pdirs_wanted, a_info_ptr, code);

	declare code		 fixed bin (35);
	declare a_info_ptr		 pointer;
	declare area_ptr		 pointer;
	declare star_name		 char (*);	/* starname for dump name part of the problem */
	declare dir_name		 char (*);	/* pathname of dir to list */
dcl pdirs_wanted bit(1);
	declare dumpx		 fixed bin;
	declare an_area		 area based (area_ptr);
	declare name_index		 fixed bin;
	declare n_dead_links	 fixed bin;
	declare n_remove_dirs	 fixed bin;
	declare n_remove_segs	 fixed bin;
	declare type		 fixed bin (2);
	declare starx		 fixed bin;
	declare checkx		 fixed bin;

/* To save LIST_ALL_DIRS the trouble of accumulating results of */
/* status_minf calls when it is given a precise entryname, this */
/* code calls star on a non-star name. Sure, its expensive, */
/* but this program does not have to be cheap. */

    star_names_ptr, star_entry_ptr, system_dump_list_ptr = null();
    a_info_ptr = null();
    on cleanup begin;
       if star_names_ptr ^= null() then free star_names in (an_area);
       if star_entry_ptr ^= null() then free star_entries in (an_area);
       if system_dump_list_ptr ^= null() then free system_dump_list in (an_area);
       end;

    call hcs_$star_ (dir_name, star_name, star_ALL_ENTRIES, area_ptr, star_entry_count, star_entry_ptr,  
                     star_names_ptr, code);
    if code ^= 0 then return;

    /***** Remove null links from the list */

    n_dead_links = 0;
    n_remove_dirs = 0;
    n_remove_segs = 0;
    do dumpx = 1 to star_entry_count;
       name_index = star_entries (dumpx).nindex;
       if star_entries (dumpx).type = star_LINK then do;
          call hcs_$status_minf (dir_name, star_names (name_index), 1, type, (0), code);
	if code = error_table_$noentry then do;
	   star_names (name_index) = "-";
	   n_dead_links = n_dead_links + 1;
	   end;
	end;

       if pdirs_wanted then do;  /* not a directory,  remove any segment entries */
          if star_entries(dumpx).type = star_SEGMENT then do;
	   star_names (name_index) = "-";
	   n_remove_segs = n_remove_segs + 1;
	   end;
	end;
       else do; /* just fdumps */
          if star_entries(dumpx).type = star_DIRECTORY then do;
	   star_names (name_index) = "-";
	   n_remove_dirs = n_remove_dirs + 1;
	   end;
	end;
       end;

    code = 0;					/* residue from link checking */

    system_dump_list_n_dumps = star_entry_count - n_dead_links - n_remove_dirs - n_remove_segs;
    if system_dump_list_n_dumps = 0 then do;
       code = error_table_$nomatch;
       return;
       end;

    allocate system_dump_list in (an_area);
    system_dump_list.version = SYSTEM_DUMP_LIST_VERSION_1;

    name_index = 1;
    dumpx = 1;

    do starx = 1 to star_entry_count;
       name_index = star_entries (starx).nindex;
       if star_names (name_index) = "-"		/* null link, or no dirs or segs */
	then go to SKIP;

       system_dump_list.dir_name (dumpx) = dir_name;
       system_dump_list.new_directory (dumpx) = "0"b;
       system_dump_list.full_entryname (dumpx) = star_names (name_index);
       if pdirs_wanted then system_dump_list.minimal_entryname (dumpx) = system_dump_list.full_entryname (dumpx);
       else system_dump_list.minimal_entryname (dumpx) = reverse (before (reverse (star_names (name_index)), "."));

       system_dump_list.duplicate (dumpx) = "0"b;

       do checkx = 1 to dumpx - 1;
	if system_dump_list.minimal_entryname (checkx) = system_dump_list.minimal_entryname (dumpx) then
             system_dump_list.duplicate (checkx), system_dump_list.duplicate (dumpx) = "1"b;
	end;

       dumpx = dumpx + 1;
SKIP:
       end;

    free star_names in (an_area);
    free star_entries in (an_area);
    revert cleanup;

    a_info_ptr = system_dump_list_ptr;
    return;

    end LIST_ONE_DIR;

/*****************************************************************************/

LIST_ALL_DIRS:
     procedure (match_star, area_ptr, a_info_ptr, code);

/* parameters */

dcl area_ptr			pointer;
dcl a_info_ptr			pointer;
dcl code				fixed bin (35);
dcl 1 match_star(3),
      2 name			char(32),
      2 pdir_sw			bit(1);

/* local */

dcl an_area			area based (area_ptr);
dcl listing_dirname			char(168);
dcl (match_count, idx)		fixed bin;
dcl (sx, path_count)		fixed bin;
dcl temp_n_dumps			fixed bin;

%include sl_control_s;

%include sl_info;



    sl_info_p = null();
    match_count = 0;
    do idx = 1 to hbound(match_star,1);
       if match_star(idx).name ^= "" then match_count = match_count+1;
       end;

    call search_paths_$get (DUMP_LIST, sl_control_default, "" /* no ref path */, null () /* default search seg */,
	     area_ptr, sl_info_version_1, sl_info_p, code);

    if code ^= 0 then call sub_err_ (code, "amu_find_system_dump_", ACTION_CAN_RESTART, null (), (0),
		"No ""dumps"" search list defined.");

    path_count = 0;
    do sx = 1 to sl_info.num_paths;
       if sl_info.paths (sx).type = ABSOLUTE_PATH then
          path_count = path_count + 1;
	end;
    path_count = match_count * path_count;
    begin;
       declare one_dir_list_ptrs      (path_count) pointer;
       declare (pathx, final_dumpx, dirx, dumpx, i)
				      fixed bin;
       declare sx		      fixed bin;

       one_dir_list_ptrs(*) = null();
       system_dump_list_ptr = null();
       on cleanup begin;
	if sl_info_p ^= null() then free sl_info in (an_area);
	if system_dump_list_ptr ^= null() then free system_dump_list in (an_area);
	do i = 1 to path_count;
	   if one_dir_list_ptrs(i) ^= null() then
	      free one_dir_list_ptrs(i) -> system_dump_list in (an_area);
	      end;
	   end;

       pathx = 1;
       temp_n_dumps = 0;
       do sx = 1 to sl_info.num_paths;
	if sl_info.code (sx) ^= 0 then go to SKIP;
	do idx = 1 to match_count;
	   call LIST_ONE_DIR (sl_info.pathname (sx), match_star.name(idx), system_area_ptr, match_star.pdir_sw(idx), 
	                      one_dir_list_ptrs (pathx), code);

   	   if code ^= 0 then do;
	      code = 0;
	      go to SKIP;
	      end;
	   temp_n_dumps = temp_n_dumps + one_dir_list_ptrs (pathx) -> system_dump_list.n_dumps;
   	   pathx = pathx + 1;
SKIP:
	   end; /* end search_name loop */
          end;

       if temp_n_dumps = 0 then do;
          code = error_table_$noentry;
          return;
          end;

       system_dump_list_n_dumps = temp_n_dumps;	/* avoid interference with LIST_ONE */

       /* Okay, now we have N lists. turn them into one BIG list. */

       allocate system_dump_list in (an_area);
       system_dump_list.version = SYSTEM_DUMP_LIST_VERSION_1;

       final_dumpx = 1;
       listing_dirname = "";
       do dirx = 1 to pathx - 1;		/* that many are useful */
          do dumpx = 1 to one_dir_list_ptrs (dirx) -> system_dump_list.n_dumps;
   	   system_dump_list.per_dump (final_dumpx) =  one_dir_list_ptrs (dirx) -> system_dump_list.per_dump (dumpx);
             if listing_dirname ^= system_dump_list.per_dump (final_dumpx).dir_name then
	      system_dump_list.per_dump (final_dumpx).new_directory = "1"b;

             listing_dirname = system_dump_list.per_dump (final_dumpx).dir_name;
	   final_dumpx = final_dumpx + 1;
	   end;
          free one_dir_list_ptrs (dirx) -> system_dump_list in (an_area);
          end;

       end;					/* The Begin Block */

    free sl_info in (an_area);
    revert cleanup;
    a_info_ptr = system_dump_list_ptr;

    return;

     end LIST_ALL_DIRS;
%page;
/*****************************************************************************/

determine_search_name:  proc(entryname, list_what, match_star);
		   
/* parameters */

dcl entryname char(*);
dcl list_what fixed bin;
dcl 1 match_star(3),
      2 name			char(32),
      2 pdir_sw			bit(1);

/* local */

dcl code fixed bin(35);
dcl idx fixed bin;
dcl match_all bit(1);
dcl no_dot bit(1);
dcl s_name char(32);
dcl suffixed_name_$make entry (char(*), char(*), char(32), fixed bin(35));

    match_star(*).name = "";
    match_star(*).pdir_sw = "0"b;
    idx, code  = 0;
    call check_star_name_$entry (entryname, code);
    match_all = (code=2);				/* This is a starname that matches all 		*/
    no_dot = (search(entryname, ".") = 0);

    if list_what = LIST_PDIRS | list_what = LIST_ALL then do;
       idx = idx + 1;
       if match_all then do;
	match_star(idx).name =   "**" || ".pdir";         /* This will match all pdirs			*/
	match_star(idx).pdir_sw = "1"b;
	end;
       else do;
          if no_dot then do;
	   match_star(idx).name =   rtrim(entryname) || ".pdir";
	   match_star(idx).pdir_sw = "1"b;
	   idx = idx + 1;
             match_star(idx).name = rtrim(entryname) || ".*.pdir";
	   match_star(idx).pdir_sw = "1"b;
	   end;
          else do;
             call suffixed_name_$make (entryname, PDIR_SUFFIX, s_name, code);
	   if code = 0 then match_star(idx).name = s_name;
             else match_star(idx).name = entryname;
	   match_star(idx).pdir_sw = "1"b;
	   end;
          end;
       end;

    if list_what = LIST_FDUMPS | list_what = LIST_ALL then do;
       idx = idx + 1;
       if match_all then match_star(idx).name = "??????.????.0." || "*";  
       else do;
          if no_dot then                       /* fdump component, assume it's the erf number */
	   match_star(idx).name = "??????.????.0." || rtrim(entryname);
          else match_star(idx).name = rtrim(entryname);
	end;
       end;

end determine_search_name;
%page;
/*****************************************************************************/

get_one_dir: proc (dir_name, match_star, area_ptr, a_info_ptr, code);

/* parameters */

dcl area_ptr			pointer;
dcl a_info_ptr			pointer;
dcl code				fixed bin (35);
dcl dir_name			char(*);
dcl 1 match_star(3),
      2 name			char(32),
      2 pdir_sw			bit(1);

/* local */

dcl an_area			area based (area_ptr);
dcl (idx, match_count)		fixed bin;
dcl temp_n_dumps			fixed bin;

    a_info_ptr = null();
    match_count = 0;
    do idx = 1 to hbound(match_star,1);
       if match_star(idx).name ^= "" then match_count = match_count+1;
       end;

    begin;
       declare one_dir_list_ptrs      (match_count) pointer;
       declare (pathx, final_dumpx, dirx, dumpx, i)
				      fixed bin;
       declare set_new_dir	      bit (1) aligned;

       one_dir_list_ptrs(*) = null();
       system_dump_list_ptr = null();
       on cleanup begin;
	if system_dump_list_ptr ^= null() then free system_dump_list in (an_area);
	do i = 1 to match_count;
	   if one_dir_list_ptrs(i) ^= null() then
	      free one_dir_list_ptrs(i) -> system_dump_list in (an_area);
	   end;
	end;

       pathx = 1;
       temp_n_dumps = 0;
       do idx = 1 to match_count;
          call LIST_ONE_DIR (dir_name, match_star.name(idx), area_ptr, match_star.pdir_sw(idx), 
	                   one_dir_list_ptrs (pathx), code);
  	if code ^= 0 then do;
	   code = 0;
	   go to SKIP;
	   end;
	temp_n_dumps = temp_n_dumps + one_dir_list_ptrs (pathx) -> system_dump_list.n_dumps;
	pathx = pathx + 1;
SKIP:
          end;

       if temp_n_dumps = 0 then do;
          code = error_table_$noentry;
	return;
	end;

       system_dump_list_n_dumps = temp_n_dumps;	/* avoid interference with LIST_ONE */

       /* Okay, now we have N lists. turn them into one BIG list. */

       allocate system_dump_list in (an_area);
       system_dump_list.version = SYSTEM_DUMP_LIST_VERSION_1;
 
       final_dumpx = 1;
       do dirx = 1 to pathx - 1;		/* that many are useful */
          set_new_dir = "1"b;
          do dumpx = 1 to one_dir_list_ptrs (dirx) -> system_dump_list.n_dumps;
	   system_dump_list.per_dump (final_dumpx) = one_dir_list_ptrs (dirx) -> system_dump_list.per_dump (dumpx);
	   if set_new_dir then do;
	      system_dump_list.per_dump (final_dumpx).new_directory = "1"b;
	      set_new_dir = "0"b;
	      end;
	   final_dumpx = final_dumpx + 1;
	   end;
          free one_dir_list_ptrs (dirx) -> system_dump_list in (an_area);
          end;

       end;				/* The Begin Block */

    revert cleanup;
    a_info_ptr = system_dump_list_ptr;

return;

end get_one_dir;
%page;
/*****************************************************************************/

setup:   proc();

     star_names_ptr, star_entry_ptr = null();
     system_area_ptr = get_system_free_area_();

end setup;
%page;
%include star_structures;
%page;
%include sub_err_flags;
%page;
%include system_dump_info;


     end amu_find_system_dump_;




		    amu_get_name_.pl1               07/20/88  1250.0r w 07/19/88  1533.0      242712



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(86-12-09,Farley), approve(87-07-09,MCR7746),
     audit(87-07-22,Fawcett), install(87-07-28,MR12.1-1049):
     Copied external module get_ast_name_ into an internal proc called
     get_ast_name, so that the current length of an sstnt.name could be
     verified before copying the name.
  2) change(87-01-16,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-22,Fawcett), install(87-07-28,MR12.1-1049):
     Check translation_table for replaced segment (via "replace" request) and
     return the new path instead of the old path.
  3) change(87-06-22,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-22,Fawcett), install(87-07-28,MR12.1-1049):
     Check for screech names on bound_xxx library names and call new
     internal procedure "get_vtoc_pathname" to locate real library name.
                                                   END HISTORY COMMENTS */


amu_get_name_: proc (P_amu_info_ptr, P_segptr) returns (char (*));

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* Modified 830830 to keep from scanning the static and symbol sections for the
   offrel, thereby allways searching just text sections to resolve component
   names... -E. A. Ranzenbach

   Modified 12/9/83 by B. Braun to add entrypoint for_structure. This allosw "stack -as" to resolve names porperly.

   Modified 09/28/84 by B. Braun to get rid of error messages in get_kstp routine.
   Modified 10/04/84 by R. A. Fawcett to look at the slt directly for hardcore sega and look for others seg numbers when there is no kst_seg.
   Modified 12/12/84 by B. Braun to fix bug in kst_name which caused it to ALWAYS fail.
   Modified 01/18/85 by B. Braun to change kst_name to call amu_$kst_util_ entries.
   Modified 01/18/85 by B. Braun to create entry get_l1dir_shortname and procedure of the same name.
   Modified 01/24/85 by B. Braun to correct truncation of pathnames returned.
   Modified 02/06/85 by B. Braun to correct bug for special casing the root ">" case.
   Modified 02/08/85 by B. Braun to check init_segs when a dump isn't early but still using them.
*/

/* Parameters */

dcl  P_amu_info_ptr ptr,
     P_count fixed bin (24),
     P_ptr ptr,
     P_segptr ptr;

/* Automatic */

dcl  areap ptr;
dcl  bitcnt fixed bin (24);
dcl  bndsw bit (1);
dcl  bmp ptr;
dcl  1 branch aligned,				/* output structure from hcs_$status_ */
       2 type bit (2) unal,
       2 nnames fixed bin (15) unal,
       2 nrp bit (18) unal,
       2 dtm bit (36) unal,
       2 dtu bit (36) unal,
       2 mode bit (5) unal,
       2 pad bit (13) unal,
       2 rec fixed bin (17) unal;
dcl  code fixed bin (35);
dcl  dirname char (168);
dcl  ename char (32);
dcl  tdname char(168);	     
dcl  tename char(32);
dcl  genp ptr;
dcl  1 hard_ptrs like hardcore_cur;
dcl  key char (1);
dcl  libx fixed bin;
dcl  (ling, k, i, j, mblen, dl) fixed bin;
dcl  namebuf char (168);
dcl  new_sdw fixed bin (71);
dcl  (nmp, nsdwp) ptr;
dcl  offrel fixed bin (18);
dcl  1 oi_area aligned like object_info;
dcl  ptrtmp ptr;
dcl  ret_ptr_sw bit (1);
dcl  sblkp ptr;
dcl  segno fixed bin;
dcl  segptr ptr;					/* ptr to segment and offset in question */
dcl  1 trans_space like translation;

/* Based */

dcl  var_str char (ling) based (ptrtmp);
dcl  dnames (branch.nnames) char (32) aligned based (nmp);

/* Internal Static */

dcl  1 dinfo int static,				/* level one directory assosciative memory */
       2 ndir fixed bin init (0),
       2 l1dir (30),
         3 lg_name char (32),
         3 sht_name char (4);

/* Conditions */

dcl  zerodivide condition;

/* External Static */

dcl  amu_et_$null_sltp fixed bin (35) ext static;
dcl  amu_et_$null_sltnt fixed bin (35) ext static;
dcl  error_table_$action_not_performed fixed bin (35) ext static;

/* External Entries */

dcl  amu_$dp_segno_to_name entry (ptr, fixed bin, char (*), fixed bin (35));
dcl  amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr);
dcl  amu_$fdump_translate_contiguous entry (ptr, ptr, ptr, fixed bin (35));
dcl  amu_$resolve_virtual_addr entry (ptr, ptr, char (*), fixed bin, fixed bin (18), fixed bin (35));
dcl  amu_$return_val_phcs_ok entry () returns (bit (1));
dcl  amu_$search_path_get_object entry (ptr, fixed bin (35));
dcl  amu_$search_path_set_object entry (ptr, fixed bin (35));
dcl  amu_$translate_force_add entry (ptr, ptr, fixed bin (15), fixed bin (35));
dcl  amu_$translate_get entry (ptr, fixed bin (15), ptr, fixed bin (35));
dcl  amu_do_translation_ entry (ptr, fixed bin, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_bound_seg_info_ entry (ptr, fixed bin (24), ptr, ptr, ptr, fixed bin (35));
dcl  get_system_free_area_ entry (ptr);
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  pathname_ entry (char (*), char (*)) returns (char (168));

/* Builtins */

dcl  (null, addr, addrel, baseno, divide, fixed, ptr, rel, substr, baseptr,
     rtrim, index, reverse, length, maxlength) builtin;
%page;
	ret_ptr_sw, bndsw = "0"b;			/* set sw to break out component names and relative offsets */
	go to common;

get_ptr_count:
     entry (P_amu_info_ptr, P_segptr, P_ptr, P_count);
	bndsw = "0"b;
	ret_ptr_sw = "1"b;
	goto common;

no_comp:
     entry (P_amu_info_ptr, P_segptr) returns (char (*));
	bndsw = "1"b;				/* set switch for no component breakout */
	ret_ptr_sw = "0"b;
	goto common;

for_structure:
     entry (P_amu_info_ptr, a_pointer_rep) returns (char (*) varying);

/* This is a kludge identical to get_name_$get_name_ except we get the pointer from the
   string representation. */

dcl  a_pointer_rep char (*) var;
dcl  segname char (256) var;
dcl  offset fixed bin (18);
dcl  dnl fixed bin;
dcl  replaced_path char(168);
dcl  amu_get_name_ entry (ptr, ptr) returns (char (*));
dcl  hcs_$fs_get_path_name entry (ptr, char(*), fixed bin, char(*), fixed bin(35));

	code = 0;
	segname = a_pointer_rep;			/* translate segname to a segno and offset        */
	call amu_$resolve_virtual_addr (P_amu_info_ptr -> amu_info.sci_ptr, P_amu_info_ptr, (segname), segno, offset,
	     code);
	if code ^= 0 then return (segname);		/* don't get pathname */

	return (segname || " " || rtrim (amu_get_name_ (P_amu_info_ptr, addrel (baseptr (segno), offset))));


common:
	amu_info_ptr = P_amu_info_ptr;
	segptr = P_segptr;
	genp = null ();
	hardcore_cur_ptr = addr (hard_ptrs);		/* get pointers to interesting hc */
	call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr);
	segno = fixed (baseno (segptr), 18);		/* Get segment number */
	offrel = fixed (rel (segptr), 18);		/* Get offset */
	mblen = 168;				/* preset return char length to 168 */
	if segptr = null then do;
	     if ^ret_ptr_sw then
		return ("NULL POINTER");		/* if null ptr stop here */
	     else do;
		P_ptr = null ();
		P_count = 0;
		return;
		end;
	     end;

	if hard_ptrs.sltntp = null then do;
	     if ^ret_ptr_sw then
		return ("Cannot get pointer to SST name table.");
	     else do;
		P_ptr = null ();
		P_count = 0;
		return;
		end;
	     end;

	do i = 1 to translation_table.n_entries while (translation_table.segno (i) ^= segno);
	end;
	if translation_table.flags (i).replaced then do;
	     call hcs_$fs_get_path_name ((translation_table.part1 (i).ptr), dirname, dnl, ename, code);
	     replaced_path = rtrim(dirname) || ">" || rtrim(ename);
	     return (replaced_path);
	end;

	if segno <= hardcore_info.hcs_count |		/* if a hardcore segment */
	     amu_info.early_dump then do;		/* or its an early dump */
	     if segno <= hardcore_info.hcs_count then	/* get name */
		call get_sup_seg_slt (segno, dirname, ename, code);
	     else call get_init_seg_slt (segno, dirname, ename, code);
	     if code ^= 0 then do;
		if ^ret_ptr_sw then
		     return ("not known");
		else do;
		     P_ptr = null ();
		     P_count = 0;
		     return;
		     end;
		end;
	     if bndsw then return (ename);
	     if ^ret_ptr_sw then
		if substr (ename, 1, 5) ^= "bound" then do;
		     call ioa_$rsnnl ("^a|^o", ename, mblen, ename, fixed (rel (segptr)));
		     return (ename);
		     end;
	     namebuf = ename;			/* copy for compatability */
	     go to inithc;				/* initiate hardcore seg from ldd */
	     end;
	else do;					/* Non hardcore segment */
	     if amu_info.type = SAVED_PROC_TYPE then do;
		namebuf = "CANNOT GET NAME";
		call amu_$dp_segno_to_name (amu_info_ptr, segno, namebuf, (0));
		if substr (namebuf, 1, 1) = ">" then goto finish_name;
		return (namebuf);
		end;
	     end;

	nsdwp = addr (new_sdw);			/* get the sdw for segno */
	call amu_do_translation_ (amu_info_ptr, 0, nsdwp, (segno * 2), 2, code);
	astep =
	     ptr (hard_ptrs.sstp,
	     fixed (nsdwp -> sdw.add, 24) - fixed (hard_ptrs.sstp -> sst.ptwbase, 18) - hard_ptrs.sstp -> sst.astsize);
						/* Compute Astep */

/* attempt to ckeck validity of sst_names_ before calling get_ast_name */

	if ^(hard_ptrs.sstntp -> sstnt.valid) then do;	/* chances are it is not valid. */
	     namebuf = "CANNOT-GET-NAME";
	     end;
	else do;
	     namebuf = "";

	     on condition (zerodivide) namebuf = "CANNOT-COMPLETE-PATH";

	     call get_ast_name (astep, hard_ptrs.sstp, hard_ptrs.sstntp, namebuf);
	     revert condition (zerodivide);
	     end;

	call expand_pathname_ (rtrim(namebuf), tdname, tename, code);
	if code ^= 0 then code = 0;
	if substr (tename, 1, 4) = "!BBB" then
	     if ((index (tename, "linker") = 0 & substr(tdname, 1, 4) ^= ">pdd" &
	     substr(tdname, 1, 16) ^= ">process_dir_dir")) then do;
		call get_vtoc_pathname;
		if code ^= 0 then code = 0;
	     end;

	if rtrim (namebuf) = ">" then do;		/* special case the root */
	     if ret_ptr_sw then do;
		P_ptr = null ();
		P_count = 0;
		genp = null;			/* make sure ptr is null */
		call hcs_$initiate_count (namebuf, "", "", bitcnt, 0, genp, code);
		if genp = null then return;
		P_ptr = genp;
		P_count = bitcnt;
		return;
		end;
	     return (namebuf);
	     end;

	if index (namebuf, "CANNOT") ^= 0
	     | (index (reverse (namebuf), "!>") ^= 0 & substr (namebuf, 1, 16) ^= ">process_dir_dir") then
	     if (amu_$return_val_phcs_ok () & get_kstp ()) then
						/* if all this is true, go find name from kst */
		call kst_name (segno, kstp);		/* find the name from kst, sets global namebuf */

	if index (namebuf, "CANNOT") ^= 0 then do;	/* couldn't find in kst */
	     call check_if_early_hardcore_seg (segno, dirname, ename, code);
	     if code ^= 0 then do;
		if index (namebuf, "CANNOT") ^= 1 then	/* have a partial path                            */
		     goto finish_name;

		if ^ret_ptr_sw then
		     return ("CANNOT-GET-NAME");
		else do;
		     P_ptr = null ();
		     P_count = 0;
		     return;
		     end;
		end;
	     if bndsw then return (ename);
	     if ^ret_ptr_sw then
		if substr (ename, 1, 5) ^= "bound" then do;
		     call ioa_$rsnnl ("^a|^o", ename, mblen, ename, fixed (rel (segptr)));
		     return (ename);
		     end;
	     namebuf = ename;			/* copy for compatability */
	     go to inithc;				/* initiate hardcore seg from ldd */
	     end;

finish_name:
	ename, dirname = "";
	call get_l1dir_shortname (namebuf, dirname, ename, code);
	if code = 0 then namebuf = pathname_ (dirname, ename);

	if bndsw then return (namebuf);		/* no need to go further */
	if substr (ename, 1, 6) = "CANNOT" then return (namebuf);
	call expand_path_ (addr (namebuf), length (namebuf), addr (dirname), addr (ename), code);
	if ^ret_ptr_sw then
	     if substr (ename, 1, 5) ^= "bound" then do;
		if (fixed (rel (segptr))) = 0 then
		     return (namebuf);
		else call ioa_$rsnnl ("^a|^o", namebuf, mblen, namebuf, fixed (rel (segptr)));
		return (namebuf);
		end;
	if substr (dirname, 1, 4) = ">sl1" then do;	/* initiate hardcore segments from ldd for bind maps */
inithc:
	     call amu_$search_path_get_object (sl_info_p, code);
	     if sl_info_p = null then			/* set default path */
		call amu_$search_path_set_object (sl_info_p, code);
	     if sl_info_p = null then do;
		namebuf = "CANNOT-COMPLETE-PATH";
		return (namebuf);
		end;

	     genp = null;
	     do libx = 1 to sl_info.num_paths;
		call hcs_$initiate_count (sl_info.paths (libx).pathname, ename, "", bitcnt, 0, genp, code);
		if genp ^= null then goto exit_search;
	     end;
exit_search:
	     if genp = null then
		if ^ret_ptr_sw then return (namebuf);	/* cannot find in search dirs */

	     end;
	else do;
	     genp = null;				/* make sure ptr is null */
	     call hcs_$initiate_count (dirname, ename, "", bitcnt, 0, genp, code);
	     if ^ret_ptr_sw then
		if genp = null then return (namebuf);
	     end;

	if ret_ptr_sw then do;
	     P_ptr = genp;
	     P_count = bitcnt;
	     if P_ptr = null then do;
		call ioa_ ("^-^a not found. Cannot determine arguments.", namebuf);
	     end;
	     return;
	     end;

	oi_area.version_number = object_info_version_2;
	call get_bound_seg_info_ (genp, bitcnt, addr (oi_area), bmp, sblkp, code);
	if code ^= 0 then return (namebuf);		/* We now have a ptr to the bind map */
	if (offrel * 36) > bitcnt then do;		/* offset is out of bounds */
	     call ioa_$rsnnl ("^a|^o Offset OUT-OF-BOUNDS", namebuf, mblen, namebuf, offrel);
	     go to trmnme;
	     end;

	do i = 1 to n_components;
	     j = fixed (bindmap.component (i).text_start, 18);
	     k = fixed (bindmap.component (i).text_lng, 18);
	     if offrel >= j then
		if offrel < j + k then do;		/* We found a match */
		     ptrtmp = addrel (sblkp, bindmap.component (i).name_ptr);
		     ling = fixed (bindmap.component (i).name_lng, 18);
		     call ioa_$rsnnl ("^a$^a|^o", namebuf, mblen, namebuf, var_str, offrel - j);
		     go to trmnme;			/* Go term segment */
		     end;
	end;

	call ioa_$rsnnl ("^a|^o (not in text)", namebuf, namebuf, offrel);
trmnme:
	if genp ^= null () then call hcs_$terminate_noname (genp, code);
	return (namebuf);
%page;
amu_get_name_$get_l1dir_shortname:
     entry (P_segname, P_shortname, P_code);

dcl  P_segname char (*);
dcl  P_shortname char (*);
dcl  P_code fixed bin (35);
dcl  seg_name char (168);

	seg_name = P_segname;
	P_code, code = 0;
	dirname, ename = "";
	call get_l1dir_shortname (seg_name, dirname, ename, code);
	if code = 0 then
	     P_shortname = pathname_ (dirname, ename);
	else do;
	     P_shortname = seg_name;
	     code = 0;
	     end;

	P_code = code;
	return;
%page;
check_if_early_hardcore_seg:
     proc (segno, dirname, ename, code);

dcl  segno fixed bin;
dcl  code fixed bin (35);
dcl  (dirname, ename) char (*);

dcl  1 pid aligned based,
       2 upper bit (18) unal,
       2 lower bit (18) unal;
dcl  pid_ptr ptr;

/*
   If this is the Initializer process, then it's possible he is using early init segs. This happens in
   dumps where it's past the "early dump" stage but not all the way up yet.
*/

/* check if this is the initializer process by looking at the processid */

	code = 0;
	dirname, ename = "";
	if amu_info.process_info_ptr = null () then do;	/* Can't look */
	     code = error_table_$action_not_performed;
	     return;
	     end;

	pid_ptr = addr (process_info.pid);
	if pid_ptr -> pid.lower = "777777"b3 then	/* initializer ID				*/
	     call get_init_seg_slt (segno, dirname, ename, code);

     end check_if_early_hardcore_seg;
%page;
get_init_seg_slt:
     proc (seg_num, ret_dir, ret_name, code);
dcl  seg_num fixed bin;
dcl  ret_name char (*);
dcl  ret_dir char (*);
dcl  code fixed bin (35);
dcl  dpath char (168) based (dpathp);
dcl  dpathp ptr;
	code = 0;
	if hard_ptrs.sltp ^= null () then
	     sltp = hard_ptrs.sltp;
	else do;
	     code = amu_et_$null_sltp;
	     return;
	     end;
	if hard_ptrs.sltntp ^= null () then
	     names_ptr = hard_ptrs.sltntp;
	else do;
	     call ioa_ ("get_init_seg_slt: No slt name segment");
	     return;
	     end;
	if (seg_num < slt.first_init_seg) | (seg_num > slt.last_init_seg) then do;
	     code = error_table_$action_not_performed;
	     return;
	     end;
	sltep = addr (slt.seg (seg_num));
	namep = addrel (names_ptr, slte.names_ptr);
	ret_name = namep -> segnam.names (1).name;
	if slte.branch_required then do;
	     dpathp = addrel (names_ptr, slte.path_ptr);
	     ret_dir = dpath;
	     end;
	else ret_dir = " ";
     end get_init_seg_slt;

%page;
get_l1dir_shortname:
     proc (P_segname, P_dirname, P_ename, P_code);

dcl  P_segname char (*);
dcl  P_dirname char (*);
dcl  P_ename char (*);
dcl  P_code fixed bin (35);

dcl  seg_path char (168);
dcl  dirname char (168);
dcl  ename char (32);
dcl  l1dirname char (32);
dcl  (idx, jdx) fixed bin;
dcl  done bit (1);

	seg_path = P_segname;
	P_dirname, P_ename, dirname, ename = "";
	P_code, code = 0;

	if substr (seg_path, 1, 6) = "CANNOT" then do;
	     P_ename, P_segname = seg_path;
	     P_code = error_table_$action_not_performed;
	     return;
	     end;

	if substr (seg_path, 1, 1) = ">" then do;	/* convert level 1 directories to short form */
	     l1dirname = "";			/* set shortname to all blanks first */
	     idx = index (substr (seg_path, 2), ">") - 1;
	     if idx = 0 then
		l1dirname = rtrim (substr (seg_path, 2));
	     else l1dirname = substr (seg_path, 2, idx);

	     if length (rtrim (l1dirname)) <= 4 then do;	/* Already a shortname just return it */
		goto RETURN_IT;
		end;

	     done = "0"b;
	     if ndir ^= 0 then do;			/*  if we have any dirs in static structure dinfo. */
		do idx = 1 to ndir while (^done);
		     if l1dir.lg_name (idx) = l1dirname then done = "1"b;
		     if l1dir.sht_name (idx) = l1dirname then done = "1"b;
		end;
		end;
	     if ^done then do;			/* did not find in static dinfo */
		ndir = ndir + 1;			/* increment index */
		l1dir.lg_name (ndir) = l1dirname;	/* set in long name */
		l1dir.sht_name (ndir) = "";		/* initially set short name to blanks */
		call get_system_free_area_ (areap);	/* get a place to store names */
		call hcs_$status_ (">", l1dirname, 0, addr (branch), areap, code);
		if code ^= 0 then goto ST_ERR;	/* if we get error, forget it */
		if branch.nnames > 1 | branch.nrp ^= "0"b then do;
		     nmp = ptr (areap, branch.nrp);	/*  form ptr to names */
		     if substr (l1dirname, 1, 15) = "system_library_" then
			if substr (l1dirname, 1, 16) ^= "system_library_1" then
			     key = substr (l1dirname, 16, 1);
						/* get cmp key for system librarys */
			else key = substr (l1dirname, 1, 1);
						/* use first letter of long name for others */
		     else key = substr (l1dirname, 1, 1);
						/* use first letter of long name for others */

		     done = "0"b;			/* reset done condition */
		     do idx = 1 to branch.nnames while (^done);
			if substr (dnames (idx), 1, 1) = key then
			     if length (rtrim (dnames (idx))) <= 4 then do;
						/* found name meetin criteria */
				l1dir.sht_name (ndir) = rtrim(dnames (idx));
				done = "1"b;
				end;
		     end;
		     end;
ST_ERR:
		idx = ndir + 1;			/* set correct index */
		end;

	     if l1dir.sht_name (idx - 1) ^= "" then do;	/* if short name is present */
		dl = length (rtrim (l1dir.lg_name (idx - 1)));
		jdx = length (rtrim (l1dir.sht_name (idx - 1)));
		ling = (length (rtrim (seg_path)) - dl) + 1;
		substr (seg_path, 2, jdx) = substr (l1dir.sht_name (idx - 1), 1, jdx);
		substr (seg_path, jdx + 2) = substr (seg_path, dl + 2);
		substr (seg_path, jdx + ling + 5) = "";
		end;
	     end;

RETURN_IT:
	call expand_pathname_ (seg_path, dirname, ename, code);
	if code ^= 0 then dirname = seg_path;
	P_dirname = dirname;
	P_ename = ename;
	P_code = code;

     end get_l1dir_shortname;
%page;
get_sup_seg_slt:
     proc (seg_num, ret_dir, ret_name, code);
dcl  code fixed bin (35);
dcl  seg_num fixed bin;
dcl  ret_name char (*);
dcl  ret_dir char (*);
dcl  dpath char (168) based (dpathp);
dcl  dpathp ptr;
	code = 0;
	if hard_ptrs.sltp ^= null () then
	     sltp = hard_ptrs.sltp;
	else do;
	     code = amu_et_$null_sltp;
	     return;
	     end;
	if hard_ptrs.sltntp ^= null () then
	     names_ptr = hard_ptrs.sltntp;
	else do;
	     code = amu_et_$null_sltnt;
	     return;
	     end;
	if (seg_num < slt.first_sup_seg) | (seg_num > slt.last_sup_seg) then do;
	     code = error_table_$action_not_performed;
	     return;
	     end;
	sltep = addr (slt.seg (seg_num));
	namep = addrel (names_ptr, slte.names_ptr);
	ret_name = namep -> segnam.names (1).name;
	if slte.branch_required then do;
	     dpathp = addrel (names_ptr, slte.path_ptr);
	     ret_dir = dpath;
	     end;
	else ret_dir = " ";
     end get_sup_seg_slt;

%page;
get_kstp:
     proc returns (bit (1));
	call amu_$translate_get (amu_info_ptr, hardcore_info.segno.kst, translation_ptr, code);

	if translation_ptr = null then goto Trans_it;
	if translation.flags.two_part then do;
Trans_it:						/*             if amu_info.type ^= FDUMP_PROCESS_TYPE then return ("0"b); */
	     translation_ptr = addr (trans_space);
	     code = 0;
	     call amu_$fdump_translate_contiguous (amu_info_ptr, baseptr (hardcore_info.segno.kst), translation_ptr,
		code);
	     if code ^= 0 then return ("0"b);

	     call amu_$translate_force_add (amu_info_ptr, translation_ptr, hardcore_info.segno.kst, code);
	     if code ^= 0 then return ("0"b);
	     end;

	kstp = translation.part1.ptr;
	return ("1"b);
     end get_kstp;
%page;
/* kst_name - internal procedure to find name of segment in kst of dump, from live system */

kst_name:
     proc (P_segn, P_kstp);

dcl  P_segn fixed bin;
dcl  P_kstp ptr;

dcl  segn fixed bin;
dcl  uid_path (16) bit (36) aligned;
dcl  code fixed bin (35);
dcl  expanded_path char (168);
dcl  amu_$kst_util_expand_uid_path entry (ptr, (16) bit (36) aligned, char (*), fixed bin (35));
dcl  amu_$kst_util_segno_to_uid_path entry (ptr, fixed bin, (16) bit (36) aligned, fixed bin (35));

	segn = P_segn;
	kstp = P_kstp;				/* copy ptr for neater code */
	code = 0;
	expanded_path = "";
	uid_path (*) = ""b;
	if segn < kst.lowseg | segn > kst.highseg then return;
						/* no point in using KST */
	call amu_$kst_util_segno_to_uid_path (kstp, segn, uid_path, code);
	if code ^= 0 then return;
	call amu_$kst_util_expand_uid_path (kstp, uid_path, expanded_path, code);
	if code ^= 0 then return;
	namebuf = expanded_path;

     end kst_name;
%page;
/* get_ast_name - internal procedure to find name of segment in sstnt of dump */

get_ast_name:
     proc (a_astep, a_sstp, a_sstnp, retstr);

dcl  (a_astep, a_sstp, a_sstnp) ptr;

dcl  retstr char (*);

	astep = a_astep;
	sstp = a_sstp;
	sstnp = a_sstnp;

	if fixed (rel (astep), 18) < fixed (rel (sstp -> sst.astap), 18) then do;
fail:
	     retstr = "CANNOT GET PATHNAME";
	     return;
	     end;

	if rel (astep) = rel (sstp -> sst.root_astep) then do;
	     retstr = ">";
	     return;
	     end;

	retstr = recurse (astep, length (retstr));
	return;

recurse:
	proc (astep, namel) returns (char (*));

dcl  (ptsi, ra) fixed bin;
dcl  namel fixed bin;
dcl  sstnt_idx fixed bin;
dcl  astep ptr,
     name char (32) varying;

	     ra = fixed (rel (astep), 18);		/* for ease */
	     if ra < fixed (rel (sstp -> sst.astap), 18) then go to fail;
	     do ptsi = 3 to 0 by -1 while (ra < sstnp -> sstnt.ast_offsets (ptsi));
	     end;
	     if ptsi < 0 then go to fail;

	     if ptsi ^= fixed (astep -> aste.ptsi, 2) then go to fail;

	     sstnt_idx =
		divide (ra - sstnp -> sstnt.ast_offsets (ptsi), sstnp -> sstnt.ast_sizes (ptsi), 18, 0)
		+ sstnp -> sstnt.ast_name_offsets (ptsi);

	     if length (sstnp -> sstnt.names (sstnt_idx)) < 0
		| length (sstnp -> sstnt.names (sstnt_idx)) > maxlength (name) then
		name = "CANNOT-GET";		/* sstnt has garbage */

	     else name = sstnp -> sstnt.names (sstnt_idx);

	     if length (name) = 0 then name = "CANNOT-GET";

	     if astep -> aste.par_astep = rel (sstp -> sst.root_astep) then do;
		if length (name) >= namel then
		     return ("");
		else return (">" || name);
		end;


	     if namel = 1 then return (">");
	     if length (name) >= namel then return (recurse (ptr (astep, astep -> aste.par_astep), namel - 1) || ">");

	     return (recurse (ptr (astep, astep -> aste.par_astep), namel - length (name) - 1) || ">" || name);
	end;
     end get_ast_name;
%page;
get_vtoc_pathname: proc;

/* get_vtoc_pathname extracted from Bernard Greenberg's 05/20/76 vtoc_pathname */

dcl  nfsw bit (1) init ("0"b);
dcl  (ioa_, ioa_$rsnnl) entry options (variable);
dcl  1 local_vtoce like vtoce aligned;
dcl  check_gate_access_ entry (char(*), ptr, fixed bin(35));
dcl  phcs_$get_vtoce entry (fixed bin, fixed bin, ptr, fixed bin (35));
dcl  pn char (168);
dcl  vpn_cv_uid_path_$ent entry (ptr, char (*), bit (36), fixed bin (35));
dcl  myname char (19) init ("amu_get_name_");
dcl  (opvtx, ovtocx) fixed bin;

     vtocep = addr (local_vtoce);
     opvtx = astep->aste.pvtx;
     ovtocx = astep->aste.vtocx;
     call check_gate_access_ ("phcs_", null, code);
     if code ^= 0 then return;
     call phcs_$get_vtoce (opvtx, ovtocx, vtocep, code);
     if code ^= 0 then do;
	call ioa_ ("^-^a: Error getting vtoce ^o on pvtx ^o.", myname, astep->aste.vtocx, astep->aste.pvtx);
	return;
     end;

     if vtoce.uid = "0"b then do;
	if nfsw then return;
	call ioa_ ("^-^a: Error: Vtocx ^o on pvtx ^o is free.", myname, astep->aste.vtocx, astep->aste.pvtx);
          return;
     end;

     pn = "";
     call vpn_cv_uid_path_$ent (addr (vtoce.uid_path), pn, vtoce.uid, code);
     if code ^= 0 then
	call ioa_ ("^-^a: Error: Cannot completely convert uid path", myname);
     call ioa_$rsnnl ("^a", namebuf, 0, pn);
     return;
end get_vtoc_pathname;
%page;
%include vtoce;
%page;
%include disk_table;
%page;
%include amu_hardcore_info;
%page;
%include amu_info;
%page;
%include amu_translation;
%page;
%include aste;
%page;
%include bind_map;
%page;
%include dir_entry;
%page;
%include dir_header;
%page;
%include dir_name;
%page;
%include kst;
%page;
%include object_info;
%page;
%include amu_process_info;
%page;
%include sdw;
%page;
%include sl_info;
%page;
%include sst;
%page;
%include sstnt;
%page;
%include slt;
%page;
%include slte;
%page;
%include pvt;
%page;
%include pvte;

     end amu_get_name_;




		    amu_hardcore_info_.pl1          07/28/87  0939.7rew 07/28/87  0924.4      189090



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-07-09,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049):
     Check for early dump based on existence of certain hardcore referencing,
     then return pointer values based on that information.
                                                   END HISTORY COMMENTS */


amu_hardcore_info_: proc;
	return;

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/*
   This proc will set up the hadrcore_info data 

   dcl amu_$hardcore_info_deadproc entry (ptr,char(168),fixed bin (35);
   call amu_$hardcore_info_deadproc (amu_info_ptr,deadproc_dir,code);
   

   dcl amu_$hardcore_info_fdump entry (ptr,fixed bin (35));
   call amu_$hardcore_info_fdump (amu_info_ptr,code);
   where
   amu_info_ptr is a pointer to this amu_info   (input)
   code is the error code  0 if ok .   (output)

   dcl amu_$hardcore_info_set_cur_ptrs entry (ptr,ptr);
   call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr,hardcore_cur_ptr);
   where
   amu_info_ptr as above (input)
   hardcore_cur_ptr is a pointer to where the hardcore_cur
   strcuture will be stored       (input)

   Modified July 84 by B. Braun to add knowledge of unpaged_page_tables.
   Modified Sept 84 by B. Braun to use inzr_stk0 when active_all_rings_data_ doesnt exist.
*/

/* Parameters */

dcl  P_amu_info_ptr ptr;
dcl  P_caller char(*);
dcl  P_code fixed bin (35);
dcl  P_ptr ptr;
dcl  P_dp_dir char (168);

/* External entries */

dcl  amu_$error_for_caller entry options (variable);
dcl  amu_$fdump_translate_to_temp_seg entry (ptr, ptr, ptr, fixed bin (35));
dcl  amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35));
dcl  amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr);
dcl  amu_$translate_add entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  amu_$translate_force_add entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  amu_$fdump_translate_contiguous entry (ptr, ptr, ptr, fixed bin (35));
dcl  amu_$slt_search_seg_ptr entry (ptr, ptr, char (32), ptr, fixed bin (35));
dcl  amu_$slt_search_init_seg_ptr entry (ptr, ptr, char (32), ptr, fixed bin (35));
dcl  amu_$slt_search_last_sup_seg entry (ptr, fixed bin);
dcl initiate_file_			entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  pathname_			entry (char(*), char(*)) returns(char(168));

/* External static */
dcl  amu_et_$no_def fixed bin (35) ext;
dcl  amu_et_$no_dseg fixed bin (35) ext;
dcl  amu_et_$no_slt fixed bin (35) ext;
dcl  amu_et_$no_sltnt fixed bin (35) ext;
dcl  amu_et_$trans_exists fixed bin (35) ext;
dcl error_table_$action_not_performed fixed bin (35) ext;

/* Builtins */

dcl (addr, addrel, baseno, baseptr, binary,
     divide, fixed, null, rel)	builtin;

/* Automatic */

dcl  bitcount fixed bin (24);
dcl  bound fixed bin(19);
dcl  (code, ecode) fixed bin (35);
dcl  deadproc_dir char (168);
dcl  dseg_ptr ptr;
dcl  1 temp_translation like translation;
dcl  segment_ptr ptr;
dcl  temp_ptr ptr;
%page;
/*****************************************************************************/

amu_hardcore_info_$deadproc:
     entry (P_caller, P_amu_info_ptr, P_dp_dir, P_code);

     amu_info_ptr = P_amu_info_ptr;
     deadproc_dir = P_dp_dir;

     hardcore_info.pointers.sst.fptr = null ();
     hardcore_info.pointers.sst.lptr = null ();
     hardcore_info.pointers.sstnt.fptr = null ();
     hardcore_info.pointers.sstnt.lptr = null ();
     hardcore_info.pointers.tc_data.fptr = null ();
     hardcore_info.pointers.tc_data.lptr = null ();
     hardcore_info.pointers.upt.fptr = null ();
     hardcore_info.pointers.upt.lptr = null ();
     hardcore_info.apt.foreign_ptr = null ();
     hardcore_info.apt.local_ptr = null ();
     hardcore_info.apt.count = 0;
     hardcore_info.apt.size = 0;

     process_info.pid = "0"b;
     process_info.address_map_ptr = amu_info.translation_table_ptr;
     process_info.state, process_info.idx, process_info.dbr = -1;
     process_info.apte.foreign_ptr, process_info.apte.local_ptr = null ();
     process_info.prds = process_info.apte;
     process_info.pds = process_info.apte;
     process_info.dseg = process_info.apte;
     process_info.kst = process_info.apte;

     process_info.dump_segx.first, process_info.dump_segx.last = 0;
     

     translation_ptr = addr(temp_translation);
     translation.flags = ""b;
     translation.in_perm_seg = "1"b;
     translation.in_dp_dir = "1"b;
     translation.part2.ptr = null ();
     translation.part2.lth = 0;

/* get the slt */

     call initiate_file_ (deadproc_dir, "slt", R_ACCESS, temp_ptr, bitcount, code);
     if temp_ptr = null () then do;
          if code = 0 then P_code = amu_et_$no_slt;
	else do;
	   P_code = error_table_$action_not_performed;
	   call amu_$error_for_caller (amu_info_ptr, code, P_caller,
	          "Initiating ^a.", pathname_ (deadproc_dir, "slt"));
	   end;
	return;
     end;
     code = 0;
     sltp = temp_ptr;
     segment_ptr = baseptr(7);
     translation.part1.ptr = temp_ptr;
     translation.part1.lth = divide(bitcount,36,18);
     translation.segno = fixed (baseno (segment_ptr), 17);
     call fill_ptrs_no_trans (addr (hardcore_info.pointers.slt), segment_ptr);
     call amu_$translate_add (amu_info_ptr, translation_ptr, fixed (baseno (segment_ptr), 17), code);
     if code ^= 0 then do;
	P_code = code;
	return;
     end;

/* get the name_table */     

     call initiate_file_ (deadproc_dir, "name_table", R_ACCESS, temp_ptr, bitcount, code);
     if temp_ptr = null () then do;
          if code = 0 then  P_code = amu_et_$no_sltnt;
	else do;
	   P_code = error_table_$action_not_performed;
	   call amu_$error_for_caller (amu_info_ptr, code, P_caller,
	          "Initiating ^a.", pathname_ (deadproc_dir, "name_table"));
	   end;     
	return;
     end;
     code = 0;
     segment_ptr = baseptr (8);
     names_ptr = temp_ptr;
     translation.part1.ptr = temp_ptr;
     translation.part1.lth = divide(bitcount,36,18);
     translation.segno = fixed (baseno (segment_ptr), 17);
     call fill_ptrs_no_trans (addr (hardcore_info.pointers.sltnt), segment_ptr);
     call amu_$translate_add (amu_info_ptr, translation_ptr, fixed (baseno (segment_ptr), 17), code);
     if code ^= 0 then do;
	P_code = code;
	return;
     end;

/* get definitions_ */

     call initiate_file_ (deadproc_dir, "definitions_", R_ACCESS, temp_ptr, bitcount, code);
     if temp_ptr = null () then do;
          if code = 0 then P_code = amu_et_$no_def;
	else do;
	   P_code = error_table_$action_not_performed;
	   call amu_$error_for_caller (amu_info_ptr, code, P_caller,
	          "Initiating ^a.", pathname_ (deadproc_dir, "definitions_"));
	   end;
	return;
     end;
     call get_ptr_from_slt ("definitions_", segment_ptr);
     translation.part1.ptr = temp_ptr;
     translation.part1.lth = divide(bitcount,36,18);
     translation.segno = fixed (baseno (segment_ptr), 17);
     call fill_ptrs_no_trans (addr (hardcore_info.pointers.definitions), segment_ptr);
     call amu_$translate_add (amu_info_ptr, translation_ptr, fixed (baseno (segment_ptr), 17), code);
     if code ^= 0 then do;
	P_code = code;
	return;
     end;

     call initiate_file_ (deadproc_dir, "dseg", R_ACCESS, temp_ptr, bitcount, code);
     if temp_ptr = null () then do;
        if code = 0 then P_code = amu_et_$no_dseg;
        else do;
	 P_code = error_table_$action_not_performed;
	 call amu_$error_for_caller (amu_info_ptr, code, P_caller,
	        "Initiating ^a.", pathname_ (deadproc_dir, "dseg"));
	 end;
        return;
     end;
     call get_ptr_from_slt ("dseg", segment_ptr);
     hardcore_info.dseg = fixed (baseno (segment_ptr), 15);
     dseg_ptr = temp_ptr;
     sdwp = dseg_ptr;
     bound = (binary (sdwp->sdw.bound, 14) +1) * 16; /* get number of words */
     translation.part1.ptr = dseg_ptr;
     translation.part1.lth = bound;
     translation.segno = fixed (baseno (segment_ptr), 17);
     call amu_$translate_add (amu_info_ptr, translation_ptr, (translation.segno), code);
     if code ^= 0 then do;
	P_code = code;
	return;
	end;
     process_info.dseg.local_ptr = translation.part1.ptr;

     call get_and_set (dseg_ptr, "pds", hardcore_info.pds, code);
     if code ^= 0 then do;
        call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Initiating ^a.", pathname_ (deadproc_dir, "pds"));
        P_code = error_table_$action_not_performed;
        return;
        end;

     process_info.pds.local_ptr = translation.part1.ptr;

     call get_and_set (dseg_ptr, "kst", hardcore_info.kst, code);
     if code ^= 0 then do;
        call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Initiating ^a.", pathname_ (deadproc_dir, "kst"));
        P_code = error_table_$action_not_performed;
        return;
        end;

     process_info.kst.local_ptr = translation.part1.ptr;

     call amu_$slt_search_last_sup_seg (sltp, hardcore_info.hcs_count);

     P_code = 0;
     return;
%page;
/*****************************************************************************/

amu_hardcore_info_$fdump:
     entry (P_amu_info_ptr, P_caller, P_code);

	amu_info_ptr = P_amu_info_ptr;		/* copy the amu_info ptr */
	process_idx = 0;				/* all hardcore segs are in first process dumped */


/* guess at the slt seg number */
	segment_ptr = baseptr (7);
	ecode = 0;
	call amu_$fdump_translate_contiguous (amu_info_ptr, segment_ptr, addr (temp_translation), ecode);
	if ecode ^= 0 then goto error_ret;
	sltp = temp_translation.part1.ptr;
	if temp_translation.flags.in_dump = "1"b then do;
	     hardcore_info.slt.fptr = temp_translation.part1.ptr;
	     hardcore_info.slt.lptr = null ();
	     end;
	else do;
	     hardcore_info.slt.lptr = temp_translation.part1.ptr;
	     hardcore_info.slt.fptr = null ();
	     end;
	call amu_$translate_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17), code);
	if code = amu_et_$trans_exists then
	     call amu_$translate_force_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17),
		code);

				/* now guess at the slt name seg 
				   segment_ptr = baseptr (8);    */

	segment_ptr = slt.name_seg_ptr;
	ecode = 0;
	call amu_$fdump_translate_contiguous (amu_info_ptr, segment_ptr, addr (temp_translation), ecode);
	if ecode ^= 0 then goto error_ret;
	names_ptr = temp_translation.part1.ptr;
	if temp_translation.flags.in_dump = "1"b then do;
	     hardcore_info.sltnt.fptr = temp_translation.part1.ptr;
	     hardcore_info.sltnt.lptr = null ();
	     end;
	else do;
	     hardcore_info.sltnt.lptr = temp_translation.part1.ptr;
	     hardcore_info.sltnt.fptr = null ();

	     end;
	call amu_$translate_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17), code);
	if code = amu_et_$trans_exists then
	     call amu_$translate_force_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17),
		code);

	segment_ptr = slt.name_seg_ptr;

	call get_ptr_from_slt ("tc_data", segment_ptr);
	call fill_ptrs (addr (hardcore_info.pointers.tc_data), segment_ptr);
	if hardcore_info.tc_data.fptr ^= null () then do;
	     tcmp = hardcore_info.tc_data.fptr;
	     hardcore_info.apt.foreign_ptr = addrel (hardcore_info.tc_data.fptr, fixed (tcm.apt_offset, 18));
	     hardcore_info.apt.local_ptr = null ();
	     end;
	else do;
	     tcmp = hardcore_info.tc_data.lptr;
	     hardcore_info.apt.local_ptr = addrel (hardcore_info.tc_data.lptr, fixed (tcm.apt_offset, 18));
	     hardcore_info.apt.foreign_ptr = null ();
	     end;
	call amu_$translate_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17), code);
	if code = amu_et_$trans_exists then
	     call amu_$translate_force_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17),
		code);

	hardcore_info.apt.count = tcm.apt_size;
	hardcore_info.apt.size = apt_entry_size;

/* definitions_ */
	call get_ptr_from_slt ("definitions_", segment_ptr);
	call fill_ptrs (addr (hardcore_info.pointers.definitions), segment_ptr);
	call amu_$fdump_translate_contiguous (amu_info_ptr, segment_ptr, addr (temp_translation), ecode);
	call amu_$translate_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17), code);
	if code = amu_et_$trans_exists then
	     call amu_$translate_force_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17),
		code);			

 	/* sst_seg */
	call get_ptr_from_slt ("sst_seg", segment_ptr);
	call amu_$fdump_translate_to_temp_seg (amu_info_ptr, segment_ptr, addr (temp_translation), ecode);
	call fill_ptrs_no_trans (addr (hardcore_info.sst), segment_ptr);
	call amu_$translate_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17), code);
	if code = amu_et_$trans_exists then
	     call amu_$translate_force_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17),
		code);

/* sst_names_ */
	call get_ptr_from_slt ("sst_names_", segment_ptr);
	call fill_ptrs (addr (hardcore_info.sstnt), segment_ptr);
	call amu_$translate_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17), code);
	if code = amu_et_$trans_exists then
	     call amu_$translate_force_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17),
		code);

	call get_ptr_from_slt ("prds", segment_ptr);
	hardcore_info.prds = fixed (baseno (segment_ptr), 15);
	call get_ptr_from_slt ("dseg", segment_ptr);
	hardcore_info.dseg = fixed (baseno (segment_ptr), 15);

	call get_ptr_from_slt ("pds", segment_ptr);
	hardcore_info.pds = fixed (baseno (segment_ptr), 15);

    if exists_unpaged_page_table (segment_ptr) then do;
       call fill_ptrs (addr (hardcore_info.upt), segment_ptr);
       call amu_$translate_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17), code);
       if code = amu_et_$trans_exists then
          call amu_$translate_force_add (amu_info_ptr, addr (temp_translation), fixed (baseno (segment_ptr), 17), code);
       hardcore_info.unpaged_page_tables = fixed (baseno (segment_ptr),15);
       end;
    else do;
       hardcore_info.upt.fptr, hardcore_info.upt.lptr = null();
       end;

    call get_ptr_from_slt ("kst_seg", segment_ptr);
    hardcore_info.kst = fixed (baseno (segment_ptr), 15);
    call amu_$slt_search_last_sup_seg (sltp, hardcore_info.hcs_count);

    segment_ptr = amu_$definition_ptr (amu_info_ptr, "active_all_rings_data", "stack_base_segno", code);
	if code = 0 then do;
	     call amu_$do_translation (amu_info_ptr, fixed (baseno (segment_ptr), 17), addr (hardcore_info.segno.stack_0),
		fixed (rel (segment_ptr), 18), 1, code);
	     if code ^= 0 then do;
		P_code = code;
		return;
	     end;
	end;
	else do;     
						/* may be an early dump, check for inzr_stk0 */
	     call amu_$slt_search_seg_ptr (sltp, names_ptr, "inzr_stk0", segment_ptr, code);
	     if code ^= 0 then do;
		call amu_$slt_search_init_seg_ptr (sltp, names_ptr, "inzr_stk0", segment_ptr, code);
                    code = 0;				 /* Totaly ignore this error code */
	     end;
	     hardcore_info.segno.stack_0 = fixed(baseno (segment_ptr),17);
	     amu_info.early_dump = "1"b;
	end;

    P_code = 0;
    return;

error_ret:
    P_code = ecode;
    return;
%page;
/*****************************************************************************/

amu_hardcore_info_$set_cur_ptrs:
     entry (P_amu_info_ptr, P_ptr);
	amu_info_ptr = P_amu_info_ptr;
	hardcore_cur_ptr = P_ptr;

	if hardcore_info.pointers.upt.lptr ^= null then
	   hardcore_cur.uptp = hardcore_info.pointers.upt.lptr;
	else hardcore_cur.uptp = hardcore_info.pointers.upt.fptr;

	if hardcore_info.pointers.slt.lptr ^= null then
	     hardcore_cur.sltp = hardcore_info.pointers.slt.lptr;
	else hardcore_cur.sltp = hardcore_info.pointers.slt.fptr;

	if hardcore_info.pointers.sltnt.lptr ^= null then
	     hardcore_cur.sltntp = hardcore_info.pointers.sltnt.lptr;
	else hardcore_cur.sltntp = hardcore_info.pointers.sltnt.fptr;

	if hardcore_info.pointers.definitions.lptr ^= null then
	     hardcore_cur.defp = hardcore_info.pointers.definitions.lptr;
	else hardcore_cur.defp = hardcore_info.pointers.definitions.fptr;

	if hardcore_info.pointers.sst.lptr ^= null then
	     hardcore_cur.sstp = hardcore_info.pointers.sst.lptr;
	else hardcore_cur.sstp = hardcore_info.pointers.sst.fptr;

	if hardcore_info.pointers.tc_data.lptr ^= null then
	     hardcore_cur.tc_datap = hardcore_info.pointers.tc_data.lptr;
	else hardcore_cur.tc_datap = hardcore_info.pointers.tc_data.fptr;

	if hardcore_info.pointers.sstnt.lptr ^= null then
	     hardcore_cur.sstntp = hardcore_info.pointers.sstnt.lptr;
	else hardcore_cur.sstntp = hardcore_info.pointers.sstnt.fptr;

  return;
%page;
/*****************************************************************************/

fill_ptrs:
     proc (hpdp, dp);
dcl  1 hard_ptr_data like hardcore_info.pointers.slt based (hpdp);
dcl  hpdp ptr;
dcl  dp ptr;
	call amu_$fdump_translate_contiguous (amu_info_ptr, dp, addr (temp_translation), ecode);
	go to fill_ptrs_common;

/*****************************************************************************/

fill_ptrs_no_trans:
     entry (hpdp, dp);

fill_ptrs_common:
	if temp_translation.flags.in_dump = "1"b then do;
	     hard_ptr_data.fptr = temp_translation.part1.ptr;
	     hard_ptr_data.lptr = null ();
	     end;
	else do;
	     hard_ptr_data.lptr = temp_translation.part1.ptr;
	     hard_ptr_data.fptr = null ();
	     end;
     end fill_ptrs;
%page;
/*****************************************************************************/

exists_unpaged_page_table:  proc(segment_ptr) returns(bit(1));

dcl segment_ptr			ptr;
dcl code				fixed bin(35);

    segment_ptr = null();
    code = 0;
    call amu_$slt_search_seg_ptr (sltp, names_ptr, "unpaged_page_tables", segment_ptr, code);
    if code = 0 then return("1"b);
    else return("0"b);

end exists_unpaged_page_table;
%page;
/*****************************************************************************/

get_and_set:
     proc (dseg_ptr, temp_name,hardcore_num, code);

dcl code fixed bin(35);
dcl dseg_ptr ptr;
dcl temp_name char (32);
dcl hardcore_num fixed bin (15);

dcl bound fixed bin(19);
dcl sdwp ptr;

     code = 0;
     call initiate_file_ (deadproc_dir, temp_name, R_ACCESS, temp_ptr, bitcount, code);
     if temp_ptr = null () then do;
	return;
     end;
     if temp_name = "kst" then temp_name = "kst_seg";
     call get_ptr_from_slt (temp_name, segment_ptr);
     hardcore_num = fixed (baseno (segment_ptr), 15);
     sdwp = addrel(dseg_ptr, hardcore_num*2);
     bound = (binary (sdwp->sdw.bound, 14) +1) * 16; /* get number of words */
     translation.part1.lth = bound;
     translation.part1.ptr = temp_ptr;
     translation.segno = fixed (baseno (segment_ptr), 17);
     call amu_$translate_add (amu_info_ptr, translation_ptr, (translation.segno), code);
     if code ^= 0 then do;
	return;
     end;
     code = 0;
end get_and_set;
%page;
/*****************************************************************************/

get_ptr_from_slt:
     proc (segment_name, temp_ptr);
dcl  test_name char (32);
dcl  temp_ptr ptr;
dcl  segment_name char (*);
dcl  seg_ptr ptr;
	temp_ptr = null ();
	test_name = segment_name;

	call amu_$slt_search_seg_ptr
	     (sltp, names_ptr, test_name, temp_ptr, ecode);

	if ecode ^= 0 then do;
	     seg_ptr = amu_$definition_ptr (amu_info_ptr, "active_all_rings_data", "stack_base_segno", code);
	     if code = 0 then do;
		call amu_$do_translation (amu_info_ptr, fixed (baseno (seg_ptr), 17), addr (hardcore_info.segno.stack_0),
		     fixed (rel (seg_ptr), 18), 1, code);
		if code ^= 0 then do;
		     P_code = code;
		     return;
		end;
	     end;
	     else do;     
						/* may be an early dump, check for inzr_stk0 */
		call amu_$slt_search_seg_ptr (sltp, names_ptr, "inzr_stk0", seg_ptr, code);
		if code ^= 0 then do;
		     call amu_$slt_search_init_seg_ptr (sltp, names_ptr, "inzr_stk0", seg_ptr, code);
		     code = 0;		          /* Totaly ignore this code */
		end;
	     end;
	     hardcore_info.segno.stack_0 = fixed(baseno (segment_ptr),17);
	     amu_info.early_dump = "1"b;
	     if amu_info.early_dump then return;
	     else goto error_ret;
	end;

     end get_ptr_from_slt;
%page;%include access_mode_values;
%page;%include amu_hardcore_info;
%page;%include amu_info;
%page;%include amu_fdump_info;
%page;%include amu_process_info;
%page;%include amu_translation;
%page;%include sdw;
%page;%include slt;
%page;%include tcm;
%page;%include hc_lock;

     end amu_hardcore_info_;




		    amu_info_.pl1                   02/16/88  1453.7r w 02/16/88  1409.6       37323



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_info_: proc ();

	return;					/* not an entrypoint */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* This procedure is in charge of creating and destroying amu_info structures

   09/06/80 W. Olin Sibert
*/

dcl  (
     P_amu_info_ptr pointer,
     P_type fixed bin
     ) parameter;

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;
dcl  new_aip  pointer;
dcl  code fixed bin (35);
dcl  amu_$check_info entry (pointer);
dcl  amu_$fdump_mgr_really_terminate entry (ptr, fixed bin (35));
dcl  amu_$deadproc_term entry (ptr, fixed bin (35));
dcl  get_system_free_area_ entry () returns (pointer);

dcl  amu_reset bit (1) init ("0"b);


dcl  (clock, null) builtin;

%page;

amu_info_$create:
     entry (P_amu_info_ptr, P_type);

/* This entrypoint allocates and initializes an amu_info */

	system_area_ptr = get_system_free_area_ ();

	allocate amu_info in (system_area) set (amu_info_ptr);

	amu_info.version = AMU_INFO_VERSION_2;
	amu_info.type = P_type;
	amu_info.time_created = clock ();
	amu_info.area_ptr = system_area_ptr;		/* so we can use amu_area from now on */
	amu_info.translation_table_ptr = null ();
	amu_info.fdump_info_ptr = null ();
	amu_info.hardcore_info_ptr = null ();
	amu_info.process_info_ptr = null ();
	amu_info.definitions_info_ptr = null ();
	amu_info.early_dump = "0"b;

/* we have no Idea how to chain this entry so null the chain pointer and let some one who called chain it in (some one that cares */

	amu_info.chain.prev = null ();
	amu_info.chain.next = null ();


	allocate definitions_info in (amu_area) set (amu_info.definitions_info_ptr);
	definitions_info.hash_buckets (*) = null;
	definitions_info.t_ptrs (*).val = null;
	do t_ptr_indx = 0 to 9;
	     definitions_info.t_ptrs (t_ptr_indx).name = init_ptr_names (t_ptr_indx);
	end;

	allocate hardcore_info in (amu_area) set (amu_info.hardcore_info_ptr);

	amu_info.copy_chain = null ();		/* no copies created yet */

	amu_info.process_info_ptr = null ();		/* not specified yet */
	amu_info.process_idx = -1;


	P_amu_info_ptr = amu_info_ptr;		/* all done */
	return;

%page;

amu_info_$destroy:
     entry (P_amu_info_ptr);

/* This entry destroys an amu_info */

	amu_info_ptr = P_amu_info_ptr;
	new_aip = null ();
	call amu_$check_info (amu_info_ptr);

	if amu_info.type = FDUMP_TYPE | amu_info.type = FDUMP_PROCESS_TYPE then
	     if amu_info.fdump_info_ptr ^= null () then call amu_$fdump_mgr_really_terminate (amu_info_ptr, code);

	if amu_info.type = SAVED_PROC_TYPE then call amu_$deadproc_term (amu_info_ptr, code);


	system_area_ptr = amu_info.area_ptr;		/* for when it is freed later */

/* now unthread it before doing anything */
/* return prev translation in chain if there is one */
/* if no prev return next, */
/* if next is null then return the null ptr */

	if amu_info.chain.prev ^= null () then do;
	     amu_info.chain.prev -> amu_info.chain.next = amu_info.chain.next;
	     new_aip = amu_info.chain.prev;
	     end;
	if amu_info.chain.next ^= null () then amu_info.chain.next -> amu_info.chain.prev = amu_info.chain.prev;
	if new_aip = null () then new_aip = amu_info.chain.next;

	if amu_info.translation_table_ptr ^= null () then /* free anything which may have been allocated */
	     free translation_table in (system_area);

	if amu_info.hardcore_info_ptr ^= null () then free hardcore_info in (system_area);

/* This will delete one amu_info and default to the last translation in
   The chain if it is valid null if not */

	free amu_info in (system_area);

	P_amu_info_ptr = new_aip;

	return;					/* all done for this entry */

%page;
%include amu_info;
%page;
%include amu_translation;
%page;
%include amu_hardcore_info;
%page;
%include amu_fdump_info;
%page;
%include amu_definitions;
%page;
%include sl_info;


     end amu_info_;




		    amu_kst_util_.pl1               02/13/85  0937.5rew 02/13/85  0903.8       99963



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_kst_util_: proc ();

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* *	Utility procedure for AMU, used to manipulate a KST in the local
   *	address space. Algorithms cribbed from kstsrch.pl1, get_kstep.pl1.
   *	Because the copy of the KST we are searching may not begin at the
   *	beginning of a segment, much hair must be gone through to get the
   *	right values of pointers and offsets; this is the reason for the
   *	high density of addrels in the code */

/* 03/12/80 W. Olin Sibert */
/* Modified 01/12/85 by B. Braun to add entry $expand_uid_path.

/* parameters */

dcl  (
     P_expand_path char(*),
     P_kstp pointer,				/* pointer to KST or copy thereof */
     P_uid bit (36) aligned,
     P_kste_offset fixed bin (18),			/* offset of interesting KST entry */
     P_uid_path (16) bit (36) aligned,
     P_segno fixed bin,
     P_code fixed bin (35)
     ) parameter;

/* automatic */

dcl code				fixed bin (35);
dcl count				fixed bin;
dcl depth				fixed bin;
dcl dirname			char(168);
dcl  dlen				fixed bin;
dcl ename				char(32);
dcl hash_idx			fixed bin;
dcl i				fixed bin;
dcl idx				fixed bin;
dcl jdx				fixed bin;
dcl kste_offset			fixed bin(18);
dcl par_kste_offset			fixed bin (18);
dcl par_segno			fixed bin;
dcl segno				fixed bin;
dcl tmr				bit(1);
dcl  1 tsdw			like sdw aligned;
dcl uid				bit (36) aligned;
dcl uid_path (16)			bit (36) aligned;
dcl (rzdp, rzdsp) ptr;

/* internal static */

dcl ROOT_UID                            bit(36) aligned init("777777777777"b3) int static options(constant);

/* external entries */

dcl amu_$kst_util_uid_to_kstep	entry (ptr, bit(36) aligned, fixed bin (18), fixed bin(35));
dcl get_temp_segment_		entry (char(*), ptr, fixed bin(35));
dcl phcs_$initiate			entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl phcs_$ring_0_peek		entry (ptr, ptr, fixed bin);
dcl phcs_$terminate_noname		entry (ptr, fixed bin (35));
dcl release_temp_segment_		entry (char(*), ptr, fixed bin(35));
dcl ring0_get_$segptr		entry (char (*), char (*), ptr, fixed bin (35));

/* external static */

dcl (
     error_table_$noentry,
     error_table_$invalidsegno,
     error_table_$action_not_performed
     )				fixed bin (35) external static;

/* builtins */

dcl (addr, addrel, baseno, binary, dimension, 
     fixed, hbound, lbound, mod, null, 
     pointer, ptr, rel, rtrim, unspec)		builtin;

dcl cleanup			condition;
%page;
/*****************************************************************************/

amu_kst_util_$expand_uid_path:   entry (P_kstp, P_uid_path, P_expand_path, P_code);

/* Determines the pathname, given a uids for the path.
     P_kstp           pointer to the kst (input)
     P_uid_path       array of uids for a pathname. This can be obtained via a
		  call to kst_util_$uid_to_uid_path (input)
     P_expand_path    The pathname (output)
     P_code	  Standard error code (output)
*/

    kstp = P_kstp;
    uid_path = P_uid_path;
    P_expand_path, dirname, ename = "";			/* start with null names */
    tmr = "0"b;
    P_code, code = 0;
    rzdsp, rzdp, dp = null();
    on cleanup begin;
       if dp ^= null() then call release_temp_segment_ ("amu_kst_util_", dp, (0));
       end;

    call get_temp_segment_ ("amu_kst_util_", dp, code);
    call ring0_get_$segptr ("", "dseg", rzdsp, code); /* get ptr to our dseg */

    /* Have to special case the root */

    if (uid_path(1) = ROOT_UID) & (uid_path(2) = ""b) then do;
       /* This is the ROOT segment */
       dirname = ">";
       goto RET;
       end;

    /* now go from the root+1 and form the complete pathname of target entry */

    do i = 2 to  hbound(uid_path, 1) while (uid_path (i) ^= ""b);
       if dirname = "" then    /* looking at the root, this is what we start with. */
          call phcs_$initiate (">", ename, "", 0, 0, rzdp, code);
       else call phcs_$initiate (dirname, ename, "", 0, 0, rzdp, code);
       if rzdp = null then go to RET1;		/* if some problem, get out of here */
       call phcs_$ring_0_peek (rzdp, dp, 1);	/* cause seg fault */
FTSDW:
       call phcs_$ring_0_peek (addr (rzdsp -> sdwa (fixed (baseno (rzdp)))), addr (tsdw), 2);
       if ^tsdw.df then goto FTSDW;		/* we must be faulted */
       dlen = fixed (tsdw.bound, 15) * 16 + 16;
       call phcs_$ring_0_peek (rzdp, dp, dlen);	/* copy dir seg out of ring 0 */
       tmr = "0"b;
       do ep = ptr (dp, dp -> dir.entryfrp) repeat ptr (dp, ep -> entry.efrp) while (dp ^= ep & tmr = "0"b);
	if ep -> entry.uid = uid_path(i) then do;	/* found right one */
	   tmr = "1"b;			/* set terminate cond */
	   dirname = rtrim (dirname) || ">" || addr (entry.primary_name) -> names.name;
	   call phcs_$terminate_noname (rzdp, code);
					/* terminate this ref */
	   end;
	end;
       if ^tmr then do;			/* didn't find name */
RET1:
          dirname = rtrim (dirname) || ">" || "CANNOT-COMPLETE-PATH";
          go to RET;
	end;
       end;    /* end of uid_path loop */

     code = 0;
RET:
     if dp ^= null() then call release_temp_segment_ ("amu_kst_util_", dp, (0));
     P_code = code;
     P_expand_path = dirname;              /* copy pathname */
     return;
%page;
/*****************************************************************************/

amu_kst_util_$uid_to_kstep:
     entry (P_kstp, P_uid, P_kste_offset, P_code);

/* *	This entry returns the offset of the KSTE with the specified UID,
   *	or returns error_table_$noentry if it's not there */

	kstp = P_kstp;
	uid = P_uid;

	if uid = ""b then do;			/* can't search for zero UID */
	     P_kste_offset = 0;
	     code = error_table_$action_not_performed;
	     goto MAIN_RETURN;
	     end;

	hash_idx = mod (binary (uid, 36), dimension (kst.uid_hash_bucket, 1));

	count = 0;				/* make sure we don't loop too long */
	kste_offset = binary (kst.uid_hash_bucket (hash_idx), 18);
	kstep = addrel (kstp, kste_offset);
	do kstep = addrel (kstp, kste_offset) repeat (addrel(kstp,kste.fp))
	     while (kste.fp ^= "0"b);			/* search until we find one */

	     if kste.uid = ""b then do;		/* BAD */
		P_kste_offset = 0;
		code = error_table_$action_not_performed;
		goto MAIN_RETURN;
		end;

	     if kste.uid = uid then do;		/* got it */
		P_kste_offset = fixed(rel(kstep),18) - fixed(rel(kstp),18);
		code = 0;
		goto MAIN_RETURN;
		end;

	     count = count + 1;
	     if count > 4096 then do;
		P_kste_offset = 0;
		code = error_table_$action_not_performed;
		goto MAIN_RETURN;
		end;
	end;					/* of search loop */

/* OK try the hard way */
	do i = lbound(kst_entry,1) to hbound(kst_entry,1);
	     if P_uid = kst_entry (i).uid then do;
		kstep = addr(kst_entry (i));
		P_kste_offset = fixed(rel(kstep),18) - fixed(rel(kstp),18);
		code = 0;
		goto MAIN_RETURN;
	     end;
	end;
	P_kste_offset = 0;
	code = error_table_$noentry;
	goto MAIN_RETURN;				/* end of code for $uid_to_kstep entry */

%page;
/*****************************************************************************/

amu_kst_util_$uid_to_uid_path:
     entry (P_kstp, P_uid, P_uid_path, P_code);

/* *	This entry returns the UID pathname of the parent of the segment
   *	identified by P_uid, of a non-zero error code. The UID path is derived
   *	by chasing up through the KST, using the branch pointer in a KSTE to
   *	get the segment number of its parent. */

	kstp = P_kstp;
	uid = P_uid;

	call amu_$kst_util_uid_to_kstep (kstp, uid, kste_offset, P_code);
						/* first, find it */
	if P_code ^= 0 then return;			/* sorry, nope */

	goto UID_PATH_COMMON;			/* otherwise join common code */

/*****************************************************************************/

amu_kst_util_$segno_to_uid_path:
     entry (P_kstp, P_segno, P_uid_path, P_code);

	kstp = P_kstp;
	segno = P_segno;

	kste_offset = validate_segno (segno);		/* see if it's OK */
	if code ^= 0 then goto MAIN_RETURN;		/* no good */

	goto UID_PATH_COMMON;

/*****************************************************************************/

amu_kst_util_$segno_to_uid:
	entry (P_kstp,P_segno,P_uid,P_code);

	kstp = P_kstp;
	segno = P_segno;
	kste_offset = validate_segno (segno);		/* see if it's OK */
	if code ^= 0 then goto MAIN_RETURN;		/* no good */
	kstep = addrel(kstp,kste_offset);
	P_uid = kste.uid;
	goto MAIN_RETURN;
	

	
UID_PATH_COMMON:					/* Now, try to find all our parents */
	depth = 1;
	kstep = addrel (kstp, kste_offset);		/* point to the original KSTE */
	uid_path (depth) = kste.uid;
	do while (kste.uid ^= "777777777777"b3);	/* loop upwards till we find the ROOT */
	     if unspec (kste.entryp) = ""b then do;	/* can't happen, of course */
		code = error_table_$action_not_performed;
		goto MAIN_RETURN;
		end;

	     par_segno = binary (baseno (kste.entryp));
	     par_kste_offset = validate_segno (par_segno);
	     if code ^= 0 then do;			/* par_segno is invalid?? */
		code = error_table_$action_not_performed;
		goto MAIN_RETURN;
		end;

	     kstep = addrel (kstp, par_kste_offset);	/* find our parent */
	     depth = depth + 1;			/* and record his UID */
	     if depth > hbound (uid_path, 1) then do;	/* too many???? */
		code = error_table_$action_not_performed;
		goto MAIN_RETURN;
		end;

	     uid_path (depth) = kste.uid;		/* this is parent UID -- continues until we hit the root */
	end;

	jdx = 1;					/* now that we have as many UIDs as we're gonna get, */
	do idx = depth to 1 by -1;			/* let's put them in our return argument */
	     P_uid_path (jdx) = uid_path (idx);
	     jdx = jdx + 1;
	end;

	do idx = jdx to hbound (P_uid_path, 1);		/* and put zeros in the rest */
	     P_uid_path (idx) = ""b;
	end;

	code = 0;					/* all done for this */
	goto MAIN_RETURN;


MAIN_RETURN:					/* general-purpose exit */
	P_code = code;				/* copy the error code */
	return;					/* and return */

%page;
/*****************************************************************************/

validate_segno:
     proc (P_segno) returns (fixed bin (18));

/* *	This procedure verifies that the segment number supplied is a valid
   *	one according to the KST, returning the KSTE offset if it is OK, and
   *	setting code and returning zero if it is not. */

dcl  P_segno fixed bin parameter;

dcl  offset fixed bin (18);

	if P_segno < kst.lowseg | P_segno > kst.highseg then do;
INVALIDSEGNO:
	     code = error_table_$invalidsegno;
	     return (0);
	     end;

	offset = binary (rel (addr (pointer (kstp, 0) -> kst.kst_entry (P_segno))), 18);
						/* find the right KSTE */

	if unspec (addrel (kstp, offset) -> kste.entryp) = ""b then goto INVALIDSEGNO;
						/* no branch ptr means no segno */

	code = 0;					/* it's OK */
	return (offset);

     end validate_segno;
%page;%include dir_entry;
%page;%include dir_header;
%page;%include dir_name;
%page;%include kst;
%page;%include sdw;

     end;						/* amu_kst_util_ */




		    amu_parse_ptr_args_.pl1         07/12/88  1444.6rew 07/12/88  1433.6      251676



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-12-16,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-17,Fawcett), install(87-07-28,MR12.1-1049):
     Changed to accept decimal integers with the "-for" control argument
     instead of accepting only octal values.
  2) change(87-01-13,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-17,Fawcett), install(87-07-28,MR12.1-1049):
     Correctly interpret arg to the "-pointers" control arg with the "mc"
     request (phx19327).
  3) change(87-02-11,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-17,Fawcett), install(87-07-28,MR12.1-1049):
     Determine if referenced segment name is a temp ptr name before
     attempting to translate it to a segno for reading users deadprocs.
  4) change(87-10-29,Parisek), approve(88-03-09,MCR7861),
     audit(88-07-08,Farley), install(88-07-12,MR12.2-1055):
     Correct bug in determining temporary pointer values when analyzing
     dead_procs.
  5) change(88-02-22,Parisek), approve(88-03-09,MCR7861),
     audit(88-07-08,Farley), install(88-07-12,MR12.2-1055):
     In checking for "ring_N" or "stack_N" segs, make sure there are not more
     characters in the segment name such as "stack_0_data". We don't want to
     think stack_0_data is really stack_0.
                                                   END HISTORY COMMENTS */


amu_parse_ptr_args_:   proc ();

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* Modified 10 Jan 85 by BLB to correct the check_name procedure to check for 
   non-hardcore names too.
*/

/* Parameters */

dcl a_code fixed bin (35);
dcl a_segname char(*);
dcl segname  char(32);
dcl segname_entry	bit(1) init("0"b);
dcl a_nargs fixed bin;
dcl a_va char(*);
dcl a_amu_info_ptr ptr;
dcl a_offset fixed bin (18);
dcl a_segno fixed bin;
dcl sci_ptr ptr;

/* Automatic */

dcl al fixed bin (21);
dcl ap ptr;
dcl arg char (al) based (ap);
dcl argno fixed bin;
dcl code fixed bin (35);
dcl doing fixed bin;
dcl error_msg char(256) var;
dcl 1 hard_ptr_space like hardcore_cur;
dcl indirect_sw bit (1);
dcl nargs fixed bin;
dcl segno fixed bin (17);

dcl temp_ptr ptr;

/* External */

dcl amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr);
dcl amu_$definition_get_prn entry (ptr, char (*), ptr, fixed bin (35));
dcl amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35));
dcl amu_$dp_name_to_segno entry (ptr, char(*), fixed bin, fixed bin(35));
dcl amu_$fdump_mpt_temp_change_idx entry (ptr, fixed bin);
dcl amu_$fdump_mpt_revert_idx entry (ptr);
dcl amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr);
dcl amu_$return_val_per_process entry (ptr, fixed bin) returns (bit (1));
dcl amu_$slt_search_init_seg_ptr entry (ptr, ptr, char(*), ptr, fixed bin(35));
dcl amu_$slt_search_seg_ptr entry (ptr, ptr, char(*), ptr, fixed bin(35));
dcl (cv_oct_check_, cv_dec_check_) entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl ioa_$rsnnl		entry() options(variable);

dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));

/* Error tables */

dcl amu_et_$bad_segno fixed bin (35) ext static;
dcl amu_et_$error_indirect fixed bin (35) ext static;
dcl amu_et_$invalid_seq fixed bin (35) ext static;
dcl amu_et_$negative_offset fixed bin (35) ext static;
dcl amu_et_$no_segname fixed bin (35) ext static;
dcl amu_et_$no_va_specified fixed bin (35) ext static;
dcl amu_et_$not_its_ptr fixed bin (35) ext static;
dcl amu_et_$not_octal_offset  fixed bin (35) ext static;
dcl amu_et_$not_octal_off_mod  fixed bin (35) ext static;
dcl amu_et_$not_octal_range  fixed bin (35) ext static;
dcl amu_et_$not_octal_segno fixed bin (35) ext static;
dcl amu_et_$null_ptr fixed bin (35) ext static;
dcl amu_et_$specified_modifier  fixed bin (35) ext static;
dcl amu_et_$modifier_before_range  fixed bin (35) ext static;
dcl error_table_$noentry   fixed bin (35) ext static;
dcl error_table_$seg_not_found   fixed bin (35) ext static;

dcl (addr, baseno, baseptr, fixed, index, 
     lbound, length, null, rel, rtrim,
     search, substr, verify)		builtin;
%page; 
amu_parse_ptr_args_$resolve_va: entry(sci_ptr, a_amu_info_ptr, a_va, a_segno, a_offset, a_code);

/* This entry resolves the virtual address to its segment number and offset.
   sci_ptr                 subsystem pointer (input), 
   a_amu_info_ptr	       pointer to amu_info structure (input),
   a_va		       virtual address construct (input),
   a_segno	       segment number (output),
   a_offset	       segment offset (output),
   a_code		       standadrd error code.
*/

dcl error_found bit(1);

    amu_info_ptr = a_amu_info_ptr;
    code = 0;
    va_args_ptr = addr(va_args);
    va.segno, va.offset, va.offset_modifier,
    va.range, va.va_position, va.ecode  = 0;
    va.va_switches = "0"b;
    va.error_msg, va.va_string = "";
    va.resolved_va = null();
    error_found = "0"b;  
    call get_va(a_va, va_args_ptr, error_found, indirect_sw);  
    if error_found then do;	
       if va.ecode = 0 then va.ecode = amu_et_$invalid_seq;
       end;
    else do;
       if indirect_sw then call resolve_indirection(va_args_ptr, error_found);
       if error_found then do;	
          if va.ecode = 0 then va.ecode = amu_et_$invalid_seq;
          end;       
       end;

    a_segno = va.segno;
    a_offset = va.offset;
    a_code = va.ecode;
return;
%page; 
amu_parse_ptr_args_$get_segno: entry(sci_ptr, a_amu_info_ptr, a_segname, a_segno, a_code);

/* This entry gets the segment number assoctiated with a segment name.
   sci_ptr                 subsystem pointer (input), 
   a_amu_info_ptr	       pointer to amu_info structure (input),
   a_segname	       segment name (input),
   a_segno	       segment number (output),
   a_code		       standadrd error code.
*/

    amu_info_ptr = a_amu_info_ptr;
    segname = "";
    segname = a_segname;
    code = 0;
    error_msg = "";
    call check_name(segname, temp_ptr, error_msg, code);  
    if error_msg ^= "" | code ^= 0 then do;	
       if code ^= 0 then code = amu_et_$no_segname;
       end;
    else do;
       segno = fixed (baseno (temp_ptr), 17);
       end;

    a_segno = segno;
    a_code = code;
return;
%page;
amu_parse_ptr_args_$get_va_args: entry(sci_ptr, a_amu_info_ptr, a_arg, a_nargs, a_va_args);

    argno = 1;
    goto COMMON_ARG;

amu_parse_ptr_args_$get_va_args_given_start: entry(sci_ptr, a_amu_info_ptr, a_arg, a_start_arg, a_nargs, a_va_args);

    argno = a_start_arg;
    goto COMMON_ARG;


/* These entrypoints check and validates VA related arguments and fill in the appropriate parts of the
   va_args structure. get_va_args parses the request line, determining the VA, range and offset modifier
   and fills in the va_args structure.

   sci_ptr                 subsystem pointer (input), 
   a_amu_info_ptr	       pointer to amu_info structure (input),
   a_arg		       pointer to the argument list to be examined (input),
   a_nargs	       number of arguments in the list (input),
   a_va_args	       pointer to va_args structure (input)

For the get_va_args_given_start entry:

   a_start_arg             index to which argument to start in the list (input)   
*/
dcl a_arg				ptr;
dcl a_va_args			ptr;
dcl a_start_arg			fixed bin;

dcl (
     GETTING_VA			init(1),
     GETTING_MODIFIER		init(2),
     GETTING_RANGE			init(3),
     DONE				init(4)

     )				fixed bin int static options(constant);
dcl NUMBERS			char(10) init("0123456789") int static options(constant);
dcl forsw bit (1);

COMMON_ARG:

    amu_info_ptr = a_amu_info_ptr;
    va_args_ptr = a_va_args;
    ap = a_arg;
    nargs = a_nargs;
    forsw = "0"b;

    doing = GETTING_VA;
    do while ((argno <= nargs) & (doing ^= DONE));
       call ssu_$arg_ptr (sci_ptr, argno, ap, al);
       if arg = "-for" then forsw = "1"b;
       call parse_arg(a_va_args, doing, arg, nargs, argno);
       end;
  
    if doing = GETTING_VA then do;
       if va.ecode = 0 then va.ecode = amu_et_$no_va_specified;
       else if va.ecode = error_table_$noentry then va.ecode = error_table_$seg_not_found;
       goto ERROR_RETURN;
       end;
   else if va.ecode ^= 0 | va.error_msg ^= "" then goto ERROR_RETURN;

END_GET_VA_ARGS:

    call finish_va_resolution(a_va_args);

ERROR_RETURN:
    return;
%page;
bad_segno: proc(segno, ecode) returns(bit(1));

dcl segno fixed bin(18);
dcl ecode fixed bin(35);
dcl max_segno fixed bin (18) int static options (constant) init (4095);
	 

    ecode = 0;
    if segno = fixed (baseno (null ()), 18) then		/* null ptr */
       ecode = amu_et_$null_ptr;
    else if segno > max_segno then ecode = amu_et_$bad_segno;
    else if segno < 0 then ecode = amu_et_$bad_segno;

    return(ecode^=0);

end bad_segno;
%page;
check_name:
     proc (segment_name, temp_ptr, error_msg, code);

dcl code				fixed(35);
dcl error_msg			char(*) var;
dcl segment_name			char (*);
dcl temp_ptr			ptr;

dcl i				fixed bin;
dcl ignore			fixed bin;
dcl stack_idx			fixed bin;
dcl test_name			char (32);

    code = 0;
    error_msg = "";
    temp_ptr = null();
    test_name = segment_name;
    hardcore_cur_ptr = addr (hard_ptr_space);
    if substr (test_name, 1, 5) = "ring_" | substr (test_name, 1, 6) = "stack_" then do;
        i = search (test_name, "_");
        if length (rtrim(test_name)) = (i+1) then do;	/* Is there chars after the octal ring_ or stack_ seg
 */						/* If so, then it's not ring_ or stack_ seg (ie: stack_0_data) */
	   stack_idx = cv_oct_check_ (substr (test_name, i + 1), code);
	   if code ^= 0 then do;
	        call ioa_$rsnnl ("The ^[ring^;stack^] number is not octal.", error_msg, ignore, (substr(test_name, 1,5) = "ring_")); 
	        return;
	   end;
	   else do;
	        if stack_idx < 0 | stack_idx > 7 then do;
		   call ioa_$rsnnl ("The ^[ring^;stack^] specified does not exist.", error_msg, ignore, (substr(test_name, 1,5) = "ring_")); 
		   return;
	        end;
	   end;
						/* appears to be a valid stack_ring so return the pointer to it */
	   if amu_info.early_dump & stack_idx >0 then do;
	        code = error_table_$seg_not_found;
	        return;
	   end;
	   temp_ptr = baseptr (hardcore_info.segno.stack_0 + stack_idx);
	   return;
        end;
    end;

    call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr);
    call amu_$slt_search_seg_ptr (hardcore_cur.sltp, hardcore_cur.sltntp, test_name, temp_ptr, code);
    if code ^= 0 then do;
       if amu_info.early_dump then 
          call amu_$slt_search_init_seg_ptr (hardcore_cur.sltp, hardcore_cur.sltntp, test_name, temp_ptr, code);
	end;

    if code ^= 0 then do;  /* not a hardcore segment name */
dcl segno fixed bin;
       if amu_info.type = SAVED_PROC_TYPE then do;
	call amu_$definition_get_prn (amu_info_ptr, test_name, temp_ptr, code);
						/* see if test_name is a temp ptr */
	if code = 0 then do;
	     if temp_ptr = null then do;
		va.ecode = amu_et_$invalid_seq;
		call ioa_$rsnnl ("Temporary ptr specified is null. ^a", va.error_msg, ignore, test_name);
		return;
	     end;
	     else do;
		call amu_$dp_name_to_segno (amu_info_ptr, test_name, segno, code);
		if code = 0 then temp_ptr = baseptr(segno);
	     end;
	end;
       end;
       else if amu_info.type = FDUMP_TYPE | amu_info.type = FDUMP_PROCESS_TYPE then do;
          end;
       end;
  

end check_name;
%page;
finish_va_resolution:  proc(va_arg_ptr);

dcl  va_arg_ptr ptr;
dcl  1 va based(va_arg_ptr) like va_args;

dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  arg char (argl) based (argp);

    if bad_segno(va.segno, va.ecode) then do;
       call ssu_$arg_ptr (sci_ptr, va.va_idx, argp, argl);
       va.error_msg = arg;
       goto END_FINISH_VA;
       end;

    if va.valid_modifier & ^(va.modifier_before_indirect) then do;   
       va.offset = va.offset + va.offset_modifier;
       if va.offset < 0 then do;
	va.ecode = amu_et_$negative_offset;
	va.error_msg = va.va_string;
	goto END_FINISH_VA;
	end;
       end;

/*  RIGHT HERE must check the final segno|offset to see if its in the fdump */

END_FINISH_VA:

    return;
end finish_va_resolution;
%page;
get_indirect_ptr:
     proc (data_ptr, seg, word, number, code);

/* Given a data_ptr to put it, returns the address area specified by seg, word, number.

   data_ptr      pointer to put data at (input)
   seg	       segment number (input)
   word          word offset (input)
   number        range (input)
   code          error code (output)
*/

/* parameters */

dcl code				fixed bin(35);
dcl data_ptr			ptr;
dcl seg				fixed bin;
dcl (word, number)			fixed bin (18);

/* automatic */

dcl index_changed			bit(1);

    index_changed = "0"b;
    code = 0;
    if ^amu_$return_val_per_process (amu_info_ptr, seg) then do;
       index_changed = "1"b;
       call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, lbound (fdump_process_table.array, 1));
       end;

    call amu_$do_translation (amu_info_ptr, seg, data_ptr, word, number, code);

    if index_changed then do;
       call amu_$fdump_mpt_revert_idx (amu_info_ptr);
       index_changed = "0"b;
       end;

end get_indirect_ptr;
%page;
get_va:
     proc (pointer_arg, va_arg_ptr, error_found, indirect_specified);

/* parameters */

dcl error_found bit(1);
dcl indirect_specified bit(1);
dcl pointer_arg char(*);
dcl pointer_arg_length fixed bin;
dcl  va_arg_ptr ptr;

/* based */

dcl  1 va based(va_arg_ptr) like va_args;

/* automatic */

dcl code				fixed bin(35);
dcl ignore			fixed bin;
dcl (ind_pos, offset_pos)		fixed bin;
dcl offset			fixed bin (18);
dcl offset_modifier			char(32);
dcl offset_name			char (65);
dcl mod_pos			fixed bin;
dcl seg_name			char (32);
dcl segno				fixed bin;
dcl segno_given			bit(1);
dcl temp_ptr			ptr;
dcl temp_ptr_given			bit(1);
dcl two_parts			bit(1);
dcl va_arg			char(256) var;

/* First check to see if the assumed VA is in two parts (A$B or A|B forms) */

    code = 0;
    error_found, two_parts, indirect_specified, temp_ptr_given, segno_given  = "0"b;
    pointer_arg_length = length(pointer_arg);
    ind_pos = index(pointer_arg, ",*");        /*  is this indirect? */
    mod_pos = search (pointer_arg, "+-");      /* do we have a offset modifier */
    offset_pos = search (pointer_arg, "$|");   /* is arg in two parts? */
    two_parts = (offset_pos > 0);
    indirect_specified = (ind_pos > 0);

    va_arg = pointer_arg;
    if mod_pos > 0 then do;
       if mod_pos < ind_pos then do;  /* have case of form A|B+30,*   */
          offset_modifier = substr(pointer_arg, mod_pos, (pointer_arg_length - (mod_pos + 1)));
	va_arg = substr(pointer_arg, 1, mod_pos - 1);
	va.modifier_before_indirect = "1"b;
	end;
       else do;    /* have case A|B,*+30 or A|B+30  */
          offset_modifier = substr(pointer_arg, mod_pos);
	if indirect_specified then 
	   va_arg = substr(pointer_arg, 1, ind_pos - 1);   /* case A|B,*+10  */
	else va_arg = substr(pointer_arg, 1, mod_pos - 1); /* case A|B+10  */
	end;

       /* lets verify the modifier */

       va.offset_modifier = cv_oct_check_ (offset_modifier, code);
       if code = 0 then va.valid_modifier = "1"b;
       else do;
	va.offset_modifier = 0;
	error_found = "1"b;
	va.ecode = amu_et_$not_octal_off_mod;
	va.error_msg = offset_modifier; 
	goto END_GET_VA;
	end;
       end;   /* end if mod_pos > 0 */

    else if indirect_specified then
       va_arg = substr(pointer_arg, 1, ind_pos - 1); /*    case A|B,*      */
    
    if two_parts then do;
       seg_name = substr(va_arg, 1, offset_pos - 1);
       offset_name = substr(va_arg, (offset_pos + 1));
       end;
    else do;
       if indirect_specified then seg_name = substr(va_arg, 1, ind_pos - 1);
       else seg_name = va_arg;
       end;
  
    /* is seg_name a name, number or temporary ptr? */

    va.offset = 0;
    va.segno = 0;
    code = 0;
    segno = cv_oct_check_ (seg_name, code);   /* check to see if its a name or number */
    if code = 0 then do;                          /* yep, it's octal */
       segno_given = "1"b;
       va.segno = segno;
       va.valid_va = "1"b;
       end;

    else do;			   /* not an octal number */
       if verify(rtrim(seg_name), NUMBERS) = 0 then do;
	error_found = "1"b;
	va.ecode = amu_et_$not_octal_segno;
	va.error_msg = rtrim(seg_name);
	goto END_GET_VA;
	end;

       code = 0;
       call check_name(seg_name, temp_ptr, va.error_msg, code); 
       if va.error_msg ^= "" then do;	/* invalid stack_N or ring_N name */
          error_found = "1"b;
	if va.ecode = amu_et_$invalid_seq then goto END_GET_VA;
	va.ecode = amu_et_$not_octal_segno;
	va.error_msg = va.error_msg || " " || rtrim(seg_name);
	goto END_GET_VA;
	end;
       else do;
	if code = 0  then do;	/* yep, it's a name */
             va.segno = fixed (baseno (temp_ptr), 17);
	   va.valid_va = "1"b;
	   end;

          else do;		/* not a segment name */
			/* check to see if it's a temporary pointer */
	   code = 0;
	   call amu_$definition_get_prn (amu_info_ptr, seg_name, temp_ptr, code);
             if code = 0 then do;    /* yep, it's a temporary pointer */
	      if temp_ptr = null then do;  /* but it's null so quit here */
	         error_found = "1"b;
	         va.ecode = amu_et_$invalid_seq;
	         call ioa_$rsnnl ("Temporary ptr specified is null. ^a", va.error_msg, ignore, seg_name); 
	         goto END_GET_VA;
	         end;
	      va.segno = fixed (baseno (temp_ptr), 17);
	      va.offset = fixed (rel (temp_ptr), 18);
	      va.valid_va = "1"b;
	      temp_ptr_given = "1"b;
	      end;

	   else do; /* not a temporatry pointer either */

	      if two_parts then;		/* segno|offset may be valid continue checking		     */
	      else goto END_GET_VA;             /* could be an arg not part of the VA construct, so just skip it */
	      end;
	   end;
	end;
       end;

    if two_parts then do;     /* given an offset too */
       offset = cv_oct_check_ (offset_name, code);
       if code = 0 then do;
          va.offset = va.offset + offset;
	va.valid_va = "1"b;	
	end;
       else do;		          /* check to see if offset is a name */
	if verify(rtrim(offset_name), NUMBERS) = 0 then do;
	   error_found = "1"b;
	   va.ecode = amu_et_$not_octal_offset;
	   va.error_msg = offset_name;
	   goto END_GET_VA;
	   end;

          if segno_given then do;  /* invalid case of segno|name */
	   va.ecode = amu_et_$invalid_seq;
	   va.error_msg = "A virtual address number|name is not valid.";
	   error_found = "1"b;
	   goto END_GET_VA;
	   end;
  
	else do;   /* both seg and offset are names, check to see if it's a symbol */
	   if temp_ptr_given then do;
	      va.offset =  va.offset + offset;
	      va.valid_va = "1"b;	
	      end;
	   else do;
	      temp_ptr = amu_$definition_ptr (amu_info_ptr, seg_name, offset_name, code);
                if code = 0 then do;     /* a symbol */
	         va.segno = fixed (baseno (temp_ptr), 17);
	         va.offset = fixed (rel (temp_ptr), 18);
	         va.valid_va = "1"b;	
	         end;
	      else do;
	         error_found = "1"b;
	         va.ecode = amu_et_$invalid_seq;
	         va.error_msg = "This is not a valid symbol." || " " || arg;
	         goto END_GET_VA;
	         end;
	      end;
	   end;
	end;
       end;

END_GET_VA:

    return;
end get_va;
%page;
parse_arg:  proc(p_va_args, doing, arg, nargs, arg_position);
	  
/* parse_arg

   p_va_args           pointer to the va_args structure(input)
		   parse_arg fills this in.
   doing		   where we are in the parsing sequnce(input)
		   parse_arg resets this.
   arg		   argument to be parsed (input)
   nargs		   total args in the list (input)
   arg_position	   the arg list index (input)
		   parse_arg sets the index to the next arg position to examine
  
   The virtual address, offset modifer and range are non-positional arguments in the arg list. A virtual
   address must be specified. A modifier or range are optional. A virtual address must be specified
   before an offset modifier can be specified on the arg list.  An offset modifier must be specified 
   before a range can be specified.  This is similar to how the dump_segment command parses its args.
*/

/* parameters */

dcl arg				char (*);
dcl arg_position			fixed bin;
dcl doing				fixed bin;
dcl nargs				fixed bin;
dcl p_va_args			ptr;

/* automatic */

dcl code				fixed bin(35);
dcl error_found			bit(1);
dcl ignore			fixed bin;
dcl indirection_specified		bit(1);
dcl offset			fixed bin(18);
    
    code = 0;
    error_found, indirection_specified = "0"b;

    if doing = GETTING_VA then do;
       if arg = "-prs" then do;
	  doing = DONE;
	  goto RETURN_PARSE_ARG;
       end;
       else if substr(arg,1,1) = "-" then goto RETURN_PARSE_ARG;   /* assume it's a ctl arg */
       va.va_string = arg;
       call get_va(arg, p_va_args, error_found, indirection_specified);
       if error_found then do;
	doing = DONE; /* quit processing */
	goto RETURN_PARSE_ARG;
	end;
       if va.valid_va then do;
          if indirection_specified then call resolve_indirection (p_va_args, error_found);
          if error_found then do;
   	   doing = DONE; /* quit processing */
	   goto RETURN_PARSE_ARG;
	   end;
	if va.valid_modifier then doing = GETTING_RANGE;
	else doing = GETTING_MODIFIER;
	va.va_idx = arg_position;
	end;
       end;   /* if GETTING_VA */

    else if doing = GETTING_MODIFIER then do;
       if substr(arg,1,1) = "+" then do;  /* assume its a offset modifier */
          if va.valid_range then do;
	   va.error_msg = arg;
             /* offset modifier has to specified before a range... */
	   if va.valid_modifier then va.ecode = amu_et_$specified_modifier;
	   else va.ecode = amu_et_$modifier_before_range;
	   goto RETURN_PARSE_ARG;
	   end;

          offset =  cv_oct_check_ (arg, code);
	if code = 0 then do;
	   va.va_string = va.va_string || " " || arg;
	   va.offset_modifier = offset;
	   va.valid_modifier = "1"b;;
	   va.mod_idx = arg_position;	   
	   doing = GETTING_RANGE;
	   goto RETURN_PARSE_ARG;
	   end;
          else do;  /* invalid modifier */
	   doing = DONE; /* quit processing */
	   va.ecode = amu_et_$not_octal_off_mod;
	   va.error_msg = arg; 
	   goto RETURN_PARSE_ARG;
	   end;
	end;
       else if substr(arg,1,1) = "-" then do;  /* assume its a offset modifier */
          offset =  cv_oct_check_ (arg, code);
	if code = 0 then do;
	   if va.valid_range then do;
	      va.error_msg = arg;
	      /* but modifiers have to specified before a range... */
	      if va.valid_modifier then va.ecode = amu_et_$specified_modifier;
	      else va.ecode = amu_et_$modifier_before_range;
	      goto RETURN_PARSE_ARG;
	      end;

	   va.offset_modifier = offset;
	   va.valid_modifier = "1"b;;
	   va.va_string = va.va_string || " " || arg;
	   va.mod_idx = arg_position;	   
	   doing = GETTING_RANGE;
	   goto RETURN_PARSE_ARG;
	   end;
          else do;  /* Could be a control argument, so skip */
	   goto RETURN_PARSE_ARG;
	   end;
	end;
       else do;  /* no + or -, could be a range */
          doing = GETTING_RANGE;
	arg_position = arg_position - 1;
	goto RETURN_PARSE_ARG;
	end;
       end;     /* end if getting_modifier */
  
    else if doing = GETTING_RANGE then do;
       if substr(arg,1,1) = "+"  then do;  /* assume its a offset modifier */
	doing = DONE; /* quit processing */
          if va.valid_modifier then 
	   /* could only get here if modifier was part of the VA eg. 234|2000+20 */
	   va.ecode = amu_et_$specified_modifier;
	else   /* this should never happen, but it's here for completeness. */
	   va.ecode = amu_et_$modifier_before_range;
	va.error_msg = arg;
	goto RETURN_PARSE_ARG;
	end; /* if "+" */

       else if substr(arg,1,1) = "-" then do;  /* could be a ctl arg, or error offset modifier */
          if verify(arg, NUMBERS) = 0 then do;  /* looks like a offset modifier */
	   doing = DONE; /* quit processing */
	   if va.valid_modifier then 
	     /* could only get here if modifier was part of the VA eg. 234|2000+20 */
	     va.ecode = amu_et_$specified_modifier;
	   else   /* modifier has to be specified before a range... */
	      va.ecode = amu_et_$modifier_before_range;
             va.error_msg = arg;
	   end;  /* if verify */
          goto RETURN_PARSE_ARG;
	end;  /* if "-"  */
       else do;   /* probably a range */
	if forsw then do;
	     forsw = "0"b;
	     offset = cv_dec_check_ (arg, code);
	     if code ^= 0 then do;
		call ioa_$rsnnl ("Decimal integer not supplied with ""-for"": ^a", va.error_msg, ignore, arg);
		error_found = "1"b;
		goto RETURN_PARSE_ARG;
	     end;
	     else goto fill_va;
	end;
          offset =  cv_oct_check_ (arg, code);
	if code = 0 then do;        /* assume its a range */
fill_va:	     va.range = offset;
	   va.range_idx = arg_position;
	   va.valid_range = "1"b;
	   va.va_string = va.va_string || " " || arg;
	   if arg_position < nargs then
	      doing = GETTING_MODIFIER;    /* for error checking purposes. */
	   else doing = DONE;	     /* completely done parsing the VA args */
	   goto RETURN_PARSE_ARG;
	   end;
          else do; 
             if verify(arg, NUMBERS) = 0 then do;
	      va.ecode = amu_et_$not_octal_range;
	      va.error_msg =  arg;  
	      error_found = "1"b;
	      end;
	   else do; 
	      if arg = ",*" then do;
	         va.ecode = amu_et_$error_indirect;
	         call ioa_$rsnnl ("^/^-For example: ^a^a", va.error_msg, ignore, va.va_string, arg);
	         error_found = "1"b;
	         end;
	      else;   /* Could be a control argument, so skip */
	      end;
	   goto RETURN_PARSE_ARG;
	   end;
	end;
       end;   /* if getting_range */

RETURN_PARSE_ARG:
  
    arg_position = arg_position + 1;

    return;
end parse_arg;
%page;
resolve_indirection:      proc (va_arg_ptr, error_found);

/* This procedure resolves indirection of the specified virtual address.

   va_arg_ptr     pointer to the va_args structure (input)
   error_found    set to on if any errors are found (output)

*/

/* parameters */

dcl error_found			bit(1);
dcl va_arg_ptr			ptr;

/* based */

dcl  1 va				based(va_arg_ptr) like va_args;

/* automatic */

dcl data_buf_ptr			ptr;
dcl indirect_ptr			ptr;
dcl offset			fixed bin(18);


    error_found = "0"b;
    offset = va.offset;
    if va.modifier_before_indirect then do;
       offset = va.offset + va.offset_modifier;
       if offset < 0 then do;
          error_found = "1"b;
	va.ecode = amu_et_$negative_offset;
	va.error_msg = va.va_string;
	goto END_RESOLVE;
	end;
       end;
  
    if bad_segno(va.segno, va.ecode) then do;
       error_found = "1"b;
       va.error_msg = va.va_string;
       goto END_RESOLVE;
       end;

    data_buf_ptr = addr(indirect_ptr);     

    call get_indirect_ptr (data_buf_ptr, (va.segno), offset, (2), va.ecode);
    if va.ecode ^= 0 then do;
       error_found = "1"b;
       va.error_msg = va.va_string;
       goto END_RESOLVE;
       end;

    if data_buf_ptr -> its.its_mod = ITS_MODIFIER then do;
       va.segno = fixed (baseno (indirect_ptr), 17);
       va.offset = fixed (rel (indirect_ptr), 18);

       if bad_segno(va.segno, va.ecode) then do;
	error_found = "1"b;
	va.error_msg = va.va_string;
	goto END_RESOLVE;
	end;
       end;
    else do;  /* not ITS pointer */
       /* ignore for now */
       error_found = "1"b;
       va.error_msg = va.va_string;
       va.ecode = amu_et_$not_its_ptr;
       goto END_RESOLVE;
       end;

END_RESOLVE:
    return;	
end resolve_indirection;
%page;
%include amu_hardcore_info;
%page;
%include amu_fdump_info;
%page;
%include amu_info;
%page;
%include its;
%page;
%include azm_va_args;


     end amu_parse_ptr_args_;




		    amu_print_.pl1                  02/13/85  0937.5rew 02/13/85  0903.6      153837



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_print_: proc;
	return;

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* Parameters */

dcl  P_data_ptr ptr;
dcl  (P_number_of_words, P_offset) fixed bin (18);
dcl  P_af_lth fixed bin(21);
dcl  P_af_ptr ptr;
dcl  P_amu_info_ptr ptr;
dcl  P_aptep ptr;
dcl  P_apte_offset fixed bin (18);
dcl  P_apte_idx fixed bin;
dcl dmp ptr;
dcl doffset fixed bin(18);
dcl num_of_words fixed bin;

/* External Entries */

dcl  amu_$definition_offset entry (ptr, char (*), char (*), fixed bin (35)) returns (fixed bin (18));
dcl  amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin, fixed bin (35));
dcl  amu_$fdump_mpt_temp_change_idx entry (ptr, fixed bin);
dcl  amu_$fdump_mpt_revert_idx entry (ptr);
dcl  amu_$get_name entry (ptr, ptr) returns (char (*));
dcl  amu_$print_text_offset entry (ptr, char(*) var, fixed bin(18));
dcl  amu_$return_val_cpu_from_idx entry (ptr, fixed bin) returns (char (1));
dcl  amu_$return_val_idx_from_dbr entry (ptr, fixed bin (24)) returns (fixed bin);
dcl  convert_status_code_	entry (fixed bin(35), char(8) aligned, char(100) aligned);
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  decode_clock_value_$date_time	entry (fixed bin(71), fixed bin, fixed bin, fixed bin, fixed bin,
				     fixed bin, fixed bin, fixed bin(71), fixed bin, char(3),
				     fixed bin(35));
dcl  (
     ioa_,
     ioa_$rsnnl
     ) entry () options (variable);

/* External Static */

dcl  iox_$user_io ptr ext static;

/* Automatic */

dcl  af_sw bit(1);
dcl  all_cpu_mask bit (8) init ("11111111"b);
dcl  bcode fixed bin (35);
dcl  char_sw bit (1) unal;
dcl  chars char (64) var;
dcl  code fixed bin (35);
dcl  cpu_str char (8) var init ("");
dcl  data_ptr ptr;
dcl  dom  fixed bin;
dcl  dow  fixed bin;
dcl  good_proc bit (1);
dcl  hour fixed bin;
dcl  ignore fixed bin;
dcl  i;
dcl  iocb_name char (32) aligned;
dcl  iocbp ptr;
dcl  line_size fixed bin;
dcl  line_ptr ptr;
dcl  lines_to_dump fixed bin;
dcl  long_output bit (1);
dcl  longinfo char(100) aligned;
dcl  min  fixed bin;
dcl  mod8 fixed bin;
dcl  month fixed bin;
dcl  msec fixed bin (71);
dcl  nprt bit (1);
dcl  number_of_words fixed bin;
dcl  opl fixed bin;
dcl  pequal bit (1);
dcl  poffset fixed bin (18);
dcl  pp ptr;
dcl  real_offset fixed bin (18);
dcl  sec  fixed bin;
dcl  shortinfo char(8) aligned;
dcl  start_line fixed bin (18);
dcl  t_data (8) fixed bin (35);
dcl  t_offset fixed bin (18);
dcl  t_idx fixed bin;
dcl  t_ptr ptr;
dcl  t_segno fixed bin;
dcl  tp ptr;
dcl  w (0:7) fixed bin based (pp);
dcl  wait_type char (40) var;
dcl  year fixed bin;
dcl  yr_char char(10);
dcl  zone char(3);

/* Based */

dcl  PTRS (0:7) ptr aligned based (pp);
dcl  PPTRS (0:7) ptr unaligned based (pp);
dcl  based_char char (32) based (t_ptr);
dcl  based_event char (4) based;
dcl  inst_word (number_of_words) bit (36) based (data_ptr);
dcl  wab bit (8 * 36) based;

/* Internal static */

dcl  vfmt char (184) int static options (constant)
	init (
	"^6o ^6o^[ ^w^;^2( ^w^)^;^3( ^w^)^;^4( ^w^)^;^4( ^w^)^[^2s^;^/^6o ^6o^] ^w^;^4( ^w^)^[^2s^;^/^6o ^6o^]^2( ^w^)^;^4( ^w^)^[^2s^;^/^6o ^6o^]^3( ^w^)^;^4( ^w^)^[^2s^;^/^6o ^6o^]^4( ^w^)^]"
	);
dcl  pfmt char (208) int static options (constant)
	init (
	"^6o ^6o^[ ^12p^;^2( ^12p^)^;^3( ^12p^)^;^4( ^12p^)^;^4( ^12p^)^[^2s^;^/^6o ^6o^] ^12p^;^4( ^12p^)^[^2s^;^/^6o ^6o^]^2( ^12p^)^;^4( ^12p^)^[^2s^;^/^6o ^6o^]^3( ^12p^)^;^4( ^12p^)^[^2s^;^/^6o ^6o^]^4( ^12p^)^]"
	);

dcl  process_st (0:6) char (9) varying int static options (constant)
	init ("empty", "running", "ready", "waiting", "blocked", "stopped", "ptlocking");

/* Builtins */

dcl  (addr, addrel, after, convert, 
      divide, fixed, length, mod,
      null, rtrim, substr, 
      translate, unspec)		builtin;
				
%page;
/* This code direct from ol_dump_$util_dump_oct */
/* amu_dump_oct - entry to display words in octal depending on line length */
dump_oct:
     entry (dmp, doffset, num_of_words);

	call ioa_ ("");
	long_output = output_mode ();			/* find terminal line length */
	lines_to_dump = divide (num_of_words, 8, 17, 0);	/* find out how many full lines to dump */
	mod8 = 8;
	pp = dmp;
	tp = null;
	poffset = doffset;
	opl = doffset + num_of_words;
	nprt, pequal = "0"b;

	do i = 0 by 8 while (poffset < opl);
	     if nprt then /* if last line was not printed */ pequal = "1"b;
	     if tp ^= null then			/* if not first line */
		if tp -> wab = pp -> wab then		/* and if last line iss equal to this line */
		     nprt = "1"b;			/* then don't print it */
		else nprt = "0"b;			/* else print the line */
	     if pequal & ^nprt then do;		/* if we have skipped n lines print a string of "=" */
		pequal = "0"b;
		call ioa_ ("^7x========");
		end;
	     if ^nprt | lines_to_dump = 0 then do;	/* if we wandt to print line or if last line */
		if lines_to_dump = 0 then mod8 = mod (num_of_words, 8);
		if mod8 ^= 0 then
		     call ioa_ (vfmt, poffset, i, mod8, w (0), w (1), w (2), w (3), long_output, poffset + 4, i + 4,
			w (4), w (5), w (6), w (7));
		end;
	     tp = pp;				/* copy current line pointer for equal line compare */
	     pp = addrel (pp, 8);			/* increment to nxt line */
	     poffset = poffset + 8;
	     lines_to_dump = lines_to_dump - 1;
	end;
	return;
%page;
amu_print_$af_char_dump:
     entry (P_data_ptr, P_offset, P_number_of_words, P_af_ptr, P_af_lth);

dcl  af_str char (P_af_lth) varying based (P_af_ptr);

	af_sw = "1"b;
	goto CHAR_COMMON;

amu_print_$char_dump:
     entry (P_data_ptr, P_offset, P_number_of_words);

	af_sw = "0"b;
CHAR_COMMON:
	data_ptr = P_data_ptr;
	real_offset = P_offset;
	number_of_words = P_number_of_words;
	char_sw = "1"b;
	line_size = 8;
	do start_line = 0 by 8 while ((number_of_words - start_line) > 7);
	     line_ptr = addrel (data_ptr, start_line);
	     call translate_line_to_dump (line_size, line_ptr, chars);
	     if af_sw then call ioa_$rsnnl ("^x^a^a", af_str, ignore, (af_str), chars);
	     else call ioa_ ("^6o^x^6o^x^a", real_offset, start_line, chars);
	     real_offset = real_offset + line_size;
	end;
	line_size = number_of_words - start_line;
	if line_size > 0 then do;
	     line_ptr = addrel (data_ptr, start_line);
	     call translate_line_to_dump (line_size, line_ptr, chars);
	     if af_sw then call ioa_$rsnnl ("^x^a^a", af_str, ignore, (af_str), chars);
	     else call ioa_ ("^6o^x^6o^x^a", real_offset, start_line, chars);
	     end;
	return;					/* end of char dump */
%page;
amu_print_$inst_dump:
     entry (P_data_ptr, P_offset, P_number_of_words);

	data_ptr = P_data_ptr;
	real_offset = P_offset;
	number_of_words = P_number_of_words;
	iocbp = iox_$user_io;
	iocb_name = iocbp -> iocb.name;



	do i = 1 to number_of_words;
	     call amu_$print_text_offset (addr (inst_word (i)), chars, real_offset);
	     call ioa_ ("^a", chars);
	     real_offset = real_offset + 1;
	end;
	return;					/* end of inst_dump */
%page;
amu_print_$apte_bf:
     entry (P_amu_info_ptr, P_aptep, P_apte_offset);
	amu_info_ptr = P_amu_info_ptr;
	aptep = P_aptep;
	good_proc = "1"b;
	call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, amu_info.process_idx);
						/* this way revert will always work */
	sdwp = addr (aptep -> apte.dbr);
	t_idx = amu_$return_val_idx_from_dbr (amu_info_ptr, fixed (substr (unspec (apte.dbr), 1, 24), 24));
	if t_idx = -1 then do;			/* process is not in dump so this is all we can say */
	   good_proc = "0"b;
             end;
          else do;
	     call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, t_idx);
	     t_ptr = addr (t_data);
	     t_segno = hardcore_info.segno.pds;
	     t_offset = amu_$definition_offset (amu_info_ptr, "pds", "process_group_id", code);
	     if code ^= 0 then good_proc = "0"b;
	     call amu_$do_translation (amu_info_ptr, t_segno, t_ptr, t_offset, 8, code);
	     if code ^= 0 then good_proc = "0"b;
	     end;

	wait_type = "";
	if fixed (apte.state, 3) = 3 then do;
	     if apte.wait_event = "400000000000"b3 then
		call ioa_$rsnnl ("^/^16tAST lock ^12.3b", wait_type, ignore, apte.wait_event);
	     else if apte.wait_event = "200000000000"b3 then
		call ioa_$rsnnl ("^/^16tTemp wiring lock ^12.3b", wait_type, ignore, apte.wait_event);
	     else if substr (apte.wait_event, 1, 30) = "3330000000"b3 then
		call ioa_$rsnnl ("^/^16tVTOC buffer ^12.3b", wait_type, ignore, apte.wait_event);
	     else if apte.wait_event = "000000000071"b3 then
		call ioa_$rsnnl ("^/^16tTTY DIM ^12.3b", wait_type, ignore, apte.wait_event);
	     else if apte.wait_event = "000000000075"b3 then
		call ioa_$rsnnl ("^/^16tIMP DIM (arpa) ^12.3b", wait_type, ignore, apte.wait_event);
	     else if apte.wait_event = "000000000114"b3 then
		call ioa_$rsnnl ("^/^16tNCP (arpa) ^12.3b", wait_type, ignore, apte.wait_event);
	     else if apte.wait_event = "000000000105"b3 then
		call ioa_$rsnnl ("^/^16tSYSERR LOG EVENT ^12.3b", wait_type, ignore, apte.wait_event);
	     else if substr (apte.wait_event, 1, 18) = "000000"b3 then do;
		if substr (apte.wait_event, 19, 18) = "707070"b3 then
		     call ioa_$rsnnl ("^/^16t-BUG- ^12.3b", wait_type, ignore, apte.wait_event);
		else call ioa_$rsnnl ("^/^16tPAGE ^o", wait_type, ignore, substr (apte.wait_event, 19, 18));
		end;
	     else if addr (apte.wait_event) -> based_event = "dbm_" then
		call ioa_$rsnnl ("^/^16tVD BIT MAP ^12.3b", wait_type, ignore, apte.wait_event);
	     else if addr (apte.wait_event) -> based_event = "free" then
		call ioa_$rsnnl ("^/^16tSystem Free Seg ^12.3b", wait_type, ignore, apte.wait_event);
	     else if addr (apte.wait_event) -> based_event = "dskw" then
		call ioa_$rsnnl ("^/^16tDisk Offline ^12.3b", wait_type, ignore, apte.wait_event);
	     else if apte.wait_event = "777777777777"b3 then
		call ioa_$rsnnl ("^/^16tROOT DIR LOCK ^12.3b", wait_type, ignore, apte.wait_event);
	     else call ioa_$rsnnl ("^/^16tDir Lock UID ^12.3b", wait_type, ignore, apte.wait_event);
	     end;

	if good_proc then 
	   call ioa_ ("^[^3d^;^s^4t^] ^8.3b^16t^9a^24t^12.3b^[^40t^a^;^s^]^43t^a^[^a^]",
	   t_idx >= 0, t_idx, sdw.add, process_st (fixed (apte.state, 3)), apte.processid, 
	   (fixed (apte.state, 3) = 1), amu_$return_val_cpu_from_idx (amu_info_ptr, t_idx),
	   based_char, wait_type ^= "", wait_type);

          else call ioa_ ("^[^3d^;^s^4t^] ^8.3b^16t^9a^24t^12.3b^[^40t^a^;^s^]^43t^32x^[^a^]",
	   t_idx >= 0, t_idx, sdw.add, process_st (fixed (apte.state, 3)), apte.processid, 
	   (fixed (apte.state, 3) = 1), amu_$return_val_cpu_from_idx (amu_info_ptr, t_idx),
	   wait_type ^= "", wait_type);

	call amu_$fdump_mpt_revert_idx (amu_info_ptr);

	return;
%page;
amu_print_$apte:
     entry (P_amu_info_ptr, P_aptep, P_apte_offset, P_apte_idx);

dcl not_dumped bit(1);

	amu_info_ptr = P_amu_info_ptr;
	aptep = P_aptep;
	sdwp = addr (aptep -> apte.dbr);
          not_dumped = "0"b;

	if P_apte_idx ^= -1 then call ioa_ ("^/APTE #^o at ADDR ^o:", P_apte_idx, P_apte_offset);

	t_idx = amu_$return_val_idx_from_dbr (amu_info_ptr, fixed (substr (unspec (apte.dbr), 1, 24), 24));
	if t_idx = -1 then do;
	   not_dumped = "1"b;;			/* process is not in dump so this is all we can say */
	   end;
	else do;
	   call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, t_idx);
	   t_ptr = addr (t_data);
	   t_segno = hardcore_info.segno.pds;
	   t_offset = amu_$definition_offset (amu_info_ptr, "pds", "process_group_id", code);
	   if code ^= 0 then goto revert;
	   call amu_$do_translation (amu_info_ptr, t_segno, t_ptr, t_offset, 8, code);
	   if code ^= 0 then goto revert;
             end;
        
	call ioa_ ("Processid:  ^12.3b (^[Not Dumped^;^a^]); ^[^s^;DBR:^-  ^o^]", apte.processid,  not_dumped, based_char,
                     not_dumped, fixed (sdw.add, 24));
          zone = "";
	call decode_clock_value_$date_time(apte.state_change_time, month, dom, year, hour, min, sec, msec, dow, zone, code);
	if code ^= 0 then do;
	   call convert_status_code_(code, shortinfo, longinfo);
	   call ioa_("^a: While getting time for apte # ^o.", rtrim(longinfo),P_apte_idx);
             end;
	else do;
	   yr_char = convert(yr_char, year);
	   call ioa_ ("State:^-  ^a at ^d/^d/^a ^d:^d:^d.^d", process_st (fixed (apte.state, 3)), 
                          month,dom,after(yr_char, "19"),hour,min,sec,msec);
	   end;

revert:
	call amu_$fdump_mpt_revert_idx (amu_info_ptr);
	return;

%page;
dump_ptr:
     entry (dmp, doffset, num_of_words);

	call ioa_ ("");
	long_output = output_mode ();			/* find terminal line length */
	lines_to_dump = divide (num_of_words, 8, 17, 0);	/* find out how many full lines to dump */
	pp = dmp;
	poffset = doffset;
	mod8 = 8;
	opl = doffset + num_of_words;

	do i = 0 by 8 while (poffset <= opl);
	     if lines_to_dump = 0 then mod8 = mod (num_of_words, 8);
	     if mod8 ^= 0 then
		call ioa_ (pfmt, poffset, i, mod8, PTRS (0), PTRS (1), PTRS (2), PTRS (3), long_output, poffset + 8,
		     i + 8, PTRS (4), PTRS (5), PTRS (6), PTRS (7));

	     pp = addrel (pp, 16);			/* increment to nxt line */
	     poffset = poffset + 16;
	     lines_to_dump = lines_to_dump - 1;
	end;
	return;

%page;
dump_ptr_exp:
     entry (P_amu_info_ptr, dmp, doffset, num_of_words);

dcl  PRINT_PTR ptr aligned based (pp);
dcl  ptrs_printed fixed bin;

	amu_info_ptr = P_amu_info_ptr;
	call ioa_ ("");
	pp = dmp;
	poffset = doffset;
	ptrs_printed = 0;

	do i = 0 by 2 while (ptrs_printed < num_of_words);
	     call ioa_ ("^6o ^6o ^12p ^a", poffset, i, PRINT_PTR, amu_$get_name (amu_info_ptr, PRINT_PTR));
	     pp = addrel (pp, 2);			/* increment to nxt line */
	     poffset = poffset + 2;
	     ptrs_printed = ptrs_printed + 1;
	end;
	return;

%page;
dump_pptr:
     entry (dmp, doffset, num_of_words);


	call ioa_ ("");
	long_output = output_mode ();			/* find terminal line length */
	lines_to_dump = divide (num_of_words, 8, 17, 0);	/* find out how many full lines to dump */
	pp = dmp;
	poffset = doffset;
	mod8 = 8;
	opl = doffset + num_of_words;

	do i = 0 by 8 while (poffset <= opl);
	     if lines_to_dump = 0 then mod8 = mod (num_of_words, 8);
	     if mod8 ^= 0 then
		call ioa_ (pfmt, poffset, i, mod8, PPTRS (0), PPTRS (1), PPTRS (2), PPTRS (3), long_output,
		     poffset + 8, i + 8, PPTRS (4), PPTRS (5), PPTRS (6), PPTRS (7));

	     pp = addrel (pp, 8);			/* increment to nxt line */
	     poffset = poffset + 8;
	     lines_to_dump = lines_to_dump - 1;
	end;
	return;

%page;
dump_pptr_exp:
     entry (P_amu_info_ptr, dmp, doffset, num_of_words);

dcl  PRINT_PPTR ptr unaligned based (pp);
dcl  pptrs_printed fixed bin;
dcl  temp_pptr ptr;

	amu_info_ptr = P_amu_info_ptr;
	call ioa_ ("");
	pp = dmp;
	poffset = doffset;
	pptrs_printed = 0;

	do i = 0 by 1 while (pptrs_printed < num_of_words);
	     temp_pptr = PRINT_PPTR;
	     call ioa_ ("^6o ^6o ^12p ^a", poffset, i, PRINT_PPTR, amu_$get_name (amu_info_ptr, temp_pptr));
	     pp = addrel (pp, i);			/* increment to nxt line */
	     poffset = poffset + 1;
	     pptrs_printed = pptrs_printed + 1;
	end;
	return;

%page;
/* output_mode - entry to determine  long/short output mode based on terminal or file line length */

output_mode:
     proc returns (bit (1));

dcl  oml fixed bin;
	oml = get_line_length_$switch (null, bcode);	/* find terminal line length */
	if oml < 118 & bcode = 0 then			/* if ll < 118 and not a file */
	     return ("0"b);				/* 4 words / line */
	else return ("1"b);				/* 8 words / line */
     end output_mode;
%page;
translate_line_to_dump:
     proc (wds_in_line, line_ptr, new_chars_to_print);

/* Formal Parameters */

dcl  wds_in_line fixed bin;
dcl  line_ptr ptr;
dcl  new_chars_to_print char (64) varying;

/* Automatic, structures for accessing the input line and subrutine return args */


dcl  ascii_chars char (wds_in_line * 4) based (line_ptr);

dcl  i fixed bin;					/* character string index */
dcl  temp_overlay char (64);				/* used to make this a quick block */
dcl  temp_ascii char (length (ascii_chars)) based (addr (temp_overlay));

/* Constants */

dcl  dots char (33) aligned internal static options (constant) init ((33)".");
dcl  nonprinting_chars char (33) aligned internal static init ("	
") options (constant);

dcl  last_ascii char (1) aligned internal static options (constant) initial ("");
						/* last ascii char code */

	new_chars_to_print = "";

	if char_sw then do;
	     temp_ascii = ascii_chars;
	     do i = 1 to length (ascii_chars) by 1;	/* set illegal characters to 0 */
		if substr (ascii_chars, i, 1) > last_ascii then substr (temp_ascii, i, 1) = "";
	     end;					/* set illegal characters to 0 */
	     new_chars_to_print = translate (temp_ascii, dots, nonprinting_chars);
	     end;

     end translate_line_to_dump;
%page;
%include apte;
%page;
%include amu_info;
%page;
%include sdw;
%page;
%include amu_hardcore_info;
%page;
%include iocb;

     end amu_print_;




		    amu_print_text_.pl1             07/28/87  0939.7rew 07/28/87  0928.6      171108



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(85-05-13,Farley), approve(85-05-13,MCR7242),
     audit(85-05-13,Fawcett), install(86-02-19,MR12.0-1019):
     Added EIS Indirect Descriptors.
  2) change(87-07-17,Parisek), approve(87-07-17,MCR7746),
     audit(87-07-17,Fawcett), install(87-07-28,MR12.1-1049):
     Modified to conform to coding standards.
                                                   END HISTORY COMMENTS */


/* Program to display output text produced by pl/1 and Fortran.  A reduced version of
   display_text.  Numbers in the disassembled instruction are decimal.  The offset and
   the instruction as it apears in core are in octal.

  The numbers are really in octal, despite comment.  Modified by JRDavis 19 Mar 80
  to not call binoct (which was transfer vector to pl1 compiler lang_util_ MCR 4422
  Modified for amu by Rich Fawcett Feb 83 to add real_offset entry
  Modified April 1985 by Paul Farley to add EIS Indirect Descriptors.
*/

amu_print_text_: proc (t_pt, arg_number, output_switch);

dcl  t_pt ptr,					/* points at text base */
     arg_number fixed bin,				/* max. no. of words to print */
     output_switch char (*) aligned,			/* switch name for printing disassembled line */
     arg_offset fixed bin (18),			/* real offset to be printed instead of t_pt */
     arg_string char (*) var;				/* output.  Contains formatted instruction */


dcl  number fixed bin;				/* no. of words to print */
dcl  desc_type fixed bin;				/* descriptor type: 0 = alpha, 1 = bit, 2 = numeric */
dcl  comment char (50) var;
dcl  op_name char (32) aligned;
dcl (p, pt) ptr,
    (no_to_print, j, k, m, op_index, irand, nrands, ndesc) fixed bin,
    (fract_offset, offset, scale) fixed bin (18),
    (double, eis, eis_desc, need_comma, ext_base, has_ic, decimal, ind_desc) bit (1),
     ht char (1) int static aligned init ("	"),		/* tab */
     htht char (2) int static aligned init ("		"),	/* two tabs */
     cstring char (12),
     op_code char (5),
     tag char (3),
     line char (256),
     buff char (12) varying,
     pl1_operators_$operator_table fixed bin ext;

dcl  repeat_inst bit (1);				/* ON for rpd, rpt, rpl */
dcl  print_instr bit (1);				/* 1= print instr;	  0= return formatted string */
dcl  real_offset_entry bit (1) unal;			/* ON if instruction ptr is different from text location */
dcl  real_offset fixed bin (18);			/* used with $format, $offset entries */
dcl  ioa_$ioa_stream ext entry options (variable);
dcl  ioa_$rsnnl ext entry options (variable);
dcl  find_operator_name_ entry (char (*) aligned, ptr, char (32) aligned);

dcl (addr, addrel, fixed, length, ptr, rel, rtrim, string, substr) builtin;

dcl 1 op_mnemonic_$op_mnemonic (0:1023) ext static aligned,
    2 opcode char (6) unal,
    2 dtype fixed bin (2) unal,			/* 0 = alpha, 1 = bit, 2 = numeric */
    2 num_desc fixed bin (5) unal,
    2 num_words fixed bin (8) unal;

dcl  digit (0:9) char (1) aligned int static
     init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9");

dcl  base (0:7) char (4) aligned int static
     init ("pr0|", "pr1|", "pr2|", "pr3|", "pr4|", "pr5|", "pr6|", "pr7|");

dcl  modifier (0:63) char (3) aligned int static
     init (" ", "au", "qu", "du", "ic", "al", "ql", "dl",
     "0", "1", "2", "3", "4", "5", "6", "7",
     "*", "au*", "qu*", "...", "ic*", "al*", "ql*", "...",
     "0*", "1*", "2*", "3*", "4*", "5*", "6*", "7*",
     "f", "itp", "...", "its", "sd", "scr", "f2", "f3",
     "ci", "i", "sc", "ad", "di", "dic", "id", "idc",
     "*n", "*au", "*qu", "*du", "*ic", "*al", "*ql", "*dl",
     "*0", "*1", "*2", "*3", "*4", "*5", "*6", "*7");

dcl  word (0:1) bit (36) aligned based (p);

dcl 1 instruction based (p) aligned,
    2 base unaligned bit (3),
    2 offset unaligned bit (15),
    2 op_code unaligned bit (10),
    2 inhibit unaligned bit (1),
    2 ext_base unaligned bit (1),
    2 tag unaligned bit (6);

dcl 1 half based (p) aligned,
    2 left unaligned bit (18),
    2 right unaligned bit (18);

dcl 1 mod_factor aligned,
    2 ext_base bit (1) unal,
    2 length_in_reg bit (1) unal,
    2 indirect_descriptor bit (1) unal,
    2 tag bit (4) unal;

dcl  mf (3) fixed bin (6) int static init (30, 12, 3);	/* location of modification factor fields in EIS inst */

dcl (ebase, len_reg, idesc, ic) (3) bit (1) aligned;
dcl  desc_word char (8) varying;

dcl  desc_op (0:3) char (8) varying int static init ("desc9a", "descb", "desc9fl", "desc9ls");

dcl  eis_modifier (0:15) char (3) aligned int static
     init ("n", "au", "qu", "du", "ic", "al", "ql", "...",
     "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7");

dcl  bool_word (0:15) char (6) aligned int static varying
     init ("clear", "and", "andnot", "move", "", "", "xor", "or",
     "", "", "", "", "invert", "", "nand", "set");

dcl 1 descriptor based aligned,			/* EIS descriptor */
    2 address bit (18) unal,
    2 char bit (2) unal,
    2 bit bit (4) unal,
    2 length bit (12) unal;

/*  */

	number = arg_number;
	print_instr = "1"b;
	real_offset_entry = "0"b;
	p = t_pt;

begin:	substr (line, 11, 3) = "   ";
	eis = "0"b;
	irand = 0;

	do no_to_print = 1 to number;

	     comment = "";
	     tag = "   ";
	     substr (line, 7, 2) = "  ";
	     cstring = binoct (p -> word (0));

	     if eis then op_index = 0;

	     else do;
		op_index = fixed (p -> instruction.op_code, 10);
		op_code = rtrim(opcode (op_index));
	     end;

	     if num_words (op_index) > 1 then call eis_instruction;

	     else do;
		has_ic, double, repeat_inst = "0"b;

		eis_desc = eis & (ind_desc | desc_word ^= "arg");
		if eis_desc then call eis_descriptor;

		else do;
		     substr (line, 13, 2) = "  ";
		     substr (line, 15, 6) = substr (cstring, 2, 5);
		     substr (line, 21, 5) = substr (cstring, 7, 4);
		     substr (line, 26, 8) = substr (cstring, 11, 2) || ht || op_code;
		     k = 34;

		     ext_base = p -> instruction.ext_base;

		     if op_code = "rpd  " | op_code = "rpt  " | op_code = "rpl  " then do;
			repeat_inst = "1"b;
			call ioa_$rsnnl ("^d", tag, j, fixed (p -> instruction.tag, 6));
			offset = fixed (substr (p -> half.left, 1, 8), 8);
			substr (line, 14, 1) = rtrim(cstring);
			call ioa_$rsnnl ("	^d", buff, j, offset);
			substr (line, k, j) = buff;
			k = k + j;
		     end;

		     else do;
			if num_desc (op_index) ^= 0 then
			     tag = substr (binoct ((p -> instruction.tag)), 1, 2);

			else do;
			     if p -> instruction.tag then tag = modifier (fixed (p -> instruction.tag, 6));
			     double = substr (op_code, 1, 2) = "df" | substr (op_code, 3, 2) = "aq" | substr (op_code, 4, 2) = "aq";
			     has_ic = p -> instruction.tag = "000100"b; /* IC */
			end;
			call address;
		     end;

		     call set_tag;
		end;

/* Print data referred to by self relative address: (tab) (tab) data offset = contents */

		if has_ic then do;
		     if real_offset_entry then pt = ptr (p, real_offset + offset - irand);
		     else pt = addrel (p, offset-irand);
		     substr (line, k, 8) = htht || binoct (rel (pt));
		     k = k + 8;

		     if substr (op_code, 1, 1) ^= "t" then do;
			comment = " = " || binoct (pt -> word (0));
			if double then comment = comment || " " || binoct (pt -> word (1));
		     end;
		end;

		else if ext_base & (p -> instruction.base = "000"b) then do; /* info for pr0 only */

		     if op_code = "xec  " then do;
			pt = addrel (addr (pl1_operators_$operator_table), offset);
			op_index = fixed (pt -> instruction.op_code, 10);
			if num_words (op_index) > 1 then do;

/* we are executing an EIS instruction in pl1_operators_ */

			     call init_eis;

			     do j = 1 to ndesc;
				ebase (j) = "1"b;
				len_reg (j) = ^ decimal;
				ic (j) = "0"b;
			     end;
			end;
		     end;

		     if tag ^= " " then do;
			call find_operator_name_ ("pl1_operators_", p, op_name);
			if op_name ^= " " then do;
			     substr (line, k, 34) = htht || op_name;
			     k = k + 34;
			end;

		     end;
		end;
		if ^eis_desc & ^repeat_inst & p -> instruction.inhibit then comment = comment || " interrupt inhibit";

	     end;

	     if comment ^= "" then do;
		j = length (comment);
		substr (line, k, j) = comment;
		k = k + j;
	     end;

	     if print_instr then call ioa_$ioa_stream (output_switch, "^6o ^a", fixed (rel (p), 17), substr (line, 11, k-11));

	     else do;				/* return string for one line only */
		j = k - 11;			/* save length of strjng */
		k = 1;
		call bin_to_oct (real_offset);
		arg_string = substr (line, 1, k-1) || substr (line, 11, j);
		return;
	     end;

	     if eis
	     then do;
		irand = irand + 1;
		if irand > nrands then do;
		     eis = "0"b;
		     irand = 0;
		end;
		else if irand > ndesc
		then op_code, desc_word = "arg";
	     end;

	     p = addrel (p, 1);
	end;

	return;


/*  */
/*  Entry point to return a formatted string with the disassembled instruction.  The
   real offset is returned in the string.  */

amu_print_text_$real_offset: entry (t_pt, arg_string, arg_offset);


	p = t_pt;
	real_offset = arg_offset;
	number = 1;				/* process one word only */
	print_instr = "0"b;				/* return string instead */
	real_offset_entry = "1"b;
	go to begin;

amu_print_text_$format: entry (t_pt, arg_string);

	number = 1;
	p = t_pt;
	real_offset = fixed (rel (p), 18);
	print_instr = "0"b;
	real_offset_entry = "0"b;
	go to begin;

bin_to_oct: proc (number);

dcl (m, number) fixed bin (18);

	     call ioa_$rsnnl ("^o", buff, m, number);
	     substr (line, k, m) = buff;
	     k = k + m;

	end bin_to_oct;


init_eis:	proc;

	     eis = "1"b;
	     nrands = num_words (op_index) - 1;
	     ndesc = num_desc (op_index);
	     decimal = dtype (op_index) = 2;
	     desc_word = desc_op (dtype (op_index));
	     desc_type = dtype (op_index);
	     irand = 0;

	end init_eis;

/*  */
eis_instruction: proc;

	     call init_eis;

	     substr (line, 13, 4) = substr (cstring, 1, 3);
	     substr (line, 17, 4) = substr (cstring, 4, 3);
	     substr (line, 21, 4) = substr (cstring, 7, 3);
	     substr (line, 25, 3) = substr (cstring, 10, 3);

	     substr (line, 28, 1) = ht;
	     substr (line, 29, 5) = op_code;
	     substr (line, 34, 1) = ht;

	     k = 35;

	     do j = 1 to ndesc;
		string (mod_factor) = substr (p -> word (0), mf (j), 7);
		ebase (j) = mod_factor.ext_base;
		len_reg (j) = mod_factor.length_in_reg;
		idesc (j) = mod_factor.indirect_descriptor;

		substr (line, k, 1) = "(";
		k = k + 1;
		need_comma = "0"b;

		if ebase (j) then do;
		     substr (line, k, 2) = "pr";
		     k = k + 2;
		     need_comma = "1"b;
		end;

		if len_reg (j) then do;
		     if need_comma then do;
			substr (line, k, 1) = ",";
			k = k + 1;
		     end;
		     substr (line, k, 2) = "rl";
		     k = k + 2;
		     need_comma = "1"b;
		end;

		if idesc (j) then do;
		     if need_comma then do;
			substr (line, k, 1) = ",";
			k = k + 1;
		     end;
		     substr (line, k, 2) = "id";
		     k = k + 2;
		     need_comma = "1"b;
		end;

		if mod_factor.tag then do;
		     if need_comma then do;
			substr (line, k, 1) = ",";
			k = k + 1;
		     end;
		     ic (j) = mod_factor.tag = "0100"b; /* IC */
		     substr (line, k, 2) = eis_modifier (fixed (mod_factor.tag, 4));
		     k = k + 2;
		end;
		else ic (j) = "0"b;

		substr (line, k, 2) = "),";
		k = k + 2;
	     end;


	     if substr (p -> word (0), 10, 1) then do;
		substr (line, k, 12) = "enablefault,";
		k = k + 12;
	     end;

	     if desc_word = "desc9a"
	     then if ndesc < 3 then do;
		     if substr (op_code, 1, 2) ^= "sc"
		     then substr (line, k, 5) = "fill(";
		     else substr (line, k, 5) = "mask(";
		     k = k + 5;
		     substr (line, k, 3) = substr (cstring, 1, 3);
		     k = k + 3;
		     substr (line, k, 1) = ")";
		     k = k + 1;
		end;
		else k = k - 1;
	     else if desc_word = "descb" then do;
		substr (line, k, 7) = "fill(" || digit (fixed (substr (p -> word (0), 1, 1), 1)) || ")"; /* fill(N) */
		k = k + 7;

		if op_code ^= "cmpb " then do;
		     substr (line, k, 6) = ",bool(";
		     k = k + 6;
		     j = fixed (substr (p -> word (0), 6, 4), 4);
		     m = length (bool_word (j));
		     if m > 0 then do;
			substr (line, k, m) = bool_word (j);
			k = k + m;
		     end;
		     else do;
			substr (line, k, 1) = digit (fixed (substr (p -> word (0), 6, 1), 1));
			substr (line, k+1, 1) = digit (fixed (substr (p -> word (0), 7, 3), 3));
			k = k + 2;
		     end;
		     substr (line, k, 1) = ")";
		     k = k + 1;
		end;
	     end;
	     else if substr (p -> word (0), 11, 1) then do;
		substr (line, k, 5) = "round";
		k = k + 5;
	     end;
	     else k = k - 1;

	     return;

	end eis_instruction;

/*  */

eis_descriptor: proc;

dcl  len fixed bin (18);
dcl  type fixed bin;				/* descriptor type */

dcl 1 n_desc aligned based (p),
    2 y bit (18) unal,				/* address field */
    2 CN bit (3) unal,				/* character position */
    2 TN bit (1) unal,				/* type 0 = 9bit; 1 = 4 bit */
    2 S bit (2) unal,				/* sign type 0 = fl, 1 = ls, 2 = ts, 3 = ns */
    2 SF bit (6) unal,				/* scale factor */
    2 N bit (6) unal;				/* length */

dcl 1 b_desc aligned based (p),			/* bit descriptor */
    2 y bit (18) unal,				/* address field */
    2 c bit (2) unal,				/* 9 bit offset */
    2 b bit (4) unal,				/* bit offset */
    2 N bit (12) unal;				/* length */

dcl 1 a_desc aligned based (p),			/* alpha-numeric descriptor */
    2 y bit (18) unal,				/* address field */
    2 CN bit (3) unal,				/* character offset */
    2 TA bit (2) unal,
    2 pad bit (1) unal,				/* always zero */
    2 N bit (12) unal;				/* length */

dcl  table_n_S (0:3) char (2) int static init ("fl", "ls", "ts", "ns");
dcl  table_a_TA (0:3) char (1) int static init ("9", "6", "4", "?");

	     ind_desc = idesc (irand);
	     if ind_desc then do;
		call ind_descriptor;
		return;
	     end;

	     substr (line, 13, 2) = "  ";
	     substr (line, 15, 6) = substr (cstring, 2, 5);
	     substr (line, 21, 3) = substr (cstring, 7, 2);
	     substr (line, 24, 4) = substr (cstring, 9, 4);
	     substr (line, 28, 1) = ht;

	     ext_base = ebase (irand);
	     has_ic = ic (irand);

	     type = desc_type;
	     if op_code = "btd" & irand = 1 then type = 0;
	     else if op_code = "dtb"  | op_code = "mvne" then if irand > 1 then type = 0;

	     if type = 0 then do;			/*  alpha-nummeric descriptor */
		desc_word = "desc" || table_a_TA (fixed (a_desc.TA, 2)) || "a";
		if a_desc.TA = "00"b then fract_offset = fixed (substr (a_desc.CN, 1, 2), 2);
		else fract_offset = fixed (a_desc.CN, 3);
		len = fixed (a_desc.N, 12);
	     end;

	     else if type = 1 then do;		/* bit descriptor */
		desc_word = "descb";
		len = fixed (b_desc.N, 12);
		fract_offset = fixed (b_desc.c, 2) * 9 + fixed (b_desc.b, 4);
	     end;

	     else do;				/* numeric descriptor */
		if n_desc.TN then do;
		     desc_word = "desc4";
		     fract_offset = fixed (n_desc.CN,3);
		end;
		else do;
		     desc_word = "desc9";
		     fract_offset = fixed (substr (n_desc.CN, 1, 2), 2);
		end;
		desc_word = desc_word || table_n_S (fixed (n_desc.S, 2));
		len = fixed (n_desc.N, 6);

		if n_desc.S then do;		/*  for S = 00 there is no scale factor */
		     scale = fixed (n_desc.SF, 6);
		     if scale > 32 then scale = scale - 64;
		end;
	     end;

/*  desc_word   address(fract_offset),tag,length,scale   */

	     k = length (desc_word);
	     substr (line, 29, k) = desc_word;
	     k = k + 29;
	     call address;

	     if fract_offset ^= 0 then do;
		call ioa_$rsnnl ("(^d)", buff, j, fract_offset);
		substr (line, k, j) = buff;
		k = k + j;
	     end;

	     if len_reg (irand) then do;		/* print register which contains length */
		tag = eis_modifier (fixed (substr (p -> descriptor.length, 9, 4), 4));
		call set_tag;
	     end;

	     else do;				/* print length as given */
		substr (line, k, 1) = ",";
		k = k + 1;
		call bin_to_oct (len);
	     end;

	     if type = 2 then if n_desc.S then do;	/* scale factor for numeric only */
		     substr (line, k, 1) = ",";
		     k = k+1;
		     call bin_to_oct (scale);
		end;

	     return;

	end eis_descriptor;

/*  */

ind_descriptor: proc;

dcl 1 i_desc aligned based (p),			/* indirect descriptor */
    2 y bit (18) unal,				/* address field */
    2 pad bit (11) unal,				/* always zero */
    2 extbase bit (1) unal,				/* PR mod */
    2 pad1 bit (2) unal,				/* always zero */
    2 tag bit (4) unal;				/* reg mod */


	     substr (line, 13, 2) = "  ";
	     substr (line, 15, 6) = substr (cstring, 2, 5);
	     substr (line, 21, 5) = substr (cstring, 7, 4);
	     substr (line, 26, 2) = substr (cstring, 11, 2);
	     substr (line, 28, 1) = ht;

	     ext_base = i_desc.extbase;
	     has_ic = (i_desc.tag = "0100"b);
	     desc_word = "arg";

	     k = length (desc_word);
	     substr (line, 29, k) = desc_word;
	     k = k + 29;
	     call address;

	     if i_desc.tag then do;
		substr (line, k, 3) = "," || eis_modifier (fixed (i_desc.tag, 4));
		k = k + 3;
	     end;
	     return;
	end ind_descriptor;

/*  */

/* This procedure disassembles the address portion.  It adds: tab [prN|] offset
   It also sets the first octal digit so a blank will separate the register from the rest of the address field.

   cstring	     The octal representation of the word.

   ext_base	     ON if the address uses a register.
*/

address:	proc;

	     substr (line, k, 1) = ht;
	     k = k + 1;

	     if ext_base then do;
		substr (line, k, 4) = base (fixed (p -> instruction.base, 3));
		offset = fixed (p -> instruction.offset, 15);
		if offset > 16384 then offset = offset - 32768;
		k = k+4;
		substr (line, 13, 1) = rtrim(cstring);
	     end;

	     else do;
		offset = fixed (p -> half.left, 18);
		if offset > 131072 then if tag ^= "du " & tag ^= "dl " then offset = offset - 262144; /* 2's comp */
		substr (line, 14, 1) = rtrim(cstring);
	     end;


	     call bin_to_oct (offset);

	end address;


/*  This procedure sets the tag in the instruction line. */

set_tag:	proc;

	     if tag ^= " " then do;
		substr (line, k, 4) = "," || tag;
		k = k + 2;
		if substr (line, k, 1) ^= " " then k = k + 1;
		if substr (line, k, 1) ^= " " then k = k + 1;
	     end;

	     return;
	end set_tag;

binoct: proc (bits) returns (char (12) aligned);
        dcl bits bit (*) aligned parameter;
        dcl c12 char (12) aligned;

        call ioa_$rsnnl ("^12.3b", c12, (0), bits);
        return (c12);
end binoct;
     end;




		    amu_replace_trans_.pl1          07/28/87  0939.7rew 07/28/87  0924.4       27162



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-01-16,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-17,Fawcett), install(87-07-28,MR12.1-1049):
     Turn on the "replaced" flag in the translation_table when segment is
     replaced.
                                                   END HISTORY COMMENTS */


amu_replace_trans_: proc (P_amu_info_ptr, P_dir_name, P_entry_name, P_segno, P_code);

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

dcl  P_amu_info_ptr ptr;
dcl  P_dir_name char (168);
dcl  P_entry_name char (32);
dcl  P_segno fixed bin;
dcl  P_code fixed bin (35);

dcl  1 trans_space like translation;
dcl  bit_count fixed bin (24);
dcl  seg_ptr ptr;
dcl  changed_idx bit (1);
dcl  code fixed bin (35);
dcl  old_proc_idx fixed bin;
dcl  segno fixed bin;
dcl  amu_$fdump_mpt_change_idx entry (ptr, fixed bin);
dcl  amu_$fdump_mpt_revert_idx entry (ptr);
dcl  amu_$return_val_per_process entry (ptr, fixed bin) returns (bit (1));
dcl  amu_$translate_force_add entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));

dcl (addr, divide, mod, null) builtin;

	segno = P_segno;	
	changed_idx = ""b;
	amu_info_ptr = P_amu_info_ptr;
	translation_ptr = addr (trans_space);
	old_proc_idx = -1;
	if ^amu_$return_val_per_process (amu_info_ptr, segno) then do;
	     old_proc_idx = amu_info.process_idx;
	     if amu_info.type ^= SAVED_PROC_TYPE then call amu_$fdump_mpt_change_idx (amu_info_ptr, 0);
	     changed_idx = "1"b;
	end;

	seg_ptr = null ();
	call hcs_$initiate_count (P_dir_name, P_entry_name, "", bit_count, 1, seg_ptr, code);
	if seg_ptr = null () then do;
	     P_code = code;
	     return;
	     end;
	translation.segno = P_segno;
	translation.flags.two_part = "0"b;
	translation.flags.in_dump = "0"b;
	translation.flags.in_temp_seg = "0"b;
	translation.flags.in_perm_seg = "1"b;
	translation.part1.ptr = seg_ptr;
	translation.part1.lth = divide (bit_count, 36, 19);
	if mod (bit_count, 36) > 0 then translation.part1.lth = translation.part1.lth + 1;
	translation.part2.ptr = null ();
	translation.part2.lth = 0;
	translation.flags.replaced = "1"b;
	call amu_$translate_force_add (amu_info_ptr, translation_ptr, P_segno, code);
	if changed_idx then call amu_$fdump_mpt_revert_idx (amu_info_ptr);
	if code ^= 0 then do;
	     P_code = code;
	     return;

	     end;
	P_code = 0;
	return;
%page;
%include amu_translation;
%page;
%include amu_info;
     end amu_replace_trans_;





		    amu_return_val_.pl1             11/19/84  1144.9rew 11/15/84  1445.4       29520



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_return_val_: proc;
	return;

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* This proc will get the miscellaneous values for FDUMPS */

/* cpu_tag_from_idx
   dbr_from_idx
   idx_from_dbr
   cpu_tag_from_dbr

   BITS:
   per_process
*/



dcl  P_amu_info_ptr ptr;
dcl  P_dbr fixed bin (24);
dcl  P_idx fixed bin;
dcl  P_segno fixed bin;


dcl  i fixed bin (17);
dcl  search_dbr fixed bin (24);
dcl  segment fixed bin;

dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));


dcl  (bit, null) builtin;


cpu_tag_from_idx:
     entry (P_amu_info_ptr, P_idx) returns (char (1));
	amu_info_ptr = P_amu_info_ptr;
	i = P_idx;
	return (fdump_process_table.array (i).cpu_name);

/* end cpu_tag_from_idx */

dbr_from_idx:
     entry (P_amu_info_ptr, P_idx) returns (fixed bin (24));
	amu_info_ptr = P_amu_info_ptr;
	i = P_idx;
	return (fdump_process_table.array (i).dbr);

idx_from_dbr:
     entry (P_amu_info_ptr, P_dbr) returns (fixed bin (17));
	amu_info_ptr = P_amu_info_ptr;
	search_dbr = P_dbr;
	do i = 0 to fdump_process_table.size;
	     if search_dbr = fdump_process_table.array (i).dbr then return (i);
	end;
	return (-1);				/* process not dumped */

/* end of idx_from_dbr */


cpu_tag_from_dbr:
     entry (P_amu_info_ptr, P_dbr) returns (char (1));
	amu_info_ptr = P_amu_info_ptr;
	search_dbr = P_dbr;
	do i = 0 to fdump_process_table.size;
	     if search_dbr = fdump_process_table.array (i).dbr then return (fdump_process_table.array (i).cpu_name);
	end;
	return ("");				/* returnn null if not found */
						/* end of cpu_tag_from_dbr */


per_process:
     entry (P_amu_info_ptr, P_segno) returns (bit (1));
	segment = P_segno;
	amu_info_ptr = P_amu_info_ptr;
	if segment <= hardcore_info.hcs_count then do;
	     if segment ^= hardcore_info.segno.prds then
		if segment ^= hardcore_info.segno.dseg then
		     if segment ^= hardcore_info.segno.pds then
			if segment ^= hardcore_info.segno.kst then
			     return ("0"b);
			else ;
		     else ;
		else ;
	     else ;
	     return ("1"b);
	     end;
	return ("1"b);

amu_return_val_$phcs_ok:
     entry () returns (bit (1));
dcl  rs_mode fixed bin (5);
dcl  execute bit (5) init ("00100"b);
dcl  phcsp ptr;
dcl  code fixed bin (35);
	call hcs_$initiate (">system_library_1", "phcs_", "", 0, 0, phcsp, code);
	if phcsp ^= null then do;			/* if can be initiated */
	     call hcs_$fs_get_mode (phcsp, rs_mode, code);/* check caller's access */
	     if code = 0 then
		if bit (rs_mode) & execute then /* if execute, then priv. process */ return ("1"b);
						/* user has access to phcs_, set switch */
	     end;
	return ("0"b);

/* end phcs_ok entry */

%page;
%include amu_info;
%page;
%include amu_fdump_info;
%page;
%include amu_hardcore_info;
%page;
%include amu_process_info;
%page;
%include amu_definitions;
     end amu_return_val_;




		    amu_search_path_.pl1            02/16/88  1453.7r w 02/16/88  1409.7       52146



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_search_path_: proc;
	return;					/* not an entry */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

dcl  P_dump_path_ptr ptr;
dcl  P_object_path_ptr ptr;
dcl  P_fdump_name char (*);
dcl  P_code fixed bin (35);
dcl  search_paths_$set entry (char (*), ptr, ptr, fixed bin (35));
dcl  search_paths_$get entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35));
dcl  cleanup condition;
dcl  system_free_area area based (system_free_ptr);
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  (
     error_table_$new_search_list,
     error_table_$action_not_performed,
     error_table_$nomatch,
     error_table_$no_search_list
     ) fixed bin (35) ext static;
dcl  system_free_ptr ptr;
dcl  com_err_ entry () options (variable);
dcl  ecode fixed bin (35);
dcl  sl_name char (32) init ("");
dcl  my_entry_name char (32);
dcl  starname char (32);
dcl  not_found bit (1);
dcl  path_idx fixed bin;
dcl  get_dump_paths bit (1) init ("0"b);
dcl  get_object_paths bit (1) init ("0"b);
dcl  (addr, null, sum) builtin;


%page;
amu_search_path_$get_dump_paths:
     entry (P_dump_path_ptr, P_code);

	my_entry_name = "amu_search_path_$get_dump_paths";
	get_dump_paths = "1"b;
	go to dump_common;

amu_search_path_$set_dump_paths:
     entry (P_dump_path_ptr, P_fdump_name, P_code);

	my_entry_name = "amu_search_path_$set_dump_paths";
	get_dump_paths = "0"b;
dump_common:
	sl_name = "dumps";
	system_free_ptr = get_system_free_area_ ();
	call search_paths_$get (sl_name, sl_control_default, "", null (), system_free_ptr, sl_info_version_1, sl_info_p,
	     ecode);

	if ecode = error_table_$no_search_list then do;	/* set default */
	     sl_info_num_paths = 1;
	     allocate sl_info in (system_free_area) set (sl_info_p);
	     sl_info.version = sl_info_version_1;
	     sl_info.num_paths = 1;
	     sl_info.paths (1).code = 0;
	     sl_info.paths (1).type = ABSOLUTE_PATH;
	     sl_info.paths (1).pathname = ">dumps";

	     call search_paths_$set (sl_name, null (), sl_info_p, ecode);
	     if ecode ^= 0 then do;
		if ecode ^= error_table_$new_search_list then do;
		     P_dump_path_ptr = null ();
		     P_code = ecode;
		     end;
		else ecode = 0;
		end;
	     end;

	else if ecode ^= 0 then do;
	      P_code = ecode;
	     return;
	     end;

	if get_dump_paths = "1"b then do;
	     P_dump_path_ptr = sl_info_p;
	     P_code = ecode;
	     return;
	     end;

	not_found = "1"b;
	do path_idx = 1 to sl_info.num_paths while (not_found);
	     call check_dir (sl_info.paths (path_idx).pathname, not_found);
	     if ^not_found then goto FOUND_DUMP;
	end;
	if not_found then do;
	     P_dump_path_ptr = null ();
	     P_code = ecode;
	     return;
	     end;
FOUND_DUMP:
	P_dump_path_ptr = addr (sl_info.paths (path_idx).pathname);
	P_code = 0;
	return;
%page;
amu_search_path_$get_object_paths:
     entry (P_object_path_ptr, P_code);

	get_object_paths = "1"b;
	go to object_common;

amu_search_path_$set_object_paths:
     entry (P_object_path_ptr, P_code);

	get_object_paths = "0"b;

object_common:
	sl_name = "hardcore";
	system_free_ptr = get_system_free_area_ ();
	call search_paths_$get (sl_name, sl_control_default, "", null (), system_free_ptr, sl_info_version_1, sl_info_p,
	     ecode);
	if ecode = error_table_$no_search_list then do;	/* set default */
	     sl_info_num_paths = 1;
	     allocate sl_info in (system_free_area) set (sl_info_p);
	     sl_info.version = sl_info_version_1;
	     sl_info.num_paths = 1;
	     sl_info.paths (1).code = 0;
	     sl_info.paths (1).type = ABSOLUTE_PATH;
	     sl_info.paths (1).pathname = ">library_dir_dir>hardcore>execution";
	     call search_paths_$set (sl_name, null (), sl_info_p, ecode);
	     if ecode ^= 0 then do;
		if ecode ^= error_table_$new_search_list then do;
		     P_object_path_ptr = null ();
		     P_code = ecode;
		     end;
		else ecode = 0;
		end;
	     end;

	P_object_path_ptr = sl_info_p;
	P_code = ecode;
	return;

%page;
check_dir:
     proc (check_path, not_here);
dcl  check_path char (168);
dcl  not_here bit (1);
dcl  dirname char (168);
	dirname = check_path;
	starname = "*.*.0." || P_fdump_name;
	star_entry_ptr = null ();
	star_names_ptr = null ();

	on condition (cleanup)
	     begin;

		if star_names_ptr ^= null () then free star_names in (system_free_area);
		if star_entry_ptr ^= null () then free star_entries in (system_free_area);
	     end;


	call hcs_$star_ (dirname, starname, star_ALL_ENTRIES, addr (system_free_area), star_entry_count, star_entry_ptr,
	     star_names_ptr, ecode);
	if ecode ^= 0 then do;
	     if ecode = error_table_$nomatch then do;
		not_here = "1"b;
		goto FREE;
		end;
	     else do;
		not_here = "1"b;
		call com_err_ (ecode, my_entry_name, "");
		end;
	     end;					/* found it */
	not_here = "0"b;
FREE:
	if star_names_ptr ^= null () then free star_names in (system_free_area);
	if star_entry_ptr ^= null () then free star_entries in (system_free_area);
	revert condition (cleanup);
	if star_entry_count > 1 then do;		/* must have only one */
	     call ioa_ ("There appear to be several copies of ERF ^a in ^a", P_fdump_name, dirname);
	     ecode = error_table_$action_not_performed;
	     end;

     end check_dir;
%page;
%include sl_info;
%page;
%include sl_control_s;
%page;
%include star_structures;


     end amu_search_path_;







		    amu_search_seg_.pl1             07/28/87  0939.7rew 07/28/87  0924.4       54288



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(86-12-02,Farley), approve(87-07-09,MCR7746),
     audit(87-07-16,Fawcett), install(87-07-28,MR12.1-1049):
     Corrected problem with array bounds of part1 & part2. Was going 1 over..
                                                   END HISTORY COMMENTS */


/* Modified 02/19/86 by Paul Leatherman to set header when seg not found */

amu_search_seg_:
     proc (P_amu_info_ptr, P_af, af_len, P_segno, P_offset, P_range, P_string, P_code);

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

dcl  P_amu_info_ptr ptr,
     P_af ptr,
     P_segno fixed bin,
     P_offset fixed bin (18),
     P_range fixed bin (18),
     P_string char (12),
     af_len fixed bin(21),
     P_code fixed bin (25);

dcl  return_af char(af_len) var based(P_af);
dcl  af_sw bit(1);
dcl  segno fixed bin;
dcl  (offset, word_idx, range, part1_end, part2_end, part1_start, part2_start) fixed bin (18);
dcl  char_idx fixed bin;
dcl  code fixed bin (35);
dcl  string char (12);
dcl  one_found bit (1);
dcl  header char (80);
dcl  header_printed bit (1);
dcl  foo_len fixed bin (21);
dcl  ignore fixed bin;

dcl  1 trans_space like translation;
dcl  part1_word (part1_start:part1_end) bit (36) aligned based (translation.part1.ptr);
dcl  part2_word (part2_start:part2_end) bit (36) aligned based (translation.part2.ptr);
dcl  (search_data, search_mask) char (12) aligned;
dcl  mask bit (36) aligned;
dcl  data bit (36) aligned;
dcl  old_proc_idx fixed bin;
dcl  out_str char(256) var;
dcl  bit_string (12) bit (3) unal based;
dcl  1 char_bits (12) based,
       2 two bit (6) unal,
       2 last bit (3) unal;

dcl  amu_et_$no_translation fixed bin (35) ext static;
dcl  amu_et_$seg_not_dumped fixed bin (35) ext static;


dcl  amu_$translate_get entry (ptr, fixed bin, ptr, fixed bin (35)),
     amu_$translate_add entry (ptr, ptr, fixed bin, fixed bin (35)),
     amu_$fdump_translate_get_translation entry (ptr, ptr, ptr, fixed bin (35)),
     amu_$get_name_no_comp entry (ptr, ptr) returns(char(*)),
     amu_$return_val_per_process entry (ptr, fixed bin) returns (bit (1)),
     amu_$fdump_mpt_change_idx entry (ptr, fixed bin),
     (
     ioa_,
     ioa_$rsnnl
     ) entry () options (variable);

dcl (addr, baseptr, min, null, translate) builtin;
%page;
	amu_info_ptr = P_amu_info_ptr;
	string = P_string;
	offset = P_offset;
	range = P_range;
	segno = P_segno;
	one_found = "0"b;
          if P_af ^= null() then do;
	   af_sw = "1"b;
	   return_af = "";
	   end;
	else af_sw = "0"b;

	old_proc_idx = -1;
	if ^amu_$return_val_per_process (amu_info_ptr, segno) then do;
	     old_proc_idx = amu_info.process_idx;
	     call amu_$fdump_mpt_change_idx (amu_info_ptr, 0);
	     end;

	call amu_$translate_get (amu_info_ptr, segno, translation_ptr, code);
	if code ^= 0 then do;
	     if code = amu_et_$no_translation then do;
	          if amu_info.type = SAVED_PROC_TYPE then do;
		   P_code = code;
		   return;
		   end;
		translation_ptr = addr (trans_space);

		call amu_$fdump_translate_get_translation (amu_info_ptr, baseptr (segno), translation_ptr, code);
		if code = amu_et_$seg_not_dumped then do;
		     P_code = code;
		     return;
		end;
		if code ^= 0 then goto ERROR;
		call amu_$translate_add (amu_info_ptr, translation_ptr, segno, code);
		if code ^= 0 then goto ERROR;
		end;
	     else goto ERROR;
	     end;

	search_mask = translate (string, "077777777", "-01234567");
	search_data = translate (string, "001234567", "-01234567");
	part1_start = 0;
	part1_end = translation.part1.lth - 1;
	part2_start = translation.part1.lth;
	part2_end = translation.part1.lth + translation.part2.lth - 1;
	do char_idx = 1 to 12;
	     addr (data) -> bit_string (char_idx) = addr (search_data) -> char_bits (char_idx).last;
	     addr (mask) -> bit_string (char_idx) = addr (search_mask) -> char_bits (char_idx).last;
	end;
	if range ^= 0 then range = range + offset;
	if (range > (translation.part1.lth + translation.part2.lth)) | (range = 0) then
	     range = translation.part1.lth + translation.part2.lth - 1;
	

	call ioa_$rsnnl (" ^o ^a ^/^2xfrom ^o to ^o",header,foo_len,
	     segno,amu_$get_name_no_comp (amu_info_ptr,(baseptr(segno))),
	     offset,range);	

	header_printed = "0"b;
	
	do word_idx = offset to min (translation.part1.lth, range) - 1;

	     if (part1_word (word_idx) & mask) = data then do;
		if ^header_printed then do;
		     if ^af_sw then call ioa_ ("Segment ^a",header);
		     header_printed = "1"b;
		end;
		if af_sw then do;
		   call ioa_$rsnnl ("^o|^o ", out_str, ignore,segno, word_idx);
		   return_af = return_af || out_str;
		   end;
		else call ioa_ ("^o|^o = ^12.3b", segno, word_idx, part1_word (word_idx));
		one_found = "1"b;
		end;
	end;

	do word_idx = word_idx to range - 1;
	     if part2_word (word_idx) & mask = data then do;
		if ^header_printed then do;
		     if ^af_sw then call ioa_ ("Segment ^a",header);
		     header_printed = "1"b;
		end;
		if af_sw then do;
		   call ioa_$rsnnl ("^o|^o ", out_str, ignore,segno, word_idx);
		   return_af = return_af || out_str;
		   end;
		else call ioa_ ("^o|^o = ^12.3b", segno, word_idx, part2_word (word_idx));
		one_found = "1"b;
		end;
	end;

	code = 0;
ERROR:

	if ^one_found then
	     call ioa_ ("^/^13x No match in ^o ^a", segno,amu_$get_name_no_comp (amu_info_ptr,(baseptr(segno))));	
	if old_proc_idx >= 0 then call amu_$fdump_mpt_change_idx (amu_info_ptr, old_proc_idx);
	P_code = code;
	return;
%page;
%include amu_info;
%page;
%include amu_translation;


     end amu_search_seg_;




		    amu_slt_search_.pl1             07/28/87  0939.7rew 07/28/87  0930.0       32004



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-12-08,Farley), approve(87-07-09,MCR7746),
     audit(87-07-16,Fawcett), install(87-07-28,MR12.1-1049):
     Corrected get_init_seg_ptr entry to only check the segnam array when
     the slte.names_ptr is non-zero.
                                                   END HISTORY COMMENTS */


amu_slt_search_:
     proc;

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* Modified 17 Oct 84 by BLB to add the get_init_seg_ptr entry */
/* Modified 10 Jan 85 by BLB to correct the dcl of code to be fixed bin(35) */

/* Parameters */

dcl  P_sltp ptr;
dcl  P_names_ptr ptr;
dcl  P_name char (32);
dcl  P_segp ptr;
dcl  P_code fixed bin (35);
dcl  P_segno fixed bin;

/* Automatic */

dcl  code fixed bin (35);
dcl  found bit (1);
dcl  (i, j) fixed bin;
dcl  name char (32);
dcl  segno fixed bin (18);
dcl  segp ptr;

/* Entries */

dcl  ring0_get_$segptr_given_slt entry (char (*), char (*), ptr, fixed bin (35), ptr, ptr);

/* Builtins */

dcl  (addr, addrel, baseno, baseptr, fixed, hbound, min, null) builtin;

/* External static */

dcl  error_table_$action_not_performed ext static fixed bin (35);
%page;
amu_slt_search_$get_seg_ptr:
     entry (P_sltp, P_names_ptr, P_name, P_segp, P_code);
	code = 0;
	sltp = P_sltp;
	names_ptr = P_names_ptr;
	name = P_name;
	call ring0_get_$segptr_given_slt ("", name, segp, code, sltp, names_ptr);
	if code = 0 then P_segp = segp;
	P_code = code;
	return;

/**** ********************************************************************* ****/

amu_slt_search_$get_init_seg_ptr:
     entry (P_sltp, P_names_ptr, P_name, P_segp, P_code);

/*
   This entrypoint is used to find the segno and pointer given a name. Called only when looking at an
   early dump.
*/

	code = 0;
	sltp = P_sltp;
	P_segp = null ();
	names_ptr = P_names_ptr;
	name = P_name;
	found = "0"b;
	do i = 0 to min (slt.last_init_seg, hbound (slt.seg, 1)) while (^found);
	     sltep = addr (slt.seg (i));
	     if slte.names_ptr ^= ""b then do;		/* only valid if non-zero */
		namep = addrel (names_ptr, slte.names_ptr);
		do j = 1 to namep -> segnam.count while (^found);
		     if name = namep -> segnam.names (j).name then do;
			found = "1"b;
			segno = fixed (namep -> segnam.names (j).segno, 18);
			end;
		end;
		end;
	end;
	if ^found then
	     code = error_table_$action_not_performed;
	else P_segp = baseptr (segno);

	P_code = code;
	return;
%page;
amu_slt_search_$get_seg_num:
     entry (P_sltp, P_names_ptr, P_name, P_segno, P_code);
	code = 0;
	sltp = P_sltp;
	names_ptr = P_names_ptr;
	name = P_name;
	call ring0_get_$segptr_given_slt ("", name, segp, code, sltp, names_ptr);
	if code = 0 then P_segno = fixed (baseno (segp), 17);
	P_code = code;
	return;

%page;
amu_slt_search_$get_first_sup_seg:
     entry (P_sltp, P_segno);
	sltp = P_sltp;
	P_segno = slt.first_sup_seg;
	return;

%page;
amu_slt_search_$get_last_sup_seg:
     entry (P_sltp, P_segno);
	sltp = P_sltp;
	P_segno = slt.last_sup_seg;
	return;
%page;
%include slt;
%page;
%include slte;

     end amu_slt_search_;




		    amu_tc_data_.pl1                02/13/85  0937.5rew 02/13/85  0907.5       95400



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_tc_data_:
     proc (P_amu_info_ptr, argument);
	return;

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* this proc will deal with the tc_data seg it has 2 entry points */

/* dcl amu_$tc_data_get_apt_entry entry (ptr, char (3), fixed bin, ptr);
   call amu_$tc_data_get_apt_entry (amu_info_ptr,arg, apte_array_ptr,apte_array_index);
   where
   amu_info_ptr is a pointer to the main info structer for the fdump
   arg is the three character state
   ("run", "rdy", "wat", "blk", "stp", "ptl")
   apte_array_ptr is a pointer to an array (see apte_array)
   apte_array_index is where the last entry is in the array.
   (this is used as input and output)

   This entry will return the selected apte entries in the array and
   increment the index
*/

/* dcl amu_$tc_data_find_apte entry (ptr,fixed bin (24),ptr,fixed bin (35));
   call amu_$tc_data_find_apte (amu_info_ptr,dbr,aptep,code);
   where
   amu_info_ptr is a pointer to the main info for this fdump
   dbr is the dbr address value that is to be searched for
   aptep is the pointer that is returned for the found apte
   code the the error code retunred

   This entry will return the apte pointer given the dbr value if code = -1 then
   the dbr did not match any apte's
*/
dcl  APT_BASE fixed bin;
dcl  WCTE_WORDS fixed bin;
dcl  code fixed bin (35);
dcl  offset fixed bin (18);
dcl  P_amu_info_ptr ptr;
dcl  P_offset fixed bin (18);
dcl  P_aptep ptr;
dcl  P_code fixed bin (35);
dcl  P_dbr fixed bin (24);
dcl  P_all_sw bit (1);
dcl  P_return_ptr ptr;
dcl  P_rdy_sw bit(1);
dcl  P_return_index fixed bin;
dcl  dbr_search fixed bin (24);
dcl  i fixed bin;
dcl  rdy_sw bit(1);
dcl  return_index fixed bin;
dcl  return_ptr ptr;
dcl  1 apte_array (return_index) based (return_ptr),
       2 ptr ptr,
       2 off fixed bin (18),
       2 index fixed bin;

dcl  ioa_ entry () options (variable);
dcl  amu_$print_apte entry (ptr, ptr, fixed bin (18), fixed bin);
dcl  amu_$print_apte_bf entry (ptr, ptr, fixed bin (18));
dcl  amu_$check_info_hard entry (ptr);

dcl  (
     amu_et_$proc_not_dumped,
     amu_et_$entry_not_found
     ) fixed bin (35) ext;

dcl  RUNNING fixed bin init (1) static options (constant);
dcl  argument char (3);

dcl  all_sw bit (1) init ("0"b);
dcl  tc_datap ptr;

dcl (addr, addrel, binary, divide, 
     fixed, null, pointer, rel, substr, unspec)  builtin;
%page;
amu_tc_data_$get_apt_entry:
     entry (P_amu_info_ptr, arg_idx, process_id, apte_offset, P_return_ptr, P_return_index);

dcl arg_idx fixed bin;
dcl process_id bit(36);
dcl apte_offset fixed bin(18);
dcl ( arg_sw, apte_sw, pid_sw, want_it) bit(1);

    call amu_$check_info_hard (P_amu_info_ptr);
    amu_info_ptr = P_amu_info_ptr;
    call set_tcp_aptp;
    arg_sw, apte_sw, pid_sw, want_it = "0"b;
    return_ptr = P_return_ptr;
    return_index = P_return_index;

    if arg_idx > 0 then arg_sw = "1"b;			/* have to match on apte state		*/
    else if apte_offset >0 then apte_sw = "1"b;
    else if process_id > "0"b then pid_sw = "1"b;

    offset = fixed (rel (aptep), 18) - fixed (rel (tc_datap), 18);

    do i = 1 to hardcore_info.apt.count;
       if arg_sw then do;
          if arg_idx = fixed (apte.state, 17) then want_it = "1"b;
          end;
       else if apte_sw then do;
	if apte_offset = offset then want_it = "1"b;
	end;
       else if pid_sw then do;
          if process_id = apte.processid then want_it = "1"b;
	end;
       if want_it then do;
	return_index = return_index + 1;
	apte_array (return_index).ptr = aptep;
	apte_array (return_index).off = offset;
	apte_array (return_index).index = i;
	want_it = "0"b;
	end;
       aptep = addrel (aptep, hardcore_info.apt.size);
       offset = fixed (rel (aptep), 18) - fixed (rel (tc_datap), 18);
       end;


    P_return_index = return_index;
    return;


amu_tc_data_$tcq:
     entry (P_amu_info_ptr, P_all_sw, P_rdy_sw);

dcl apte_number fixed bin;
dcl wc_number fixed bin;
dcl first_aptep ptr;
dcl print_this_wc bit(1);
	amu_info_ptr = P_amu_info_ptr;
	call set_tcp_aptp;
	tcmp = tc_datap;
          rdy_sw = P_rdy_sw;				/* Print the eligible queue. */
	all_sw = P_all_sw;				/* Print unthreaded entruies also.		*/

	APT_BASE = fixed (tcm.apt_offset, 18);
	if APT_BASE = 0 then APT_BASE = 256;		/* old style tc_data */
	WCTE_WORDS = divide (APT_BASE - fixed (tcm.min_wct_index), 17, 17, 0);

	  call ioa_ ("ELIGIBLE QUEUE:^/Proc^8tDBR^17tState^27tProcess ID^39tCPU");
	aptep = addrel (tcmp, tcm.eligible_q_head.fp);
elig_apt_loop:
	if aptep ^= addr (tcm.ready_q_tail) then do;
	     offset = fixed (rel (aptep), 18) - fixed (rel (tcmp), 18);
	     call amu_$print_apte_bf (amu_info_ptr, aptep, offset);
	     aptep = addrel (tcmp, apte.thread.fp);
	     go to elig_apt_loop;
	     end;

	if ^(all_sw | rdy_sw) then return;			

/* Print the realtime queue. */

	if tcm.realtime_q.sentinel ^= "0"b then do;	/* look in realtime queue */
	     call ioa_ ("REALTIME QUEUE:");
	     aptep = addrel (tcmp, tcm.realtime_q.fp);
dead_apt_loop:
	     if aptep ^= addr (tcm.realtime_q) then do;
		offset = fixed (rel (aptep), 18) - fixed (rel (tcmp), 18);
		call amu_$print_apte_bf (amu_info_ptr, aptep, offset);
		aptep = addrel (tcmp, apte.thread.fp);
		go to dead_apt_loop;
		end;
	     end;

/* Print the interactive queue. */

	if tcm.apt_offset ^= "0"b then do;		/* look in interactvve queue */
	     if tcm.deadline_mode ^= 0 then
		call ioa_ ("DEADLINE QUEUE:");	/* processes with soft deadlines */
	     else call ioa_ ("INTERACTIVE QUEUE:");
	     aptep = addrel (tcmp, tcm.interactive_q.fp);
int_apt_loop:
	     if aptep ^= addr (tcm.interactive_q) then do;
		offset = fixed (rel (aptep), 18) - fixed (rel (tcmp), 18);
		call amu_$print_apte_bf (amu_info_ptr, aptep, offset);
		aptep = addrel (tcmp, apte.thread.fp);
		go to int_apt_loop;
		end;
	     end;

/* Print per-workclass queues. */

	if tcm.apt_offset ^= ""b then do;
	     wctep = addr (tcm.wcte (0));
	     do wc_number = 0 to 16;

		first_aptep = addrel (tcmp, wct_entry.thread.fp);
		print_this_wc = "0"b;

		/* print all queues, first check some things */
		if (tcm.deadline_mode = 0)		/* only if not in deadline mode */
		     & wct_entry.flags.defined	/* skip undefined ones */
		     & (wct_entry.realtime = 0)	/* skip realtime as not threaded here unless bug */
		     & wctep ^= first_aptep then	/* and skip the empties, too */
		     print_this_wc = "1"b;

		if print_this_wc then do;
		     call ioa_ ("WORKCLASS ^d QUEUE: credits = ^d ms.",
			wc_number, divide (wct_entry.credits, 1000, 17, 0), (first_aptep = wctep));
		     call print_queue (first_aptep, wctep);
		     end;

		wctep = addrel (wctep, WCTE_WORDS);
		end;				/* of loop through workclasses */
	     end;
          
          if ^all_sw then return;

/* Print unthreaded entries. */

          call ioa_ ("^/UNTHREADED:");
	do apte_number = 0 to tcm.apt_size - 1; 	/* loop through all the APTEs */
	     aptep = pointer (tcmp, (apte_number * tcm.apt_entry_size + binary (rel (addrel (tcmp, APT_BASE)), 17)));
	     offset = fixed (rel (aptep), 18) - fixed (rel (tcmp), 18);

	     if unspec (apte.thread) = ""b & apte.state ^= ""b then
	        call amu_$print_apte_bf (amu_info_ptr, aptep, offset);
	     else if apte.idle then call amu_$print_apte_bf (amu_info_ptr, aptep, offset);
	     end;

	return;					/* end tcq entry */

amu_tc_data_$find_apte:
     entry (P_amu_info_ptr, P_dbr, P_aptep, P_code);
	call amu_$check_info_hard (P_amu_info_ptr);
	amu_info_ptr = P_amu_info_ptr;
	call set_tcp_aptp;
	dbr_search = P_dbr;
	offset = fixed (rel (aptep), 18) - fixed (rel (tc_datap), 18);
	do i = 1 to hardcore_info.apt.count;
	     if dbr_search = binary (substr (unspec (apte.dbr), 1, 24)) then do;
		P_aptep = aptep;
		P_code = 0;
		return;
		end;
	     aptep = addrel (aptep, hardcore_info.apt.size);
	end;
	P_aptep = null ();
	P_code = -1;
	return;


amu_tc_data_$print_this_apte:
     entry (P_amu_info_ptr, P_offset, P_code);
	amu_info_ptr = P_amu_info_ptr;
	call set_tcp_aptp;

	offset = fixed (rel (aptep), 18) - fixed (rel (tc_datap), 18);
	do i = 1 to hardcore_info.apt.count;
	     if P_offset = offset then do;
		call amu_$print_apte (amu_info_ptr, aptep, offset, i);
		return;
		end;
	     aptep = addrel (aptep, hardcore_info.apt.size);
	     offset = fixed (rel (aptep), 18) - fixed (rel (tc_datap), 18);
	end;
	P_code = amu_et_$entry_not_found;
	return;
amu_tc_data_$get_dbr:
     entry (P_amu_info_ptr, P_offset, P_dbr);
	amu_info_ptr = P_amu_info_ptr;
	offset = P_offset;
	call set_tcp_aptp;
	aptep = addrel (tc_datap, offset);
	if apte.state = "0"b then P_dbr = -1;
	else P_dbr = binary (substr (unspec (apte.dbr), 1, 24));
	return;


amu_tc_data_$find_first_running:
     entry (P_amu_info_ptr, P_dbr, P_code);
	amu_info_ptr = P_amu_info_ptr;
	call set_tcp_aptp;
	do i = 1 to hardcore_info.apt.count;
	     if binary (apte.state) = RUNNING then do;
		P_dbr = binary (substr (unspec (apte.dbr), 1, 24));
		P_code = 0;
		return;
		end;
	     aptep = addrel (aptep, hardcore_info.apt.size);
	end;
	P_dbr = -1;
	P_code = amu_et_$proc_not_dumped;
	return;
%page;
print_queue:
          proc(Pfirst, Plast);

/* Prints a single workclass queue */

dcl (Pfirst, Plast) ptr parameter;

     do aptep = Pfirst
	      repeat (addrel (tcmp, apte.thread.fp))
                while (aptep ^= Plast);
                 
        offset = fixed (rel (aptep), 18) - fixed (rel (tcmp), 18);
        call amu_$print_apte_bf (amu_info_ptr, aptep, offset);
        end;

end print_queue;
%page;
set_tcp_aptp:
     proc;

	if hardcore_info.pointers.tc_data.fptr ^= null () then do;
	     tc_datap = hardcore_info.pointers.tc_data.fptr;
						/* tc_data is in dump */
	     aptep = hardcore_info.apt.foreign_ptr;
	     return;
	     end;


	else if hardcore_info.pointers.tc_data.lptr ^= null () then do;
	     tc_datap = hardcore_info.pointers.tc_data.lptr;
						/* tc_data is in local copy */
	     aptep = hardcore_info.apt.local_ptr;
	     return;
	     end;

	else do;
	     tc_datap = null ();
	     aptep = null ();
	     return;				/* we can not look at it */
	     end;
     end set_tcp_aptp;

%page;%include amu_info;
%page;%include amu_hardcore_info;
%page;%include apte;
%page;%include sdw;
%page;%include tcm;
%page;%include hc_lock;

     end amu_tc_data_;




		    amu_temp_seg_.pl1               11/19/84  1144.9rew 11/15/84  1445.4       23166



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_temp_seg_: proc ();

	return;					/* not an entrypoint */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* This procedure is used to allocate and release temp segments associated with
   various amu_ data structures. These temp segments are kept track of in a chain
   which is linked forward only.
*/

dcl  (
     P_amu_info_ptr pointer,
     P_copy_block_ptr pointer,
     P_caller char (*),
     P_seg_ptr pointer
     ) parameter;

dcl  code fixed bin (35);
dcl  copy_block_ptr pointer;
dcl  next_block pointer;

dcl  1 copy_block aligned based (copy_block_ptr),
       2 next pointer,
       2 seg_ptr pointer,
       2 area_ptr pointer,
       2 caller_name char (32) unaligned;

dcl  system_area_ptr pointer;
dcl  system_area area based (system_area_ptr);

dcl  amu_error_ entry options (variable);
dcl  get_temp_segment_ entry (char (*), pointer, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), pointer, fixed bin (35));

dcl  null builtin;

%page;

amu_temp_seg_$get:
     entry (P_amu_info_ptr, P_caller, P_copy_block_ptr, P_seg_ptr);

	amu_info_ptr = P_amu_info_ptr;
	allocate copy_block in (amu_area) set (copy_block_ptr);

	copy_block.area_ptr = amu_info.area_ptr;
	copy_block.caller_name = P_caller;

TRY_TO_GET_TEMP_SEGMENT:
	call get_temp_segment_ (copy_block.caller_name, copy_block.seg_ptr, code);

	if code ^= 0 then do;
	     call amu_error_ (amu_info_ptr, code, "Try terminating something and type start.");
	     goto TRY_TO_GET_TEMP_SEGMENT;
	     end;

	copy_block.next = P_copy_block_ptr;		/* thread it onto the chain */
	P_copy_block_ptr = copy_block_ptr;

	P_seg_ptr = copy_block.seg_ptr;

	return;					/* all done for this entrypoint */

%page;

amu_temp_seg_$release_all:
     entry (P_copy_block_ptr);

/* This entry is used to release all the copy blocks in a chain. */

	do copy_block_ptr = P_copy_block_ptr repeat (next_block) while (copy_block_ptr ^= null ());

	     call release_temp_segment_ (copy_block.caller_name, copy_block.seg_ptr, (0));

	     system_area_ptr = copy_block.area_ptr;
	     next_block = copy_block.next;

	     free copy_block in (system_area);
	end;

	P_copy_block_ptr = null ();

	return;

%page;
%include amu_info;

     end amu_temp_seg_;




		    amu_translate_.pl1              07/28/87  0939.7r w 07/28/87  0927.2       48501



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
amu_translate_: proc ();

	return;					/* not an entrypoint */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* This procedure manages the translation table associated with an amu_info.
   It adds, deletes, and locates translation entries.

   Note: for the moment, the translation table is just an unordered array. It would
   be good to make it ordered someday, so we could search it with a binary search.

   09/06/80 W. Olin Sibert
*/

dcl  (
     P_amu_info_ptr pointer,
     P_segno fixed bin,
     P_translation_ptr pointer,
     P_size fixed bin,
     P_code fixed bin (35)
     ) parameter;

dcl  idx fixed bin;
dcl  segno fixed bin;

dcl  amu_error_ entry options (variable);

dcl  (
     amu_et_$bad_segno,
     amu_et_$trans_exists,
     amu_et_$no_translation
     ) fixed bin (35) external static;

dcl  (addr, min, null, unspec) builtin;

%page;

amu_translate_$get:
     entry (P_amu_info_ptr, P_segno, P_translation_ptr, P_code);

/* This entry is used to get a pointer to the translation info for a particular segment */

	amu_info_ptr = P_amu_info_ptr;
	segno = P_segno;

	if (segno < 0) | (segno > 4095) then do;
	     call amu_error_ (amu_info_ptr, amu_et_$bad_segno, "^d", segno);
	     P_code = amu_et_$bad_segno;
	     return;
	     end;
	if ^translation_table.valid (segno) then do;	/* segno does not exist in foreign address space */
	     P_code = amu_et_$no_translation;
	     P_translation_ptr = null ();
	     return;
	     end;

	do idx = 1 to translation_table.n_entries;
	     if segno = translation_table.segno (idx) then do;
		P_translation_ptr = addr (translation_table.array (idx));
		P_code = 0;
		return;
		end;
	end;

	P_translation_ptr = null ();			/* didn't find it */
						/*	call amu_debug$proc (amu_info_ptr);   */
	P_code = amu_et_$no_translation;
	return;					/* end of code for this entrypoint */

%page;

amu_translate_$allocate:
     entry (P_amu_info_ptr, P_size);

/* This entry is used to initially allocate an empty translation table of the specified size */

	amu_info_ptr = P_amu_info_ptr;
	alloc_translation_table_max_entries = P_size;

	allocate translation_table in (amu_area) set (amu_info.translation_table_ptr);

	unspec (translation_table) = ""b;

	translation_table.max_entries = alloc_translation_table_max_entries;
	translation_table.n_entries = 0;

	return;					/* end of code for this entrypoint */

%page;

amu_translate_$add:
     entry (P_amu_info_ptr, P_translation_ptr, P_segno, P_code);

/* This entry is used to add a new translation to the list of translations. */

	amu_info_ptr = P_amu_info_ptr;
	segno = P_segno;
	if translation_table.valid (segno) then do;
	     P_code = amu_et_$trans_exists;
	     return;
	     end;

add_it:
	if translation_table.n_entries >= translation_table.max_entries then
						/* too big, must reallocate */
	     call reallocate_translation_table ();

	idx = translation_table.n_entries + 1;
	translation_table.array (idx) = P_translation_ptr -> translation, by name;
	translation_table.valid (segno) = "1"b;
	translation_table.used (idx) = "1"b;
	translation_table.n_entries = idx;
	P_code = 0;
	return;					/* end of code for this entrypoint */
amu_translate_$force_add:
     entry (P_amu_info_ptr, P_translation_ptr, P_segno, P_code);
	amu_info_ptr = P_amu_info_ptr;
	segno = P_segno;
	if translation_table.valid (segno) then do;
	     do idx = 1 to translation_table.n_entries;
		if translation_table.array (idx).segno = segno then do;
		     translation_table.array (idx) = P_translation_ptr -> translation;
		     P_code = 0;
		     return;
		     end;
	     end;
	     end;
	else goto add_it;
	return;



%page;

reallocate_translation_table:
     proc ();

/* This procedure reallocates the translation table, copying all the old information,
   and doubling the size of the table. */

dcl  old_tt pointer;
dcl  new_tt pointer;
dcl  copy_idx fixed bin;


	old_tt = amu_info.translation_table_ptr;

	if translation_table.max_entries >= 4096 then
	     call amu_error_ (amu_info_ptr, 0, "Translation table is full. Cannot reallocate.");

	alloc_translation_table_max_entries = min (4096, 2 * translation_table.max_entries);
	allocate translation_table in (amu_area) set (new_tt);

	unspec (new_tt -> translation_table) = ""b;
	new_tt -> translation_table.max_entries = alloc_translation_table_max_entries;
	new_tt -> translation_table.n_entries = old_tt -> translation_table.n_entries;
	new_tt -> translation_table.valid_array = old_tt -> translation_table.valid_array;
	new_tt -> translation_table.used_array = old_tt -> translation_table.used_array;

	do copy_idx = 1 to new_tt -> translation_table.n_entries;
	     new_tt -> translation_table.array (copy_idx) = old_tt -> translation_table.array (copy_idx);
	end;


	amu_info.translation_table_ptr = new_tt;
	process_info.address_map_ptr = new_tt;
	free old_tt -> translation_table in (amu_area);

	return;
     end reallocate_translation_table;

%page;
%include amu_info;
%page;
%include amu_translation;
%page;
%include amu_process_info;
     end amu_translate_;




		    arg_assign_.pl1                 10/24/88  1625.7r w 10/24/88  1401.2      100611



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-07-09,Parisek), approve(87-07-09,MCR7746),
     audit(87-07-16,Fawcett), install(87-07-28,MR12.1-1049):
     Correct condition handling.
                                                   END HISTORY COMMENTS */


arg_assign_: proc ();

	return;					/* not an entrypoint */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */

/* *	ARG_ASSIGN_  --  Utility procedure for options (variable) programs.
   *
   *	This procedure is used to assign values to and from references in an
   *	argument list. This is useful for options (variable) procedures, in that
   *	it allows the program to readily extract values from its argument list
   *	and assign them to its own variables.
   *
   *	All entries in arg_assign_ are declared options (variable), since the
   *	third argument may be of any type.
   *
   *	09/07/80, W. Olin Sibert, with a lot of help from probe_assign_value_.
*/

dcl  from_sw bit (1) aligned;
dcl  check_sw bit (1) aligned;

dcl  caller_alp pointer;
dcl  caller_argno fixed bin;				/* arg list info from our caller */
dcl  my_alp pointer;
dcl  my_arg_count fixed bin;
dcl  code fixed bin (35);
dcl  myname char (32);

dcl  1 arg_info aligned based,
       2 ndims fixed bin,
       2 comp_data aligned like computational_data;

dcl  1 arg1 aligned like arg_info;
dcl  1 arg2 aligned like arg_info;
dcl  1 to_arg aligned like arg_info;
dcl  1 from_arg aligned like arg_info;

dcl  (
     error_table_$bad_conversion,
     error_table_$noarg
     ) fixed bin (35) external static;

dcl  area_assign_ entry (pointer, pointer);
dcl  arg_assign_$to_arg entry options (variable);
dcl  assign_ entry (pointer, fixed bin, fixed bin (35), pointer, fixed bin, fixed bin (35));
dcl  assign_$computational_ entry (pointer, pointer, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  based_ptr pointer aligned based;			/* overlays for various data types */
dcl  based_integer fixed bin (35) aligned based;
dcl  based_packed_ptr pointer unaligned based;
dcl  based_label label based;
dcl  based_entry entry based;
dcl  based_file file based;

dcl  temp_ptr pointer;

dcl  cu_$arg_list_ptr entry (pointer);
dcl  cu_$arg_ptr_rel entry (fixed bin, pointer, fixed bin (21), fixed bin (35), pointer);
dcl  decode_descriptor_ entry (pointer, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin (24), fixed bin (35));
dcl  sub_err_ entry options (variable);

dcl  WHOAMI char (32) internal static options (constant) init ("arg_assign_");
dcl  STOP char (1) unaligned internal static options (constant) init ("s");

dcl  (size, conversion, stringsize) condition;

dcl  (addr, addrel, binary, string, null) builtin;

%page;

arg_assign_$from_arg:
     entry () options (variable);

/* call arg_assign_$from_arg (arg_list_ptr, arg_index, TARGET); */

	from_sw = "1"b;
	check_sw = "0"b;
	myname = "arg_assign_$from_arg";
	goto COMMON;


arg_assign_$to_arg:
     entry () options (variable);

/* call arg_assign_$to_arg (arg_list_ptr, arg_index, SOURCE); */

	from_sw = "0"b;
	check_sw = "0"b;
	myname = "arg_assign_$to_arg";
	goto COMMON;


arg_assign_$from_arg_check:
     entry () options (variable);

/* call arg_assign_$from_arg_check (arg_list_ptr, arg_index, TARGET, code); */

	from_sw = "1"b;
	check_sw = "1"b;
	myname = "arg_assign_$from_arg_check";
	goto COMMON;


arg_assign_$to_arg_check:
     entry () options (variable);

/* call arg_assign_$to_arg_check (arg_list_ptr, arg_index, SOURCE, code); */

	from_sw = "0"b;
	check_sw = "1"b;
	myname = "arg_assign_$to_arg_check";
	goto COMMON;


COMMON:

	call cu_$arg_count (my_arg_count);		/* find out whether the arg count is proper */
	if (check_sw & (my_arg_count ^= 4)) | (^check_sw & (my_arg_count ^= 3)) then
	     call sub_err_ (0, WHOAMI, STOP, (null ()), 0, "^a: Invalid calling sequence. ^[4^;3^] arguments required.",
		myname, check_sw);

	call cu_$arg_list_ptr (my_alp);

%page;

	call get_arg_info (my_alp, 1, arg1);		/* get the arg_list_ptr argument */
	call get_arg_info (my_alp, 2, arg2);		/* and the arg_count argument */

	if (arg1.data_type ^= pointer_dtype) | (arg1.ndims ^= 0) then
	     call sub_err_ (0, WHOAMI, STOP, (null ()), (0), "^a: First argument must be a pointer", myname);

	if arg1.packed then				/* assign the arg list pointer */
	     caller_alp = arg1.address -> based_packed_ptr;
	else caller_alp = arg1.address -> based_ptr;

	if (^data_type_info_$info (arg2.data_type).arithmetic) | (arg2.ndims ^= 0) then
	     call sub_err_ (0, WHOAMI, STOP, (null ()), (0), "^a: Second argument must be a number.", myname);

	if arg2.data_type = real_fix_bin_1_dtype then	/* optimize the anticipated case */
	     caller_argno = arg2.address -> based_integer;

	else call assign_ (arg2.address,		/* otherwise, call assign_ to do the job */
		((2 * arg2.data_type) + binary (arg2.packed, 1)), ((262144 * arg2.scale) + arg2.prec_or_length),
		addr (caller_argno), (2 * real_fix_bin_1_dtype), 35);

	if from_sw then do;				/* assigning from arg in arglist to our third arg */
	     call get_arg_info (caller_alp, caller_argno, from_arg);
	     call get_arg_info (my_alp, 3, to_arg);
	     end;

	else do;					/* assigning from our third arg to caller argument */
	     call get_arg_info (caller_alp, caller_argno, to_arg);
	     call get_arg_info (my_alp, 3, from_arg);
	     end;

%page;

	if (from_arg.ndims > 0) | (to_arg.ndims > 0) then
	     call sub_err_ (0, WHOAMI, STOP, (null ()), (0), "^a: Array assignment not supported.", myname);

/* set up condition handlers */

	     on condition (size)
		begin;
		     code = error_table_$bad_conversion;
		     goto ERROR_RETURN;
		end;

	     on condition (stringsize)
		begin;
		     code = error_table_$bad_conversion;
		     goto ERROR_RETURN;
		end;

	     on condition (conversion)
		begin;
		     code = error_table_$bad_conversion;
		     goto ERROR_RETURN;
		end;


	if data_type_info_$info (to_arg.data_type).computational then do;
	     if ^data_type_info_$info (from_arg.data_type).computational then signal condition (conversion);
						/* Sorry, we only take tunas that taste good. */

	     if (to_arg.data_type = real_fix_bin_1_dtype) & (from_arg.data_type = real_fix_bin_1_dtype) then
		to_arg.address -> based_integer = from_arg.address -> based_integer;
						/* optimize common case */

/* We could productively optimize some other assignments here, like char strings and the like,
   but it's not worth the trouble in the initial version. */

	     else do;				/* otherwise, call for Phillip Morris */
		call assign_$computational_ (addr (to_arg.comp_data), addr (from_arg.comp_data), code);
		if code ^= 0 then
		     if check_sw then
			goto ERROR_RETURN;
		     else signal condition (conversion);
		end;				/* of calling assign_ */
	     end;					/* of handling computational data */

%page;

	else if (to_arg.data_type = pointer_dtype) then do;
	     if from_arg.data_type ^= pointer_dtype then signal condition (conversion);

	     if from_arg.packed then
		temp_ptr = from_arg.address -> based_packed_ptr;
	     else temp_ptr = from_arg.address -> based_ptr;

	     if to_arg.packed then
		to_arg.address -> based_packed_ptr = temp_ptr;
	     else to_arg.address -> based_ptr = temp_ptr;
	     end;					/* of poiner assignment */

	else if (to_arg.data_type = offset_dtype) | (from_arg.data_type = offset_dtype) then
	     call sub_err_ (0, WHOAMI, STOP, (null ()), (0), "^a: Assignment of offsets not supported.", myname);

/* Actually, we COULD support assignments of null offsets to pointers, and null pointers to
   offsets, but it hardly seems worthwhile. Nobody uses offsets, anyway. */

/* I do not know whether this procedure should be in the business of dealing with
   label_runtime_dtype and entry_runtime_dtype; probe_assign_value_ is, but I think
   that's because it deals with stu_. As far as I know, anything which appears in an
   argument list ought to be either label_dtype or entry_dtype.
*/


	else if (to_arg.data_type = label_dtype) then do;
	     if from_arg.data_type ^= label_dtype then signal condition (conversion);

	     to_arg.address -> based_label = from_arg.address -> based_label;
	     end;

	else if (to_arg.data_type = entry_dtype) then do;
	     if from_arg.data_type ^= entry_dtype then signal condition (conversion);

	     to_arg.address -> based_entry = from_arg.address -> based_entry;
	     end;

	else if (to_arg.data_type = file_dtype) then do;
	     if from_arg.data_type ^= file_dtype then signal condition (conversion);

	     to_arg.address -> based_file = from_arg.address -> based_file;
	     end;

	else if (to_arg.data_type = area_dtype) then do;
	     if from_arg.data_type ^= area_dtype then signal condition (conversion);

	     call area_assign_ (to_arg.address, from_arg.address);
	     end;

	else call sub_err_ (0, WHOAMI, STOP, (null ()), (0), "^a: Cannot assign from type ^d to type ^d.",
		from_arg.data_type, to_arg.data_type);

	code = 0;					/* successful */

ERROR_RETURN:					/* come here for error exit */
	if check_sw then do;
	     revert condition (size);
	     revert condition (stringsize);
	     revert condition (conversion);
	     end;

	if check_sw then /* assign the code */ call arg_assign_$to_arg (my_alp, 4, code);
						/* we can do this since this call doesn't have a fourth arg */

	return;					/* all done */

%page;

get_arg_info:
     proc (P_alp, P_argno, P_arg_info);

/* This procedure fills in the arg_info structure for the specified argument. */

dcl  (
     P_alp pointer,
     P_argno fixed bin
     ) parameter;

dcl  1 P_arg_info aligned like arg_info parameter;

dcl  packed_bit bit (1) aligned;


	call cu_$arg_ptr_rel (P_argno, P_arg_info.address, (0), code, P_alp);
	if check_sw & (code = error_table_$noarg) then goto ERROR_RETURN;
						/* be silent about this one */
	if code ^= 0 then call sub_err_ (code, "arg_assign_", STOP, (null ()), 0, "^a: Argument ^d.", myname, P_argno);

	call decode_descriptor_ (P_alp, P_argno, P_arg_info.data_type, packed_bit, P_arg_info.ndims,
	     P_arg_info.prec_or_length, P_arg_info.scale);

	string (P_arg_info.flags) = ""b;
	P_arg_info.packed = packed_bit;
	P_arg_info.picture_image_ptr = null ();

/* I do not know whether it is necessary for this procedure to deal with pictures. If it is,
   I surely don't know how to do it. I will therefore leave it out for now. */

	if data_type_info_$info (P_arg_info.data_type).varying then
						/* KLUDGE to adjust varying string arg ptr */
	     P_arg_info.address = addrel (P_arg_info.address, -1);

	return;
     end get_arg_info;

%page;
%include std_descriptor_types;
%page;
%include data_type_info_;
%page;
%include computational_data;

     end arg_assign_;




		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
