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 12/11/99 1830.6re 12/11/99 1803.2 155124 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(99-06-23,Haggett): Y2K END HISTORY COMMENTS */ 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,mod(year,100),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