analyze_ioi_istat_.pl1 11/15/82 1825.9rew 11/15/82 1505.3 18693 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ANALYZE_IOI_ISTAT_ - Procedures to decode ioi status structures */ /* Written March 1980 by Larry Johnson */ analyze_ioi_istat_: proc (arg_isp, arg_tablep, arg_message); /* Parameters */ dcl arg_isp ptr; dcl arg_imp ptr; dcl arg_tablep ptr; dcl arg_message char (*) var; /* External */ dcl analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72), bit (18)); dcl ioa_$rsnnl entry options (variable); dcl (bin, substr) builtin; /* entry for decoding the istat (long) structure */ isp = arg_isp; call worker ((istat.completion), istat.level, (istat.iom_stat)); return; /* entry for decoding the imess (short) sturcture */ analyze_ioi_imess_: entry (arg_imp, arg_tablep, arg_message); imp = arg_imp; call worker (imess.completion, bin (imess.level), (imess.status)); return; /* procedure that does the work */ worker: proc (comp, level, status); dcl 1 comp like istat.completion; dcl level fixed bin (3); dcl status bit (72); arg_message = ""; if level = 7 then call ioa_$rsnnl ("Special status: ^.3b", arg_message, (0), substr (status, 1, 36)); else if level = 1 then call ioa_$rsnnl ("System fault: ^.3b", arg_message, (0), substr (status, 1, 36)); else if level = 3 | level = 5 then do; if comp.time_out then arg_message = "Timeout"; else call analyze_device_stat_$rsnnl (arg_message, arg_tablep, status, ("0"b)); end; else call ioa_$rsnnl ("Unknown level ^d status : ^.3b", level, substr (status, 1, 36)); return; end worker; %include ioi_stat; end analyze_ioi_istat_;  binary_segmsg_util_.pl1 11/15/82 1825.9rew 11/15/82 1505.4 36684 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ binary_segmsg_util_: proc (a_datap) returns (char (250)); /* Procedure to make heads and tails out of binary messages produced by page control/vtoc salvager. */ /* This procedure knows the format and decision trees of these binary messages, which happen */ /* to be transmitted via the syserr log, most usually. This procedure has no knowledge */ /* of syserr or its logs. */ /* Bernard Greenberg 8/4/77 */ dcl (datap, a_datap) ptr; /* Pointer to binary stuff */ dcl path char (168); /* Ostensible vpn_cv_.. answer */ dcl segname char (250); /* Answer */ dcl (linkage_error, command_error) condition; /* vpn_cv_ is a mighty funny boy */ dcl brief char (8) aligned; /* For convert_status_code_ */ dcl long char (100) aligned; /* Ditto */ dcl code fixed bin (35); /* Status code in general */ dcl volname char (32); /* Phys vol name */ dcl (error_table_$noentry, error_table_$no_dir) fixed bin (35) external; dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl vpn_cv_uid_path_ entry (ptr, char (*), fixed bin (35)); /* for dirnames */ dcl vpn_cv_uid_path_$ent entry (ptr, char (*), bit (36) aligned, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl mdc_$find_volname entry (bit (36), char (*), char (*), fixed bin (35)); %include segdamage_msg; dcl 1 sd like segdamage based (datap) aligned; /* */ datap = a_datap; volname = cv_pvname (); if sd.vtocx = -2 then do; /* PD case */ if sd.uid = "0"b then segname = "VTOCEless segment on pv " || volname; else call ioa_$rsnnl ("UID ^w on pv ^a", segname, (0), sd.uid, volname); end; else if sd.vtocx = -1 then segname = "VTOCEless segment on pv " || volname; else do; /* Have vtocx, if we have uid, golden */ if sd.uid = "0"b then do; path = "Cannot determine pathname."; on command_error; on linkage_error go to vpnf1; call vpn_cv_uid_path_ (addr (sd.uid_path), path, code); vpnf1: revert linkage_error; revert command_error; call ioa_$rsnnl ("Seg at vtocx ^o on pv ^a, dir = ^a", segname, (0), sd.vtocx, volname); end; else do; /* Got ALL goods! */ on linkage_error go to vpnf2; on command_error; path = "Cannot determine pathname"; call vpn_cv_uid_path_$ent (addr (sd.uid_path), path, sd.uid, code); vpnf2: revert command_error; revert linkage_error; if code = 0 then segname = rtrim (path) || " on pv " || volname; else if code = error_table_$noentry then do; call expand_pathname_ ((path), path, (" "), (0)); call ioa_$rsnnl ("Deleted segment in ^a, on pv ^a.", segname, (0), path, volname); end; else if code = error_table_$no_dir then call ioa_$rsnnl ("Segment on pv ^a in deleted directory: ^a", segname, (0), volname, path); else do; call convert_status_code_ (code, brief, long); call ioa_$rsnnl ("Cannot determine full path name: ^a ^a = UID ^w.", segname, (0), long, path, sd.uid); end; end; end; return (segname); /* */ cv_pvname: proc () returns (char (32)); dcl (pvname, lvname) char (32); dcl code fixed bin (35); if sd.pvid = "777777777777"b3 then return ("Paging Device"); call mdc_$find_volname ((sd.pvid), pvname, lvname, code); if code ^= 0 then call ioa_$rsnnl ("<>", pvname, (0), sd.pvid); return (pvname); end cv_pvname; interpret_pvname: entry (a_datap) returns (char (32)); datap = a_datap; return (cv_pvname ()); end binary_segmsg_util_;  copy_out.pl1 02/07/84 1156.0rew 02/07/84 1121.4 58005 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ copy_out: cpo: proc; /* Fixed to delete output seg if copy fails 02/08/80 S. Herbst */ /* Fixed to copy non-connected segments properly, 09/19/80 W. Olin Sibert */ dcl (bound, tc, i) fixed bin; dcl bit_count fixed bin (24); dcl code fixed bin (35); dcl got_copy bit (1); dcl (segptr, segptr0, tp) ptr; dcl dirname char (168); dcl (high_seg, hcsc) fixed bin; dcl test_word fixed bin (35); dcl tsdw fixed bin (71); dcl ename char (32); dcl targ char (tc) based (tp); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_wdir_ entry returns (char (168)); dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35)); dcl hcs_$high_low_seg_count entry (fixed bin, fixed bin); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl phcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl nd_handler_ entry (char (*), char (*), char (*), fixed bin (35)); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl ring0_get_$name entry (char (*), char (*), ptr, fixed bin (35)); dcl ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl ring_zero_peek_ entry (ptr, ptr, fixed bin, fixed bin (35)); dcl (com_err_, com_err_$suppress_name, ioa_) entry options (variable); dcl (error_table_$action_not_performed, error_table_$namedup, error_table_$segknown) fixed bin (35) external static; dcl myname char (32) int static options (constant) init ("copy_out"); dcl (cleanup, linkage_error) condition; dcl (null, addr, addrel, binary, baseno, baseptr, size) builtin; /* */ call cu_$arg_ptr (1, tp, tc, code); /* pick up name of segment to copy out */ if code ^= 0 | tc = 0 then do; /* no arguments, give calling sequence */ call com_err_$suppress_name (0, myname, "Usage: ^a name/number {alternate name}", myname); return; end; segptr = null; got_copy = "0"b; i = cv_oct_check_ (targ, code); /* see if it's a number */ if code ^= 0 then do; /* it isn't, must be name */ call ring0_get_$segptr ("", targ, segptr0, code); /* get segptr for this name */ if segptr0 = null then do; /* name not found */ call expand_pathname_ (targ, dirname, ename, code); if code ^= 0 then do; call com_err_ (code, myname); return; end; on condition (linkage_error) begin; code = 0; goto rzp_error; end; call phcs_$initiate (dirname, ename, "", 0, 0, segptr0, code); revert condition (linkage_error); if segptr0 = null then do; call com_err_ (code, myname, "^a", pathname_ (dirname, ename)); return; end; goto get_alternate_name; end; ename = targ; /* default name of seg to create */ end; else do; /* number was given */ call hcs_$high_low_seg_count (high_seg, hcsc); if i > high_seg + hcsc then do; call com_err_ (0, myname, "Segment ^o is greater than the highest segment number ^o.", i, high_seg+hcsc); return; end; segptr0 = baseptr (i); /* create pointer to segment */ call ring0_get_$name (dirname, ename, segptr0, code); /* get name for this segment */ if code ^= 0 then do; /* no name for the segment */ ename = targ; goto get_alternate_name; end; call ioa_ ("Segment name is ^a", ename); /* tell user name of segment */ end; get_alternate_name: call cu_$arg_ptr (2, tp, tc, code); /* see if optional segment name is given */ if code ^= 0 | tc = 0 then do; if dirname = ">" & ename = "" then ename = "root"; dirname = get_wdir_ (); end; else do; /* if arg is given expand_path_ it, else use wdir */ call expand_pathname_ (targ, dirname, ename, code); if code ^= 0 then do; /* trouble with path name */ cerr: call com_err_ (code, myname, targ); /* tell user */ call clean_up; return; end; end; /* Test whether copying is possible, and also cause segment fault to get sdw.bound right */ call ring_zero_peek_ (segptr0, addr (test_word), size (test_word), code); if code ^= 0 then goto rzp_error; call ring_zero_peek_ (addr (baseptr (0) -> sdwa (binary (baseno (segptr0), 15))), addr (tsdw), size (tsdw), code); if code ^= 0 then goto rzp_error; bound = (binary (addr (tsdw) -> sdw.bound, 14) + 1) * 16; /* get number of words */ bit_count = bound * 36; /* bit of segment */ call ring_zero_peek_ (addrel (segptr0, bound - 1), addr (test_word), size (test_word), code); if code ^= 0 then /* test whether whole segment is copyable -- in case we're */ goto rzp_error; /* stuck with using metering_ring_zero_peek_ */ on cleanup call clean_up; CREATE: call hcs_$make_seg (dirname, ename, "", 01011b, segptr, code); /* get segment to copy data into */ if code ^= 0 then if code = error_table_$namedup then do; call nd_handler_ ("copy_out", dirname, ename, code); if code = error_table_$action_not_performed then return; goto CREATE; end; else if code ^= error_table_$segknown then go to cerr; call ring_zero_peek_ (segptr0, segptr, bound, code); /* copy segment into user ring */ if code ^= 0 then goto rzp_error; got_copy = "1"b; call hcs_$set_bc_seg (segptr, bit_count, (0)); /* set bit count */ call hcs_$terminate_noname (segptr, (0)); /* and terminate the segment */ return; rzp_error: call com_err_ (code, myname, "This operation requires access to phcs_."); call clean_up (); return; clean_up: proc (); if segptr ^= null & ^got_copy then call hcs_$delentry_file (dirname, ename, (0)); end clean_up; %page; %include sdw; end copy_out;  dump_fnp.pl1 11/15/82 1825.9rew 11/15/82 1505.4 47097 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DUMP_FNP - Command to dump fnp memory */ /* PATCH_FNP - Command to patch fnp memory */ /* Re-implemented October 1978 by Larry Johnson to use debug_fnp interfaces. Modified 1979 June 1 by Art Beattie to remove maximum address checks. */ dump_fnp: proc; /* Automatic */ dcl name char (16); dcl n_args fixed bin; dcl arg_no fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin; dcl fnp fixed bin; dcl fnp_addr fixed bin; dcl fnp_len fixed bin; dcl code fixed bin (35); dcl display_mode fixed bin; dcl length_given bit (1); dcl mem_buf (0:2047) bit (18) unal; dcl patch_buf (10) fixed bin (17) unal; /* Based */ dcl arg char (arg_len) based (arg_ptr); /* External */ dcl cu_$arg_count entry (fixed bin); dcl com_err_ entry options (variable); dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl db_fnp_display_ entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin, fixed bin (35)); dcl db_fnp_memory_$store entry (ptr, fixed bin, fixed bin, fixed bin, ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl (addr, index, null, substr) builtin; dcl error_table_$too_many_args ext fixed bin (35); dcl error_table_$noarg ext fixed bin (35); /* Dump_fnp command */ name = "dump_fnp"; call cu_$arg_count (n_args); if n_args < 2 then do; call com_err_ (0, name, "Usage: ^a tag address {length} {-ch}", name); return; end; arg_no = 1; fnp = get_fnp (); fnp_addr = get_address (); display_mode = 0; /* Octal */ length_given = "0"b; fnp_len = 1; /* The default */ do while (arg_no <= n_args); call get_arg; if arg = "-character" | arg = "-ch" then display_mode = 1; else if ^length_given then do; fnp_len = eval_arg (); length_given = "1"b; end; else do; call com_err_ (0, name, "Unrecognized argument: ^a", arg); return; end; end; call check_values; call db_fnp_memory_$fetch (null (), fnp, fnp_addr, fnp_len, addr (mem_buf), code); if code ^= 0 then do; call com_err_ (code, name, "Unable to read memory."); return; end; call db_fnp_display_ (null (), fnp, fnp_addr, fnp_len, addr (mem_buf), display_mode, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to display memory"); return; end; return; /* Patch_fnp command */ patch_fnp: entry; name = "patch_fnp"; call cu_$arg_count (n_args); if n_args < 3 then do; call com_err_ (0, name, "Usage: ^a tag address word1 {... word10}", name); return; end; arg_no = 1; fnp = get_fnp (); fnp_addr = get_address (); fnp_len = 0; do while (arg_no <= n_args); call get_arg; if fnp_len >= 10 then do; call com_err_ (error_table_$too_many_args, name, "^a", arg); return; end; fnp_len = fnp_len + 1; patch_buf (fnp_len) = eval_arg (); end; call check_values; call db_fnp_memory_$store (null (), fnp, fnp_addr, fnp_len, addr (patch_buf), name, 2, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to patch memory"); return; end; done: return; /* Check fnp arg */ get_fnp: proc returns (fixed bin); dcl i fixed bin; call get_arg; i = index ("abcdefgh", arg); if i = 0 then do; bad_tag: call com_err_ (0, name, "Bad FNP tag: ^a", arg); go to done; end; if substr ("abcdefgh", i, 1) ^= arg then go to bad_tag; return (i); end get_fnp; /* Get address argument */ get_address: proc returns (fixed bin); if arg_no > n_args then do; call com_err_ (error_table_$noarg, name, "Address"); go to done; end; call get_arg; return (eval_arg ()); end get_address; /* Procedure to handle numeric args */ eval_arg: proc returns (fixed bin); dcl i fixed bin; call db_fnp_eval_ (null (), fnp, arg, null (), name, i, code); if code ^= 0 then go to done; return (i); end; /* Get next argument */ get_arg: proc; call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, name, "Arg ^d", arg_no); /* Should be impossible */ go to done; end; arg_no = arg_no + 1; return; end get_arg; /* Check FNP address and length values */ check_values: proc; if fnp_addr < 0 then do; call com_err_ (0, name, "Starting address out of range: ^o", fnp_addr); go to done; end; if fnp_len < 1 | fnp_len > dim (mem_buf, 1) then do; call com_err_ (0, name, "Invalid length: ^o", fnp_len); go to done; end; return; end check_values; end dump_fnp;  ed_appending_simulation_.pl1 01/26/85 1311.3r w 01/22/85 1300.8 106992 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ ed_appending_simulation_: proc; /* Modified routine to access segments in the saved Multics memory image. Taken from bce_appending_simulation. Keith Loepere, December 1983. */ /* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */ dcl address fixed bin (26); /* running absolute or virtual (within segment) address */ dcl code fixed bin (35) parameter; dcl crash_system_type fixed bin static; /* supplied from dump */ dcl data_length fixed bin (18); /* running data left to be gotten */ dcl data_part (data_part_length) bit (36) aligned based; /* part of page to extract toward total desired */ dcl data_part_length fixed bin (18); dcl data_ptr ptr; /* running ptr to user data area */ dcl dbr_value bit (72) aligned parameter; dcl desired_segnum fixed bin (15) parameter; dcl dseg_sdw fixed bin (71); dcl 1 dseg_info aligned like seg_info static; /* describe dseg in dump */ dcl error_table_$argerr fixed bin (35) ext static; dcl error_table_$boundviol fixed bin (35) ext static; dcl error_table_$invalidsegno fixed bin (35) ext static; dcl error_table_$out_of_bounds fixed bin (35) ext static; dcl memory_block_ptrs (4) ptr static; /* forms a set of 4 128k blocks of memory */ dcl multics_data_ptr ptr; /* running ptr to area in dump to copy out for user */ dcl 1 my_dbr_info aligned like dbr_info; dcl 1 my_ptw_info aligned like ptw_info; dcl p_address fixed bin (26) parameter; /* desired address */ dcl p_crash_system_type fixed bin parameter; dcl p_data_length fixed bin (18) parameter; /* desired data length */ dcl p_data_ptr ptr parameter; /* ptr to user data area */ dcl p_last_segnum fixed bin (15) parameter; dcl p_memory_block_ptrs (4) ptr parameter; dcl p_seg_info_ptr ptr parameter; dcl page_num fixed bin; /* loop counter */ dcl page_offset fixed bin; /* start within page of data to get */ dcl ptp ptr; /* ptw ptr */ dcl sdwp ptr; /* sdw ptr */ dcl seg_sdw fixed bin (71); dcl size builtin; %page; init: entry (p_memory_block_ptrs, p_crash_system_type); /* save away data about dump */ memory_block_ptrs = p_memory_block_ptrs; crash_system_type = p_crash_system_type; return; %page; new_dbr: entry (dbr_value, p_last_segnum, code); /* Supply a new dseg for the simulation. */ /* Examine the new dbr. */ code = 0; dbr_info_ptr = addr (my_dbr_info); ptw_info_ptr = addr (my_ptw_info); call dbr_util_$dissect (addr (dbr_value), dbr_info_ptr); p_last_segnum = divide (dbr_info.bound, 2, 15) - 1; dseg_info.sdwi.paged = dbr_info.paged; dseg_info.sdwi.address = dbr_info.address; /* Get the sdw & page table for dseg. */ if dseg_info.sdwi.paged then do; call get_absolute (dseg_info.sdwi.address - size (aste), size (aste) + divide (dbr_info.bound + 1023, 1024, 8), addr (dseg_info.sst_data), code); if code ^= 0 then return; call ptw_util_$dissect (addr (dseg_info.page_table (0)), ptw_info_ptr); call get_absolute (ptw_info.address, 2, addr (dseg_sdw), code); if code ^= 0 then return; end; else do; call get_absolute (dseg_info.sdwi.address, 2, addr (dseg_sdw), code); if code ^= 0 then return; end; call sdw_util_$dissect (addr (dseg_sdw), addr (dseg_info.sdwi)); return; %page; get_absolute: entry (p_address, p_data_length, p_data_ptr, code); data_length = p_data_length; /* We march the address we desire downwards, by at most a page at a time. As we do this, we appropriately keep track of the memory this is in (or not in) to validate the address. */ do while (data_length > 0); /* Find amount of data in this page. */ data_part_length = mod (p_address + data_length - 1, 1024) + 1; /* amount from start of page to last word */ if data_part_length <= data_length then address = p_address + data_length - data_part_length; /* data crosses into this page */ else do; /* data within a page */ address = p_address; data_part_length = data_length; end; data_ptr = addrel (p_data_ptr, address - p_address); if address >= 512 * 1024 then do; /* address beyond this memory */ code = error_table_$out_of_bounds; unspec (data_ptr -> data_part) = "0"b; end; else do; multics_data_ptr = addrel (memory_block_ptrs (divide (address, 128 * 1024, 17) + 1), mod (address, 128 * 1024)); data_ptr -> data_part = multics_data_ptr -> data_part; end; data_length = data_length - data_part_length; end; return; %page; new_segment: entry (desired_segnum, p_seg_info_ptr, code); /* Supply a new segnum for virtual simulation. */ code = 0; seg_info_ptr = p_seg_info_ptr; /* We will get the user's new segment's sdw and page table. We call virtual, telling it to get the seg's sdw. */ call get_virtual (addr (dseg_info), desired_segnum * 2, 2, addr (seg_sdw), code); if code ^= 0 then go to bad_segment; call sdw_util_$dissect (addr (seg_sdw), addr (seg_info.sdwi)); if seg_info.sdwi.faulted then do; code = error_table_$invalidsegno; go to bad_segment; end; if seg_info.sdwi.paged then do; /* Get the seg's aste/page table */ call get_absolute (seg_info.sdwi.address - size (aste), size (aste) + divide (seg_info.sdwi.size + 1023, 1024, 8), addr (seg_info.sst_data), code); if code ^= 0 then do; /* It could just be that the page table is in good memory and has no aste in front of it, but... */ seg_info.sdwi.faulted = "1"b; bad_segment: return; end; end; return; %page; get_virtual: entry (p_seg_info_ptr, p_address, p_data_length, p_data_ptr, code); /* Fetch a given set of words from the current segment. */ code = 0; seg_info_ptr = p_seg_info_ptr; ptw_info_ptr = addr (my_ptw_info); data_length = p_data_length; if p_address + p_data_length > seg_info.sdwi.size then do; data_part_length = p_address + data_length - seg_info.sdwi.size; data_ptr = addrel (p_data_ptr, data_length - data_part_length); unspec (data_ptr -> data_part) = "0"b; code = error_table_$boundviol; data_length = data_length - data_part_length; end; if seg_info.sdwi.paged then do; do while (data_length > 0); data_part_length = mod (p_address + data_length - 1, 1024) + 1; /* amount from start of page to last word */ if data_part_length <= data_length then address = p_address + data_length - data_part_length; /* data crosses into this page */ else do; /* data within a page */ address = p_address; data_part_length = data_length; end; data_ptr = addrel (p_data_ptr, address - p_address); page_num = divide (address, 1024, 8); page_offset = mod (address, 1024); /* Find the appropriate page. Move the amount found in that page to the user's area. */ call ptw_util_$dissect (addr (seg_info.page_table (page_num)), ptw_info_ptr); if ptw_info.valid then /* properly in memory */ call get_absolute (ptw_info.address + page_offset, data_part_length, data_ptr, code); else do; bad_page: unspec (data_ptr -> data_part) = "0"b; if code = 0 then code = error_table_$argerr; end; data_length = data_length - data_part_length; end; end; else do; /* in memory (unpaged) */ address = seg_info.sdwi.address + p_address; call get_absolute (address, p_data_length, p_data_ptr, code); end; return; %page; /* The following routines were stolen from their namesakes for use here. They are striped down and key off crash_system_type for operation. */ dbr_util_$dissect: proc (dbr_ptr, p_dbr_info_ptr); /* Routine to take apart (and assemble?) dbr (descriptor segment base register) values. Initially coded by Keith Loepere, October 1983. */ dcl dbr_ptr ptr parameter; dcl p_dbr_info_ptr ptr parameter; dbr_info_ptr = p_dbr_info_ptr; if crash_system_type = ADP_SYSTEM then do; dbr_info.address = bin (dbr_ptr -> adp_dbr.add, 26); dbr_info.bound = (bin (dbr_ptr -> adp_dbr.bound, 14) + 1) * 16; dbr_info.stack_base_segnum = dbr_ptr -> adp_dbr.stack_base_segno * 8; dbr_info.paged = ^ dbr_ptr -> adp_dbr.unpaged; end; else do; dbr_info.address = bin (dbr_ptr -> l68_dbr.add, 24); dbr_info.bound = (bin (dbr_ptr -> l68_dbr.bound, 14) + 1) * 16; dbr_info.stack_base_segnum = dbr_ptr -> l68_dbr.stack_base_segno * 8; dbr_info.paged = ^ dbr_ptr -> l68_dbr.unpaged; end; return; end; %page; ptw_util_$dissect: proc (P_ptw_ptr, P_ptw_info_ptr); dcl P_ptw_ptr pointer parameter; dcl P_ptw_info_ptr pointer parameter; ptp = P_ptw_ptr; ptw_info_ptr = P_ptw_info_ptr; if crash_system_type = ADP_SYSTEM then do; if adp_ptw.add_type = add_type.core then do; ptw_info.address = adp_core_ptw.frame * 1024; ptw_info.null_disk = "0"b; end; else if adp_ptw.add_type = add_type.disk then do; ptw_info.address = bin (substr (adp_ptw.add, 2, 17), 17); ptw_info.null_disk = substr (adp_ptw.add, 1, 1); end; else do; ptw_info.address = bin (adp_ptw.add, 18); ptw_info.null_disk = "0"b; end; ptw_info = adp_ptw.flags, by name; end; else do; if l68_ptw.add_type = add_type.core then do; ptw_info.address = l68_core_ptw.frame * 1024; ptw_info.null_disk = "0"b; end; else if l68_ptw.add_type = add_type.disk then do; ptw_info.address = bin (substr (l68_ptw.add, 2, 17), 17); ptw_info.null_disk = substr (l68_ptw.add, 1, 1); end; else do; ptw_info.address = bin (l68_ptw.add, 18); ptw_info.null_disk = "0"b; end; ptw_info = l68_ptw.flags, by name; end; return; end; %page; sdw_util_$dissect: proc (P_sdw_ptr, P_sdw_info_ptr); dcl P_sdw_ptr pointer parameter; dcl P_sdw_info_ptr pointer parameter; sdwp = P_sdw_ptr; /* Make it addressable */ sdw_info_ptr = P_sdw_info_ptr; unspec (sdw_info) = ""b; /* Clear it out, and fill it in */ if crash_system_type = ADP_SYSTEM then do; string (sdw_info.access) = string (adp_sdw.access); string (sdw_info.rings) = string (adp_sdw.rings); sdw_info.faulted = ^adp_sdw.valid; /* Bits are different in state */ sdw_info.paged = ^adp_sdw.unpaged; if ^adp_sdw.not_a_gate then /* Copy the entry bound, if interesting */ sdw_info.gate_entry_bound = 1 + binary (adp_sdw.entry_bound, 14); sdw_info.size = 16 + 16 * binary (adp_sdw.bound, 14); sdw_info.address = binary (adp_sdw.add, 26); end; else do; /* Ordinary Level 68 */ string (sdw_info.access) = string (l68_sdw.access); string (sdw_info.rings) = string (l68_sdw.rings); sdw_info.faulted = ^l68_sdw.valid; /* Bits are different in state */ sdw_info.paged = ^l68_sdw.unpaged; sdw_info.cache = l68_sdw.cache; /* Only on the Level 68 */ if ^l68_sdw.not_a_gate then /* Copy the entry bound, if interesting */ sdw_info.gate_entry_bound = 1 + binary (l68_sdw.entry_bound, 14); sdw_info.size = 16 + 16 * binary (l68_sdw.bound, 14); sdw_info.address = binary (l68_sdw.add, 24); end; return; end; %page; %include add_type; %page; %include bce_appending_seg_info; %page; %include "dbr.adp"; %page; %include "dbr.l68"; %page; %include dbr_info; %page; %include "ptw.adp"; %page; %include "ptw.l68"; %page; %include ptw_info; %page; %include "sdw.adp"; %page; %include "sdw.l68"; %page; %include system_types; end;  edit_mos_rscr_.pl1 06/02/83 1219.9r 06/02/83 1103.3 156807 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* EDIT_MOS_RSCR_: Procedure to interpret and edit contents memory maintence register. */ /* Written May 1976 by Larry Johnson */ /* Modified September 1977 by Larry Johnson for 16k chips */ /* Modified November 1979 by Larry Johnson for $decode entry */ /* Modified April 1983 by Paul Farley, with input from D. A. Fudge (UofC), for 64k chips */ edit_mos_rscr_: proc (arg_scrp, arg_descrip); /* Arguments */ dcl arg_descrip char (*) var; /* Description built here */ dcl arg_mem_type char (*); dcl arg_error char (*); dcl arg_scrp ptr; /* Automatic */ dcl decode_sw bit (1); dcl mem_type char (32); dcl error char (32); dcl syndrome fixed bin; dcl bit_no fixed bin; dcl board char (1); dcl quad fixed bin; dcl i fixed bin; dcl chip fixed bin; dcl ioa_ entry options (variable); dcl ioa_$rsnpnnl entry options (variable); dcl (bin, bit, divide, mod, substr) builtin; %include scr; %page; /* The following delcarations are for 1k MOS chips */ /* This table translates a syndrome to a board bit number */ dcl bit_1k (128) fixed bin (8) unal int static options (constant) init ( 19, 18, 19, 17, 18, 16, 15, -1, 19, 14, 13, 11, 12, 10, 09, -1, 18, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1, 19, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1, -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1, 18, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1, -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1, -1, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1, -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1); /* This table translates a syndrom into a "quandrant" in the error chart */ dcl quad_1k (128) fixed bin (3) unal int static options (constant) init ( 4, 4, 3, 4, 3, 4, 4, 0, 2, 4, 4, 4, 4, 4, 4, 0, 2, 4, 4, 4, 4, 4, 4, 0, 0, 4, 4, 0, 4, 0, 0, 0, 1, 0, 0, 3, 0, 3, 3, 0, 0, 3, 3, 3, 3, 3, 3, 0, 0, 3, 3, 3, 3, 3, 3, 0, 0, 3, 3, 0, 3, 0, 0, 0, 1, 0, 0, 2, 0, 2, 2, 0, 0, 2, 2, 2, 2, 2, 2, 0, 0, 2, 2, 2, 2, 2, 2, 0, 0, 2, 2, 0, 2, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 0); /* This table is used to determine a board number. One string applies to each quandrant. */ dcl board_1k (4) char (8) int static options (constant) init ( "ACEGBDFH", "JLNQKMPR", "LJGEKHFD", "USQNTRPM"); dcl bay_1k (4) char (3) int static options (constant) init ( "AA0", "AA0", "AA1", "AA1"); /* End of 1k chip declarations */ %page; /* The following declarations are for 4k and 16k mos chips. */ dcl bit_4k (128) fixed bin (8) unal int static options (constant) init ( 19, 18, 17, 15, 16, 14, 13, -1, 19, 12, 11, 09, 10, 08, 07, -1, 18, 06, 05, 03, 04, 02, 01, -1, -1, 00, 19, -1, 18, -1, -1, -1, 17, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1, -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1, 16, -1, -1, 15, -1, 14, 13, -1, -1, 12, 11, 09, 10, 08, 07, -1, -1, 06, 05, 03, 04, 02, 01, -1, -1, 00, 19, -1, 18, -1, -1, -1, -1, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1, -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1); /* The following table translate a syndrome into a quadrant in the error chard */ dcl quad_4k (128) fixed bin (3) unal int static options (constant) init ( 4, 4, 4, 4, 4, 4, 4, 0, 2, 4, 4, 4, 4, 4, 4, 0, 2, 4, 4, 4, 4, 4, 4, 0, 0, 4, 3, 0, 3, 0, 0, 0, 2, 0, 0, 3, 0, 3, 3, 0, 0, 3, 3, 3, 3, 3, 3, 0, 0, 3, 3, 3, 3, 3, 3, 0, 0, 3, 3, 0, 3, 0, 0, 0, 2, 0, 0, 2, 0, 2, 2, 0, 0, 2, 2, 2, 2, 2, 2, 0, 0, 2, 2, 2, 2, 2, 2, 0, 0, 2, 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 0); dcl board_4k (4) char (4) int static options (constant) init ( "ABCD", "FGHJ", "KLMN", "QRST"); /* End of 4k chip declarations */ %page; /* The following tables are for M264 16k chips */ dcl bit_16k (128) fixed bin (8) unal int static options (constant) init ( 79, 78, 77, 71, 76, 70, 69, -1, 75, 68, 67, 65, 66, 64, 63, -1, 74, 62, 61, 59, 60, 58, 57, -1, -1, 56, 55, -1, 54, -1, -1, -1, 73, -1, -1, 53, -1, 52, 51, -1, -1, 50, 49, 47, 48, 46, 45, -1, -1, 44, 43, 41, 42, 40, 39, -1, -1, 38, 37, -1, 36, -1, -1, -1, 72, -1, -1, 35, -1, 34, 33, -1, -1, 32, 31, 29, 30, 28, 27, -1, -1, 26, 25, 23, 24, 22, 21, -1, -1, 20, 19, -1, 18, -1, -1, -1, -1, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1, -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1); dcl chip_16k (0:79) char (3) unal int static options (constant) init ( "0A", "2A", "4A", "6A", "0B", "2B", "4B", "6B", "0C", "2C", "4C", "6C", "0D", "2D", "4D", "6D", "0E", "2E", "4E", "6E", "0F", "2F", "4F", "6F", "0G", "2G", "4G", "6G", "0H", "2H", "4H", "6H", "0J", "2J", "4J", "6J", "0K", "2K", "4K", "6K", "0R", "2R", "4R", "6R", "0S", "2S", "4S", "6S", "0T", "2T", "4T", "6T", "0U", "2U", "4U", "6U", "0V", "2V", "4V", "6V", "0W", "2W", "4W", "6W", "0X", "2X", "4X", "6X", "0Y", "2Y", "4Y", "6Y", "0Z", "2Z", "4Z", "6Z", "0AA", "2AA", "4AA", "6AA"); dcl board_16k (0:15) char (1) unal int static options (constant) init ( "A", "B", "C", "D", "E", "F", "G", "H", "J", "K", "L", "M", "N", "P", "Q", "R"); %page; /* The following tables are for M64 64k chips */ dcl bit_64k (128) fixed bin (8) unal int static options (constant) init ( 79, 78, 77, 71, 76, 70, 69, -1, 75, 68, 67, 65, 66, 64, 63, -1, 74, 62, 61, 59, 60, 58, 57, -1, -1, 56, 55, -1, 54, -1, -1, -1, 73, -1, -1, 53, -1, 52, 51, -1, -1, 50, 49, 47, 48, 46, 45, -1, -1, 44, 43, 41, 42, 40, 39, -1, -1, 38, 37, -1, 36, -1, -1, -1, 72, -1, -1, 35, -1, 34, 33, -1, -1, 32, 31, 29, 30, 28, 27, -1, -1, 26, 25, 23, 24, 22, 21, -1, -1, 20, 19, -1, 18, -1, -1, -1, -1, -1, -1, 17, -1, 16, 15, -1, -1, 14, 13, 11, 12, 10, 09, -1, -1, 08, 07, 05, 06, 04, 03, -1, -1, 02, 01, -1, 00, -1, -1, -1); dcl chip_64k_not_a6 (0:79) char (3) unal int static options (constant) init ( "01A", "19A", "37A", "55A", "01B", "19B", "37B", "55B", "01C", "19C", "37C", "55C", "01D", "19D", "37D", "55D", "01E", "19E", "37E", "55E", "01F", "19F", "37F", "55F", "01G", "19G", "37G", "55G", "01H", "19H", "37H", "55H", "01J", "19J", "37J", "55J", "01K", "19K", "37K", "55K", "01N", "19N", "37N", "55N", "01P", "19P", "37P", "55P", "01Q", "19Q", "37Q", "55Q", "01R", "19R", "37R", "55R", "01S", "19S", "37S", "55S", "01T", "19T", "37T", "55T", "01U", "19U", "37U", "55U", "01V", "19V", "37V", "55V", "01W", "19W", "37W", "55W", "01X", "19X", "37X", "55X"); dcl chip_64k_a6 (0:79) char (3) unal int static options (constant) init ( "10A", "28A", "46A", "64A", "10B", "28B", "46B", "64B", "10C", "28C", "46C", "64C", "10D", "28D", "46D", "64D", "10E", "28E", "46E", "64E", "10F", "28F", "46F", "64F", "10G", "28G", "46G", "64G", "10H", "28H", "46H", "64H", "10J", "28J", "46J", "64J", "10K", "28K", "46K", "64K", "10N", "28N", "46N", "64N", "10P", "28P", "46P", "64P", "10Q", "28Q", "46Q", "64Q", "10R", "28R", "46R", "64R", "10S", "28S", "46S", "64S", "10T", "28T", "46T", "64T", "10U", "28U", "46U", "64U", "10V", "28V", "46V", "64V", "10W", "28W", "46W", "64W", "10X", "28X", "46X", "64X"); dcl board_64k (0:15) char (1) unal int static options (constant) init ( "A", "B", "C", "D", "E", "F", "G", "H", "J", "K", "L", "M", "N", "P", "Q", "R"); %page; /* The edit_mos_rscr_ entry */ decode_sw = "0"b; join: scrp = arg_scrp; mem_type, error = ""; /* First, determine the kind of memory */ if scr_su.identification = "0000"b then mem_type = "High Speed Core, Model AA1"; else if scr_su.identification = "0001"b then mem_type = "High Speed Core, Model AA3"; else if scr_su.identification = "1100"b then mem_type = "MOS, 1k chip, EDAC disabled"; else if scr_su.identification = "0100"b then call edit_1k; else if scr_su.identification = "1111"b then call edit_M16; else if scr_su.identification = "1110"b then call edit_M128; else if scr_su.identification = "1010"b then call edit_M64; else if scr_su.identification = "1011"b then call edit_M264; else if scr_su.identification = "0011"b then call edit_M32; else do; call ioa_$rsnpnnl ("Unknown memory type, id=^4b", mem_type, (0), scr_su.identification); call ioa_$rsnpnnl ("ZAC line(bits 36-41)=^b, syndrome=^.3b", error, (0), scr_su.ZAC_line, "0"b || scr_su.syndrome); end; if decode_sw then do; arg_mem_type = mem_type; arg_error = error; end; else call ioa_$rsnpnnl ("^a, ^[Error: ^a^;No error.^]", arg_descrip, (0), mem_type, (error ^= ""), error); return; /* The edit_mos_rscr_$decode entry. Returns mem_type and error in seperate feilds */ decode: entry (arg_scrp, arg_mem_type, arg_error); decode_sw = "1"b; go to join; %page; /* Procedure to edit data for 1k chip */ edit_1k: proc; dcl a234 fixed bin; /* Bits 2,3,4 of addr */ dcl a56 fixed bin; /* Bits 5 and 6 */ mem_type = "MOS, 1k chip"; if scr_su.syndrome = "0"b then return; /* No error */ if ^substr (scr_su.syndrome, 8, 1) then do; /* Syndrome must be odd */ bad_1k_synd: call ioa_$rsnpnnl ("A2-A6=^b, syndrome=^.3b", error, (0), substr (scr_su.ZAC_line, 1, 5), "0"b || scr_su.syndrome); return; end; syndrome = bin (substr (scr_su.syndrome, 1, 7), 7) + 1; bit_no = bit_1k (syndrome); /* Map syndrome into bit number */ if bit_no < 0 then go to bad_1k_synd; quad = quad_1k (syndrome); a234 = bin (substr (scr_su.ZAC_line, 2, 3), 3); board = substr (board_1k (quad), a234 + 1, 1); a56 = bin (substr (scr_su.ZAC_line, 5, 2), 2); if bit_no < 10 then chip = 10 * a56 + bit_no + 1; else chip = 10 * a56 + (bit_no - 10) + 41; call ioa_$rsnpnnl ("board ^a-^a, chip A^d", error, (0), bay_1k (quad), board, chip); return; end edit_1k; %page; /* Procedure to edit 4k mos data */ edit_M16: proc; dcl a78 fixed bin; /* Bits 7-8 of address */ dcl a910 fixed bin; /* Bits 9 and 10 of address */ mem_type = "MOS-M16, 4k chip"; if scr_su.syndrome = "0"b then return; if ^substr (scr_su.syndrome, 8, 1) then do; /* Must be odd */ bad_4k_synd: call ioa_$rsnpnnl ("A7-A10=^b, syndrome=^.3b", error, (0), substr (scr_su.ZAC_line, 1, 4), "0"b || scr_su.syndrome); return; end; syndrome = bin (substr (scr_su.syndrome, 1, 7), 7) + 1; bit_no = bit_4k (syndrome); if bit_no < 0 then go to bad_4k_synd; quad = quad_4k (syndrome); a78 = bin (substr (scr_su.ZAC_line, 1, 2), 2); board = substr (board_4k (quad), a78 + 1, 1); a910 = bin (substr (scr_su.ZAC_line, 3, 2), 2); chip = 20 * a910 + bit_no; call ioa_$rsnpnnl ("board ^a, chip A^d", error, (0), board, chip); return; end edit_M16; %page; /* Procedure to edit data from 16-pin chip memories - 4k and 16k chips */ edit_M128: proc; dcl a45 fixed bin; dcl a678 fixed bin; dcl chip_letter char (1); dcl chip_pic picture "99"; dcl addr_bits char (32) var; mem_type = "MOS-M128, 16k chip"; addr_bits = "A4-A8"; edit_join: if scr_su.syndrome = "0"b then return; /* No error */ if ^substr (scr_su.syndrome, 8, 1) then do; /* Syndrome not odd */ bad_M128_synd: call ioa_$rsnpnnl ("^a=^b, syndrome=^.3b", error, (0), addr_bits, substr (scr_su.ZAC_line, 1, 5), "0"b || scr_su.syndrome); return; end; syndrome = bin (substr (scr_su.syndrome, 1, 7), 7) + 1; bit_no = bit_4k (syndrome); if bit_no < 0 then go to bad_M128_synd; quad = quad_4k (syndrome); a45 = bin (substr (scr_su.ZAC_line, 1, 2)); a678 = bin (substr (scr_su.ZAC_line, 3, 3)); board = substr (board_4k (quad), a45 + 1); chip_letter = substr ("ABCDEGHJKL", divide (bit_no, 2, 17, 0) + 1, 1); if mod (bit_no, 2) = 1 then chip_pic = 7 - a678; else chip_pic = 18 - a678; call ioa_$rsnpnnl ("board ^a, chip ^a^a", error, (0), board, chip_pic, chip_letter); return; edit_M32: entry; mem_type = "MOS-M32, 4k chip"; addr_bits = "A6-A10"; go to edit_join; end edit_M128; %page; /* Procedure to edit 16k M264 chip */ edit_M264: proc; dcl a4567 fixed bin; dcl a8 bit (1); dcl chip_name char (3); dcl chip_pic pic "9"; mem_type = "MOS-M264, 16k chip"; if scr_su.syndrome = "0"b then return; if ^substr (scr_su.syndrome, 8, 1) then do; /* Must be odd */ bad_M264_synd: call ioa_$rsnpnnl ("A4-A8=^b, syndrome=^.3b", error, (0), substr (scr_su.ZAC_line, 1, 5), "0"b || scr_su.syndrome); return; end; syndrome = bin (substr (scr_su.syndrome, 1, 7), 7) + 1; bit_no = bit_16k (syndrome); if bit_no < 0 then go to bad_M264_synd; a4567 = bin (substr (scr_su.ZAC_line, 1, 4), 4); a8 = substr (scr_su.ZAC_line, 5, 1); chip_name = chip_16k (bit_no); if a8 then do; chip_pic = bin (substr (chip_name, 1, 1)) + 1; substr (chip_name, 1, 1) = chip_pic; end; call ioa_$rsnpnnl ("board ^a, chip ^a", error, (0), board_16k (a4567), chip_name); return; end edit_M264; %page; /* Procedure to edit 64k M64 chip */ edit_M64: proc; dcl a2345 fixed bin; dcl a6 bit (1); dcl chip_name char (3); mem_type = "MOS-M64, 64k chip"; if scr_su.syndrome = "0"b then return; if ^substr (scr_su.syndrome, 8, 1) then do; /* Must be odd */ bad_M64_synd: call ioa_$rsnpnnl ("A2-A6=^b, syndrome=^.3b", error, (0), substr (scr_su.ZAC_line, 1, 5), "0"b || scr_su.syndrome); return; end; syndrome = bin (substr (scr_su.syndrome, 1, 7), 7) + 1; bit_no = bit_64k (syndrome); if bit_no < 0 then go to bad_M64_synd; a2345 = bin (substr (scr_su.ZAC_line, 1, 4), 4); a6 = substr (scr_su.ZAC_line, 5, 1); if a6 then chip_name = chip_64k_a6 (bit_no); else chip_name = chip_64k_not_a6 (bit_no); call ioa_$rsnpnnl ("board ^a, chip ^a", error, (0), board_64k (a2345), chip_name); return; end edit_M64; %page; /* The following debuging entries are commands which will check the translation tables for consistency and print a syndome table in a format similiar to that on the memory. These entries are not retained and are used only to help in verifying the correctness of the tables. */ debug_1k: entry; call debug_test (bit_1k, quad_1k); return; debug_4k: entry; call debug_test (bit_4k, quad_4k); return; debug_test: proc (b, q); dcl b (128) fixed bin (8) unal; dcl q (128) fixed bin (3) unal; dcl dat (4, 0:19) fixed bin; /* Table built here */ dcl (i, j) fixed bin; dcl bits (4) bit (9); dat = -1; do i = 1 to 128; if ^(b (i) = -1 & q (i) = 0) then do; /* If position not undefined */ if b (i) < 0 | b (i) > 19 | q (i) < 1 | q (i) > 4 then /* Bad number */ call ioa_ ("error at ^d: ^d, ^d", i, b (i), q (i)); else if dat (q (i), b (i)) ^= -1 then /* Duplicate (reused address?) */ call ioa_ ("duplicate at ^d: ^d, ^d", i, b (i), q (i)); else dat (q (i), b (i)) = i; end; end; do i = 1 to 4; /* Check for missing entries */ do j = 0 to 19; if dat (i, j) = -1 then call ioa_ ("no entry for ^d, ^d", j, i); end; end; do j = 0 to 19; /* Print table */ do i = 1 to 4; if dat (i, j) = -1 then bits (i) = (9)"1"b; else bits (i) = bit (bin (dat (i, j)-1, 8), 8) || "1"b; end; call ioa_ ("^2d ^(^3.3b ^)", j, bits); end; return; end debug_test; %page; debug_16k: entry; do i = 1 to 128; if bit_16k (i) >= 0 then call ioa_ ("^.3b ^a", "0"b || bit (bin (2 * (i-1) + 1, 8), 8), bit_name_16k ((bit_16k (i)))); end; do i = 0 to 79; call ioa_ ("^4a ^a ^d^a", bit_name_16k (i), chip_16k (i), bin (substr (chip_16k (i), 1, 1)) + 1, substr (chip_16k (i), 2)); end; return; bit_name_16k: proc (b) returns (char (2)); dcl b fixed bin; dcl p picture "99"; if b <= 71 then do; p = b; return (p); end; else do; p = b-71; return ("P" || substr (p, 2)); end; end bit_name_16k; %page; debug_64k: entry; do i = 1 to 128; if bit_64k (i) >= 0 then call ioa_ ("^.3b ^a", "0"b || bit (bin (2 * (i-1) + 1, 8), 8), bit_name_64k ((bit_64k (i)))); end; do i = 0 to 79; call ioa_ ("^4a ^a ^a", bit_name_64k (i), chip_64k_not_a6 (i), chip_64k_a6 (i)); end; return; bit_name_64k: proc (b) returns (char (3)); dcl b fixed bin; dcl p picture "99"; if b <= 71 then do; p = b; return (p); end; else do; p = b-71; return ("PC" || substr (p, 2)); end; end bit_name_64k; end edit_mos_rscr_;  extract.pl1 11/21/84 1206.3rew 11/21/84 1034.8 40221 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style1,ind2,^inddcls,ifthenstmt,dclind2,declareind2,ifthendo,ifthen*/ extract: ext: proc; /* Modified 2/24/81 by J. A. Bush for larger fdump header size */ /* Modified 10/15/81 by J. A. Bush to add the "-pathname" control arg */ /* Modified: October 1984 by Greg Texada to use copy_erf_seg_ to get the data. */ dcl seg_no fixed bin (15) uns; dcl delete_seg bit (1) init ("0"b); dcl tc fixed bin; dcl code fixed bin (35); dcl arg char (tc) based (tp); dcl (dump_name, ename, segname) char (32); dcl (dirname, dump_dir) char (168); dcl p_length fixed bin (19) uns; dcl (addrel, baseno, divide, fixed, mod, null, ptr, rel, size) builtin; dcl (p, tp) ptr; dcl (error_table_$namedup, error_table_$segknown) fixed bin (35) ext static; dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl copy_erf_seg_ entry (char (*), uns fixed bin (15), ptr, uns fixed bin (19), fixed bin (35)); dcl copy_erf_seg_$name entry (char (*), char (*), ptr, uns fixed bin (19), fixed bin (35)); dcl delete_$ptr entry (ptr, bit (36) aligned, char (*), fixed bin (35)); dcl get_dump_ptrs_$dump_dir entry (char (*), char (*), (0:31) ptr, (0:31) fixed bin, fixed bin, char (32)); dcl (ioa_, com_err_) entry options (variable); dcl ring0_get_$segptr_given_slt entry (char (*), char (*), ptr, fixed bin (35), ptr, ptr); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl get_wdir_ entry returns (char (168)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$get_max_length_seg entry (ptr, fixed bin, fixed bin (35)); dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); %page; segname = ""; call cu_$arg_ptr (1, tp, tc, code); /* pick up erf number */ if code ^= 0 then do; tell: call ioa_ ("Usage: extract erfno seg_name/number {-pathname (-pn) path}"); return; end; dump_name = arg; /* get name of dump from which to extract the segment */ call cu_$arg_ptr (3, tp, tc, code); /* get possible pathname arg */ if code = 0 then do; /* if present, check for -pathname arg */ if arg = "-pathname" | arg = "-pn" then do; call cu_$arg_ptr (4, tp, tc, code); /* get path */ if code ^= 0 then go to tell; /* give user usage message */ call absolute_pathname_ (arg, dump_dir, code); /* expand it */ if code ^= 0 then do; call com_err_ (code, "extract", "expanding pathname ""^a""", arg); return; end; end; else go to tell; /* give user usage message */ end; call cu_$arg_ptr (2, tp, tc, code); /* get name/number of segment to extract */ if tc = 0 | code ^= 0 then goto tell; seg_no = cv_oct_check_ (arg, code); /* assume octal arg was given */ if code ^= 0 then segname = arg; dirname = get_wdir_ (); ename = arg || "." || dump_name; call hcs_$make_seg (dirname, ename, "", 01011b, p, code); /* make the segment to contain the data */ if p = null then do; call com_err_ (code, "extract", "Creating ^a>^a", dirname, ename); return; end; delete_seg = ^(code = error_table_$namedup | code = error_table_$segknown); /* delete it if we can't do the work */ if segname = "" then call copy_erf_seg_ (dump_name, seg_no, p, p_length, code); else call copy_erf_seg_$name (dump_name, segname, p, p_length, code); if code ^= 0 then do; call com_err_ (code, "extract", "Could not find ERF ^a using the dumps search list.", dump_name); if delete_seg then call delete_$ptr (p, "010111"b, "extract", code); end; else call terminate_file_ (p, 0, TERM_FILE_TERM, (0)); %page; %include terminate_file; end extract;  find_config_card_.pl1 11/15/82 1825.9rew 11/15/82 1450.1 33507 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* FIND_CONFIG_CARD_ - Procedure to find a card in the config deck */ /* Adapted January 1980 by Larry Johnson from hardcore procedure 'config', written 3/12/74 by N. I. Morris */ /* Modified September 1982 by C. Hornig to remove common code to config_. */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ find_config_card_: procedure; dcl p ptr parameter; /* pointer to config card */ dcl a_iom fixed bin (3) parameter; dcl a_chan fixed bin (6) parameter; dcl config_$find entry (char (4) aligned, ptr); dcl config_$find_periph entry (char (4) aligned, ptr); dcl card_iom fixed bin (3); dcl card_chan fixed bin (8); dcl card_nchan fixed bin; dcl i fixed bin; /* iteration variable */ dcl (hbound, null, substr) builtin; %page; /* PRPH_FOR_CHANNEL - Given an iom and channel, this entry returns the prph card for the device connected to the channel. calling sequence: call find_config_card_$prph_for_channel (iom, chann, p); */ prph_for_channel: entry (a_iom, a_chan, p); prph_cardp = null (); do while ("1"b); call config_$find ("prph", prph_cardp); if prph_cardp = null () then goto no_prph; if substr (prph_card.name, 1, 3) = "tap" then do; prph_tap_cardp = prph_cardp; card_iom = prph_tap_card.iom; card_chan = prph_tap_card.chan; card_nchan = prph_tap_card.nchan; end; else if substr (prph_card.name, 1, 3) = "dsk" then do; prph_dsk_cardp = prph_cardp; card_iom = prph_dsk_card.iom; card_chan = prph_dsk_card.chan; card_nchan = prph_dsk_card.nchan; end; else do; card_iom = prph_card.iom; card_chan = prph_card.chan; card_nchan = 1; end; if (card_iom = a_iom) & (card_chan <= a_chan) & (card_chan + card_nchan > a_chan) then do; p = prph_cardp; return; end; end; no_prph: chnl_cardp = null (); do while ("1"b); call config_$find ("chnl", chnl_cardp); if chnl_cardp = null () then do; p = null (); return; end; do i = 1 to hbound (chnl_card.group, 1) while (chnl_card.iom (i) ^= -1); if (chnl_card.iom (i) = a_iom) & (chnl_card.chan (i) <= a_chan) & (chnl_card.chan (i) + chnl_card.nchan (i) > a_chan) then do; call config_$find_periph (chnl_card.name, p); /* Get associated prph card */ return; end; end; end; %page; /* MPC_FOR_CHANNEL - Given an iom and channel, this entry returns the mpc card for the controller connected to the channel. calling sequence: call find_config_card_$mpc_for_channel (iom, chann, p); */ mpc_for_channel: entry (a_iom, a_chan, p); mpc_cardp = null (); do while ("1"b); call config_$find ("mpc", mpc_cardp); if mpc_cardp = null () then do; p = null (); return; end; do i = 1 to hbound (mpc_card.port, 1) while (mpc_card.port (i).iom ^= -1); if (a_iom = mpc_card.port (i).iom) & (a_chan >= mpc_card.port (i).chan) & (a_chan < mpc_card.port (i).chan + mpc_card.port (i).nchan) then do; p = mpc_cardp; return; end; end; end; %page; %include config_chnl_card; %include config_mpc_card; %include config_prph_card; %include config_prph_dsk_card; %include config_prph_tap_card; end find_config_card_;  identify_io_channel_.pl1 03/25/86 0857.0rew 03/25/86 0856.3 51219 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-09,Farley), approve(85-09-09,MCR6979), audit(86-02-19,Coppola), install(86-03-21,MR12.0-1033): Support IMU. END HISTORY COMMENTS */ /* format: style2,indcomtxt */ identify_io_channel_: procedure (P_configp, P_iom, P_channel, P_name, P_code); /* Procedure to identify individual IOM channels */ /* Split out of interrupt_meters, August, 1981, W. Olin Sibert */ /* Modified for prph fnp cards BIM 83-12-15 */ /* Modified Feb 1985 by Paul Farley for IMU changes */ dcl P_configp pointer parameter; /* Pointer to config deck used for channel identification */ dcl P_iom fixed bin (3) parameter; /* IOM number */ dcl P_channel fixed bin (8) parameter; /* Channel number */ dcl P_name char (*) parameter;/* Returned, interpreted channel name */ dcl P_code fixed bin (35) parameter; dcl iom fixed bin (3); dcl channel fixed bin (8); dcl error_table_$bad_channel fixed bin (35) external static; dcl OVERHEAD_CHANNELS (0:7) char (32) varying internal static options (constant) init ("overhead channel zero", "system fault", "connect", "snapshot", "wraparound", "bootload", "special", "scratchpad"); dcl IOM_NAMES (1:8) char (8) varying internal static options (constant) init ("IOM A", "IOM B", "IOM C", "IOM D", "IOM E", "IOM F", "IOM G", "IOM H"); dcl IMU_OVERHEAD_CHANNELS (0:7) char (32) varying internal static options (constant) init ("overhead channel zero", "system fault", "connect", "mca", "overhead channel four", "bootload", "special", "overhead channel seven"); dcl IMU_NAMES (1:8) char (8) varying internal static options (constant) init ("IMU A", "IMU B", "IMU C", "IMU D", "IMU E", "IMU F", "IMU G", "IMU H"); dcl TAGS (1:8) char (1) aligned internal static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl (addr, addrel, divide, hbound, max, min, null, size, substr) builtin; /* */ iom = P_iom; channel = P_channel; if (iom < 1) | (iom > 4) | (channel < 0) | (channel > 63) then do; INVALID_IO_CHANNEL: P_name = "invalid channel number"; P_code = error_table_$bad_channel; return; end; if P_configp = null () then /* Default is running system config deck */ cardp = addr (config_deck$); /* Prepare to look through the config deck */ else cardp = P_configp; P_name = lookup (); P_code = 0; /* Consider successful, even if unidentifiable */ return; /* All done */ /* */ lookup: procedure () returns (char (32)); /* This procedure returns the "name" of the specified channel, as best it can */ dcl first_channel fixed bin (8); dcl last_channel fixed bin (8); dcl field fixed bin; if (channel <= hbound (OVERHEAD_CHANNELS, 1)) then do; do while (config_card.word ^= FREE_CARD_WORD); /* look for sentinel at end */ if config_card.word = IOM_CARD_WORD then do; iom_cardp = cardp; if iom_card.tag = iom then do; if iom_card.model = "imu" | iom_card.model = "iioc" then return (IMU_NAMES (iom) || " " || IMU_OVERHEAD_CHANNELS (channel)); else return (IOM_NAMES (iom) || " " || OVERHEAD_CHANNELS (channel)); end; end; cardp = addrel (cardp, size (config_card)); /* On to the next config card */ end; return (IOM_NAMES (iom) || " " || OVERHEAD_CHANNELS (channel)); end; do while (config_card.word ^= FREE_CARD_WORD); /* look for sentinel at end */ if config_card.word = CHNL_CARD_WORD then do; chnl_cardp = cardp; do field = 1 to hbound (chnl_card_array.group, 1); /* Loop through channels which exist */ first_channel = chnl_card.chan (field); last_channel = chnl_card.chan (field) + chnl_card.nchan (field) - 1; if iom = chnl_card.iom (field) then if channel >= first_channel then if channel <= last_channel then return (chnl_card.name); end; end; else if config_card.word = PRPH_CARD_WORD then do; prph_cardp = cardp; prph_dsk_cardp = cardp; prph_tap_cardp = cardp; if iom ^= prph_card.iom then goto NEXT_CARD; first_channel = prph_card.chan; if /* case */ substr (prph_card.name, 1, 3) = "dsk" then last_channel = first_channel + prph_dsk_card.nchan - 1; else if substr (prph_card.name, 1, 3) = "tap" then last_channel = first_channel + prph_tap_card.nchan - 1; else last_channel = first_channel; if channel >= first_channel then if channel <= last_channel then return (prph_card.name); end; NEXT_CARD: cardp = addrel (cardp, size (config_card)); /* On to the next config card */ end; return ("unidentifiable channel"); end lookup; %page; %include config_deck; %page; %include config_iom_card; %page; %include config_chnl_card; %page; %include config_prph_card; %page; %include config_prph_tap_card; %page; %include config_prph_dsk_card; end identify_io_channel_;  mc_trace.pl1 11/15/82 1825.9rew 11/15/82 1450.1 193473 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ mc_trace: mct: proc; /* mc_trace - machine condition trace, initially coded March 1977 by James A. Bush taken from original idea by Bernie Greenberg and Steve Webber Modified 780327 by J. A. Bush to add -all and -hc control args Modified Oct 1982 by Rich Coppola to disable tracing when displaying MCs or hregs. Also corrected hreg headers when hregs are from a DPS8 CPU. */ dcl cu_$cp entry (ptr, fixed bin, fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl phcs_$trace_buffer_init entry (ptr, bit (1) aligned, fixed bin, ptr, fixed bin (35)); dcl phcs_$hc_trace_on_off entry (bit (1) aligned, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl (ioa_, com_err_, ioa_$ioa_switch, ioa_$ioa_switch_nnl) entry options (variable); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl prtscu_$on_line entry (ptr, ptr, bit (1)); dcl dump_machine_cond_$mc_only entry (ptr, char (32)); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl ring0_get_$name entry (char (*), char (*), ptr, fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl hran_$hrlgnd entry (ptr); dcl hran_$hranl entry (ptr, ptr, bit (1)); dcl (null, fixed, addr, addrel, divide, baseno, baseptr, length, substr, rel, ltrim, search) builtin; dcl (iox_$user_input, iox_$error_output) ptr ext; dcl (any_other, cleanup) condition; dcl dir_name char (168); dcl ename char (32); dcl com_string char (132) aligned; dcl arg char (al) based (ap); dcl (code, lp_cnt) fixed bin (35); dcl (i, j, k, acnt, al, lp) fixed bin; dcl (ap, sp, mcp, scup) ptr; dcl mc_pos (260) fixed bin unaligned; dcl p_name char (8) init ("mc_trace"); dcl ll fixed bin (21); dcl buf_size fixed bin init (5); /* default buffer size */ dcl (trace_on, brief, lo, path_sw, buf_sw, hc_all, hc_sw) bit (1) unaligned init ("0"b); dcl WS char (2) int static options (constant) init (" "); % include mc_trace_buf; /* */ /* process arguments */ call cu_$arg_count (acnt); /* get no of args */ if acnt = 0 then do; /* tell user what to do */ arger: call com_err_ (0, p_name, "Usage: ^a path {-brief | -bf} {-buffer | -buf }", p_name); return; end; do i = 1 to acnt; /* process arguments */ call cu_$arg_ptr (i, ap, al, code); /* get arg */ if code ^= 0 then do; /* some days you can't win */ call com_err_ (code, p_name, "getting arg"); return; end; if arg = "-all" | arg = "-hc" then do; /* if special trace */ hc_all, path_sw = "1"b; if arg = "-all" then /* if tracing all faults and interrupts */ sp = baseptr (0); /* set indicator for hardcore */ else hc_sw = "1"b; /* tracing hardcore seg */ end; else if ^path_sw then do; /* if not special trace, pathname arg must be first */ path_sw = "1"b; call expand_pathname_ (arg, dir_name, ename, code); if code ^= 0 then do; /* some problem with pathname */ call com_err_ (code, p_name, "expanding pathname ^a", arg); return; end; end; else if hc_sw then do; /* user wants to trace hard core seg */ hc_sw = "0"b; lp_cnt = cv_oct_check_ (arg, code); /* convert to seg number */ if code ^= 0 then do; /* might be name */ call ring0_get_$segptr ("", arg, sp, code); if code ^= 0 then do; /* user got something wrong */ call com_err_ (code, p_name, "getting hardcore segment ^a", arg); return; /* let him re-enter */ end; end; else do; /* user entered number, verify */ sp = baseptr (lp_cnt); /* that it is a valid hc seg */ call ring0_get_$name ("", ename, sp, code); if code ^= 0 then do; /* not a valid hc seg */ call com_err_ (code, p_name, "getting hardcore segment ^o", lp_cnt); return; /* return and make him get it right */ end; end; if fixed (baseno (sp)) = 0 then /* tracing dseg will get all faults and ints. */ call com_err_ (0, p_name, "Warning tracing segment # 0 will result in tracing all faults and interrupts"); end; else if buf_sw then do; /* got buffer size arg */ buf_sw = "0"b; /* don't want to come here again */ lp_cnt = cv_dec_check_ (arg, code); buf_size = lp_cnt; if code ^= 0 | buf_size > max_buf_size | buf_size <= 0 then do; /* user goofed */ call com_err_ (0, p_name, "buffer size arg ^a invalid or too big", arg); return; end; end; else if arg = "-buffer" | arg = "-buf" then /* user wants a bigger buffer */ buf_sw = "1"b; else if arg = "-brief" | arg = "-bf" then /* user does not want prompt */ brief = "1"b; /* set brief switch */ else do; call com_err_ (0, p_name, "Invalid argument ^a", arg); go to arger; end; end; /* initiate object segment to trace */ if ^hc_all then do; /* if ring 4 segment to be traced */ call hcs_$initiate (dir_name, ename, "", 0, 0, sp, code); if sp = null then do; /* can't find it */ call com_err_ (code, p_name, "initiating object segment ^a>^a", dir_name, ename); return; end; end; /* Now we are ready to start the hardcore trace */ call phcs_$trace_buffer_init (sp, "1"b, buf_size, bp, code); if code ^= 0 then do; /* must have had problem starting trace */ call com_err_ (code, p_name, "attempting to initialize hardcore tracing"); return; end; trace_on = "1"b; /* set switch to indicate we are traceing */ on any_other begin; call cond_hand; /* set up condition handler */ call phcs_$hc_trace_on_off ("0"b, code); /* turn off hardcore tracing mechanism */ end; on cleanup call clean; /* set up condition handler for cleanup condition */ /* Now we are ready to ask user for input to trace something */ request: com_string = ""; /* clear out last command */ if ^brief then /* if not in brief mode */ call ioa_$ioa_switch_nnl (iox_$error_output, "--> "); /* print out prompt for user */ call iox_$get_line (iox_$user_input, addr (com_string), length (com_string), ll, code); if code ^= 0 then do; /* error reading from terminal */ call com_err_ (code, p_name, "reading input from user_input"); go to request; end; ll = ll - 1; /* adjust line length to ignor the N. L. char */ if ll = 0 then go to request; /* ignor white space */ /* strip off leading white space */ i = length (ltrim (substr (com_string, 1, ll), WS)); j = (ll - i) + 1; /* get start of good data */ substr (com_string, 1, i) = substr (com_string, j, ll); substr (com_string, i + 1) = ""; /* pad rest of line with blanks */ /* Process requests */ if substr (com_string, 1, 1) ^= "." then do; /* user made syntax error */ errsp: call com_err_ (0, p_name, "Invalid response ^a, reenter", com_string); go to request; end; ll = i; /* copy new line length */ if ll = 1 then /* user wants to know where he is at */ call ioa_ ("^a", p_name); /* so tell him */ else if substr (com_string, 1, ll) = ".q" then do; /* user wants to quit */ call clean; /* clean up */ return; end; /* and exit */ else if substr (com_string, 1, 2) = ".." then do; /* user wants to execute Multics cmd */ substr (com_string, 1, ll - 2) = substr (com_string, 3, ll - 2); /* adjust cmd in buffer */ call phcs_$hc_trace_on_off ("1"b, code); /* turn on hardcore tracing mechanism */ if code ^= 0 then do; /* can't turn trace on */ call com_err_ (code, p_name, "attempting to turn trace on"); go to request; end; call cu_$cp (addr (com_string), ll - 2, code); /* and execute cmd */ call phcs_$hc_trace_on_off ("0"b, code); /* turn off hardcore tracing mechanism */ end; else if substr (com_string, 1, 4) = ".rpt" then do; /* user wants to repeat cmd */ lp = 5; /* set line position */ lp_cnt = parse (); /* get the loop count arg */ if lp_cnt = -1 then /* user goofed typing in */ go to errsp; j = ll - lp + 1; substr (com_string, 1, j) = substr (com_string, lp, j); /* adjust cmd */ call phcs_$hc_trace_on_off ("1"b, code); /* turn on hardcore tracing mechanism */ if code ^= 0 then do; /* can't turn trace on */ call com_err_ (code, p_name, "attempting to turn trace on"); go to request; end; do i = 1 to lp_cnt; /* execute cmd requested number of times */ call cu_$cp (addr (com_string), j, code); end; call phcs_$hc_trace_on_off ("0"b, code); /* turn off hardcore tracing mechanism */ end; else if substr (com_string, 1, 5) = ".pmc " then /* user wants to print M. C. */ call display_mc (5, 1); /* display M. C. in octal */ else if substr (com_string, 1, 5) = ".pmci" then /* user wants interpreted M. C. */ call display_mc (6, 2); /* display M. C. interpreted */ else if substr (com_string, 1, 5) = ".pscu" then /* user wants only scu data */ call display_mc (6, 3); /* Display M. C. scu data only */ else if substr (com_string, 1, 4) = ".hr " then /* User wants to see history regs in octal */ call display_hregs (4, 1, "1"b); /* display all history regs */ else if substr (com_string, 1, 5) = ".hrou" then /* user wants only OU history regs */ call display_hregs (6, 1, "0"b); else if substr (com_string, 1, 5) = ".hrcu" then /* user only wants to see CU histroy regs */ call display_hregs (6, 2, "0"b); else if substr (com_string, 1, 5) = ".hrdu" then /* user wants to see DU history regs */ call display_hregs (6, 3, "0"b); else if substr (com_string, 1, 5) = ".hrau" then /* user wants to see APU History regs */ call display_hregs (6, 4, "0"b); else if substr (com_string, 1, 6) = ".hranl" then /* user wants analisis of history regs */ call display_hregs (7, 5, "0"b); else if substr (com_string, 1, 6) = ".hrlgd" then do; /* user wants to know what abrevs mean */ call ioa_ ("^/Abbreviations used in History Register Analysis^/"); call hran_$hrlgnd (null); end; else go to errsp; /* invalid request */ go to request; /* get nxt request */ /* display_mc - internal procedure to display requested number of Machine Conditions from the M. C. buffer */ display_mc: proc (line_pos, type); dcl (line_pos, type, count, limit) fixed bin; call phcs_$hc_trace_on_off ("0"b, code); /* turn off hardcore tracing mechanism */ j = mc_trace_buf.mc_nxtad; /* start with next avail location */ if j = mc_trace_buf.mc_strt then /* if at beginning of buffer */ if mach_cond (1).scu_dta (1) = buf_init then do; /* no M. C. stored */ call ioa_ ("Machine Condition buffer empty"); return; end; call get_args (line_pos, count, limit); /* get further args */ if count = 0 then /* No args set count to display entire buffer */ count = mc_trace_buf.mc_cnt; /* first get cronilogical order of M. C.'s, last to first */ do i = 1 to count; /* get each requested M. C. */ if j = mc_trace_buf.mc_strt then /* if at beginning of buffer */ j = (mc_cnt - 1) * mc_size + mc_trace_buf.mc_strt; /* set to last M. C. */ else j = j - mc_size; /* just decrement to nxt M. C. */ k = divide ((j + mc_size) - mc_trace_buf.mc_strt, mc_size, 17, 0); /* get array index */ if mach_cond (k).scu_dta (1) ^= buf_init then mc_pos (i) = k; /* if M. C. valid */ else go to too_many; /* if not valid, exit */ end; too_many: if i - 1 ^= count then do; /* if not all requested M. C.'s valid */ call ioa_ ("Only ^d sets of Machine Conditions are valid", i - 1); count = i - 1; /* adjust count */ end; call set_line_length; /* set up output length parameters */ if limit = 0 | limit > count then /* set up defaults */ limit = 1; else limit = count - (limit - 1); do i = count to limit by -1; /* this is really forward */ j = mc_pos (i); mcp = addr (mc_trace_buf.mach_cond (j)); /* form ptr to machine condition */ call ioa_ ("^/^/*****Machine Conditions at mc_trace_buffer|^o*****", fixed (rel (mcp))); go to mc_prt (type); /* print M. C.'s in requested form */ mc_prt (1): /* display M. C.'s in octal format */ call ioa_ ("^/Pointer Registers"); call display_oct (addr (mach_cond (j).spri_dta (1)), 2); /* print in octal format */ call ioa_ ("^/Processor Registers"); call display_oct (addr (mach_cond (j).sreg_dta (1)), 1); /* print in octal format */ call ioa_ ("^/SCU Data"); call display_oct (addr (mach_cond (j).scu_dta (1)), 1); /* print in octal format */ call ioa_ ("^/Software Data"); call display_oct (addr (mach_cond (j).sw_dta (1)), 1); /* print in octal format */ call ioa_ ("^/EIS Pointers and Lengths"); call display_oct (addr (mach_cond (j).spl_dta (1)), 1); /* print in octal format */ go to p_nxt; /* go print next M. C. */ mc_prt (2): /* display M. C.'s in interpreted form */ call ioa_ (" "); call dump_machine_cond_$mc_only (mcp, "user_output"); /* that was simple */ go to p_nxt; /* go print next M.C. */ mc_prt (3): /* display SCU data only */ scup = addr (mc_trace_buf.mach_cond (j).scu_dta (1)); /* set up ptr first */ call ioa_ ("^/SCU data at mc_trace_buffer|^o^/", fixed (rel (scup))); call prtscu_$on_line (null, scup, "1"b); /* interpret scu data */ p_nxt: end; end display_mc; /* parse - internal procedure to parse cmd line for numerical string and return as decimal constant */ parse: proc returns (fixed bin (35)); dcl count fixed bin (35); if lp > ll then /* if at end of line */ return (-1); i = length (ltrim (substr (com_string, lp, ll - lp), WS)); /* strip off leading white space */ lp = lp + ((ll - lp) - i); /* update line position */ i = search (substr (com_string, lp), WS); /* find end of string */ count = cv_dec_check_ (substr (com_string, lp, i - 1), code); /* convert to decimal */ if code ^= 0 then /* not decimal number return w/error */ return (-1); lp = lp + i; /* update line position */ return (count); end parse; /* clean - internal procedure to turn off trace and unwire trace buffer */ clean: proc; if trace_on then do; /* turn trace off if on */ call phcs_$trace_buffer_init (sp, "0"b, buf_size, bp, code); if code ^= 0 then call com_err_ (code, p_name, "attempting to turn trace off"); trace_on = "0"b; end; end clean; /* set_line_length - internal procedure to set output length parameters based on the terminal line length */ set_line_length: proc; i = get_line_length_$switch (null, code); /* get terminal line length */ if i < 104 & code = 0 then lo = "0"b; else lo = "1"b; end set_line_length; /* */ /* display_hregs - internal procedure to display requested number of history registers */ display_hregs: proc (line_pos, type, cont); dcl cont bit (1); dcl (line_pos, type, count, limit, cpu_type) fixed bin; call phcs_$hc_trace_on_off ("0"b, code); /* turn off hardcore tracing mechanism */ j = mc_trace_buf.hr_nxtad; /* start with next avail location */ if j = mc_trace_buf.hr_strt then /* if at beginning of buffer */ if substr (h_regs (1).ou_hr (1), 1, 36) = buf_init then do; /* no H. R. stored */ call ioa_ ("History Register buffer empty"); return; end; call get_args (line_pos, count, limit); /* get further args */ if count = 0 then /* No args set count to display entire buffer */ count = mc_trace_buf.hr_cnt; /* first get cronilogical order of H. R.'s, last to first */ do i = 1 to count; /* get each requested H. R. */ if j = mc_trace_buf.hr_strt then /* if at beginning of buffer */ j = (hr_cnt - 1) * hr_size + mc_trace_buf.hr_strt; /* set to last H. R. */ else j = j - hr_size; /* just decrement to nxt H. R. */ k = divide ((j + hr_size) - mc_trace_buf.hr_strt, hr_size, 17, 0); /* get array index */ if substr (h_regs (k).ou_hr (1), 1, 36) ^= buf_init then mc_pos (i) = k; /* if H. R. valid */ else go to too_many2; /* if not valid, exit */ end; too_many2: if i - 1 ^= count then do; /* if not all requested H. R.'s valid */ call ioa_ ("Only ^d sets of History Registers are valid", i - 1); count = i - 1; /* adjust count */ end; call set_line_length; /* set up output length parameters */ if limit = 0 | limit > count then /* set up defaults */ limit = 1; else limit = count - (limit - 1); do i = count to limit by -1; /* this is really forward */ j = mc_pos (i); call ioa_ ("^2/*****History Registers at mc_trace_buffer|^o*****", fixed (rel (addr (mc_trace_buf.h_regs (j))))); if substr (h_regs (j).du_hr (1), 72, 1) = "1"b then cpu_type = 0; /* its a l68 */ go to dhr (type); /* display requested history reg */ dhr (1): /* label for OU history register display */ if cpu_type = 0 then call ioa_ ("^/Operations Unit (OU) History Registers"); else call ioa_ ("^/Decimal Unit/Operations Unit (DU/OU) History Registers"); call display_oct (addr (h_regs (j).ou_hr (1)), 4); /* print out octal history regs */ if ^cont then go to p_nxt1; /* user wants OU history regs only */ dhr (2): /* label for CU History Registers */ call ioa_ ("^/Control Unit (CU) History Registers"); call display_oct (addr (h_regs (j).cu_hr (1)), 4); /* print out octal history regs */ if ^cont then go to p_nxt1; /* user wants CU history regs only */ dhr (3): /* label for DU history reg display */ if cpu_type = 0 then call ioa_ ("^/Decimal Unit (DU) History Registers"); else call ioa_ ("^/Appending Unit #2 (AU2) History Registers"); call display_oct (addr (h_regs (j).du_hr (1)), 4); /* print out octal history regs */ if ^cont then go to p_nxt1; /* user wants du history regs only */ dhr (4): /* label for APU history reg display */ if cpu_type = 0 then call ioa_ ("^/Appending Unit (AU) History Registers"); else call ioa_ ("^/Appending Unit #1 (AU1) History Registers"); call display_oct (addr (h_regs (j).au_hr (1)), 4); /* print out octal history regs */ go to p_nxt1; dhr (5): call ioa_ ("^/Composite Analysis of History Registers^/"); call hran_$hranl (addr (h_regs (j).ou_hr (1)), null, lo); p_nxt1: end; end display_hregs; /* display_oct - internal procedure for displaying a requested number of 8 word blocks in octal to stream user_output */ display_oct: proc (iwp, sets); dcl (iwp, wp) ptr; dcl (sets, i) fixed bin; dcl w (8) fixed bin based (wp); wp = iwp; /* copy pointer */ do i = 1 to sets; /* iterate requested number of times */ call ioa_ ("^4(^w ^)^[^;^/^]^4(^w ^)", w (1), w (2), w (3), w (4), lo, w (5), w (6), w (7), w (8)); wp = addrel (wp, 8); /* increment pointer */ end; end display_oct; /* get_args - internal procedure to get numerical args from cmd line and return count and limit values */ get_args: proc (init_lp, cnt, lmt); dcl (init_lp, cnt, lmt) fixed bin; cnt, lmt = 0; /* initially set returns to 0 */ if init_lp >= ll then /* no further args */ return; lp = init_lp; /* set up line position */ lp_cnt = parse (); /* get count arg */ if lp_cnt = -1 then /* conversion error */ go to errsp; /* no local goto */ cnt = lp_cnt; /* conversion ok set return count parameter */ lp_cnt = parse (); if lp_cnt ^= -1 then /* set limit only if valid */ lmt = lp_cnt; end get_args; /* */ /* cond_hand - internal procedure to implement the "any_other" condition handler */ cond_hand: proc; dcl ec fixed bin (35); dcl 1 condinfo aligned, % include cond_info; call find_condition_info_ (null, addr (condinfo), ec); /* get some info about condition */ /* pass on any condition we can not handle */ if condition_name = "alrm" then go to cts; if condition_name = "cput" then go to cts; if condition_name = "program_interrupt" then go to cts; if condition_name = "mme2" then go to cts; if condition_name = "stack" then go to cts; if condition_name = "command_error" then go to cts; if condition_name = "finish" | condition_name = "cleanup" then do; call clean; cts: call continue_to_signal_ (ec); return; end; call phcs_$hc_trace_on_off ("0"b, ec); /* turn off hardcore tracing mechanism */ call ioa_$ioa_switch (iox_$error_output, "^a condition raised, enter command", condition_name); go to request; end cond_hand; end mc_trace;  mcs_version.pl1 10/25/89 1202.5r w 10/25/89 1000.0 28755 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ mcs_version: proc; /* a command/active function that returns/prints the name of the version * of MCS most recently bootloaded into a specified FNP (defaults to a) * * Written 6/9/77 by Robert Coren */ /* ENTRIES */ dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl (ioa_, com_err_, active_fnc_err_) entry options (variable); dcl ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl ring_zero_peek_ entry (ptr, ptr, fixed bin, fixed bin (35)); dcl parse_fnp_name_ entry (char (*), fixed bin); dcl err_entry entry variable options (variable); /* ARGUMENT STUFF */ dcl ret_ptr ptr; dcl ret_l fixed bin; dcl ret_str char (ret_l) varying based (ret_ptr); dcl argp ptr; dcl argl fixed bin; dcl arg char (argl) based (argp); /* EXT STATIC */ dcl (error_table_$not_act_fnc, error_table_$too_many_args) fixed bin (35) ext static; /* INTERNAL STATIC */ dcl prog_name char (11) int static options (constant) init ("mcs_version"); /* AUTOMATIC */ dcl code fixed bin (35); dcl nargs fixed bin; dcl fnp_no fixed bin; dcl sourcep ptr; dcl our_version char (4); dcl af bit (1); dcl (addr, index) builtin; %include dn355_data; call cu_$af_return_arg (nargs, ret_ptr, ret_l, code); if code = error_table_$not_act_fnc then do; af = "0"b; err_entry = com_err_; call cu_$arg_count (nargs); end; else if code ^= 0 then do; call active_fnc_err_ (code, prog_name); return; end; else do; af = "1"b; err_entry = active_fnc_err_; end; if nargs = 0 then fnp_no = 1; else if nargs = 1 then do; call cu_$arg_ptr (1, argp, argl, code); call parse_fnp_name_ (arg, fnp_no); if fnp_no < 0 then do; call err_entry (0, prog_name, "Invalid FNP tag ^a", arg); return; end; end; else do; call err_entry (error_table_$too_many_args, prog_name, "Usage: mcs_version {fnp_tag}"); return; end; call ring0_get_$segptr ("", "dn355_data", infop, code); if code ^= 0 then do; call err_entry (code, prog_name, "Could not get pointer to dn355_data"); return; end; sourcep = addr (datanet_info.per_datanet (fnp_no).version); call ring_zero_peek_ (sourcep, addr (our_version), 1, code); if code ^= 0 then do; call err_entry (code, prog_name, "Could not copy version from dn355_data"); return; end; if our_version = "" | our_version = low (4) then our_version = "none"; if af then ret_str = our_version; else call ioa_ (our_version); return; end /* mcs_version */ ;  parse_io_channel_name_.pl1 11/15/82 1825.9rew 11/15/82 1450.1 18468 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ parse_io_channel_name_: proc (arg_string, arg_iom, arg_channel, arg_code); /* PARSE_IO_CHANNEL_NAME_ - Procedure to parse a character string representing an iom and channel */ /* Written February 1980 by Larry Johnson */ /* Modified 11 August, 1981, W. Olin Sibert, for decimal channel numbers */ /* Modified October 1982 by C. Hornig for new PRPH TAP card. */ /* The format of the string is: tdd - an iom tag (a thru h) followed by a channel number */ /* Arguments */ dcl arg_string char (*); dcl arg_iom fixed bin (3); dcl arg_channel fixed bin (8); dcl arg_code fixed bin (35); /* Automatic */ dcl code fixed bin (35); dcl iom fixed bin (3); dcl channel fixed bin (35); /* External */ dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl error_table_$bad_channel fixed bin (35) ext static; dcl (index, length, substr) builtin; %page; if length (arg_string) < 1 then do; error: arg_iom = 0; arg_channel = 0; arg_code = error_table_$bad_channel; return; end; iom = index ("abcdefgh", substr (arg_string, 1, 1)); if iom = 0 then iom = index ("ABCDEFGH", substr (arg_string, 1, 1)); if iom = 0 then go to error; if length (arg_string) < 2 then go to error; channel = cv_dec_check_ (substr (arg_string, 2), code); if code ^= 0 then go to error; if channel < 0 | channel > 63 then go to error; arg_iom = iom; arg_channel = channel; arg_code = 0; return; end parse_io_channel_name_;  patch_ring_zero.pl1 11/15/82 1825.9rew 11/15/82 1505.7 44028 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ patch_ring_zero: prz: procedure () options (variable); /* This procedure allows privileged users to patch locations in ring 0. If necessary the descriptor segment is patched to give access to patch a non-write permit segment */ dcl tc fixed bin (21); dcl tp pointer; dcl targ char (tc) based (tp); dcl code fixed bin (35); dcl i fixed bin; dcl first fixed bin; dcl force_sw bit (1) aligned; dcl processid bit (36) aligned; dcl data (0 : 99) fixed bin (35); dcl data1 (0 : 99) fixed bin (35); dcl count fixed bin (18); dcl datap pointer; dcl data1p pointer; dcl ok_to_patch bit (1) aligned; dcl segptr pointer; dcl dsp0 pointer; dcl tsdwp pointer; dcl 1 tsdw aligned like sdw automatic; dcl error_table_$noarg fixed bin (35) external static; dcl com_err_ entry options (variable); dcl command_query_$yes_no entry options (variable); dcl cv_oct_ entry (char (*)) returns (fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl get_process_id_ entry () returns (bit (36) aligned); dcl hphcs_$pxss_set_timax entry (bit (36) aligned, fixed bin (35)); dcl hphcs_$ring_0_patch entry (pointer, pointer, fixed bin (18)); dcl ioa_ entry options (variable); dcl ring_zero_peek_ entry (pointer, pointer, fixed bin (18), fixed bin (35)); dcl ring0_get_$segptr entry (char (*), char (*), pointer, fixed bin (35)); dcl WHOAMI char (32) internal static options (constant) init ("patch_ring_zero"); dcl (fixed, null, addr, baseno, baseptr, ptr) builtin; /* */ datap = addr (data); /* get pointer to data area */ count = 0; call cu_$arg_ptr (1, tp, tc, code); /* pick up the first arg (name/number) */ if code = error_table_$noarg then do; mess: call com_err_ (0, WHOAMI, "Usage: ^a name/segno offset value1 ... valueN", WHOAMI); return; end; i = cv_oct_check_ (targ, code); /* get segment number */ if code ^= 0 then do; /* didn't give number */ segptr = null; /* if null we're still in trouble */ call ring0_get_$segptr ("", targ, segptr, code); /* so assume ring 0 name */ if segptr = null then do; call com_err_ (0, WHOAMI, "^a not found.", targ); return; end; i = fixed (baseno (segptr)); /* get segment number */ end; else segptr = baseptr (i); /* segment number given */ call cu_$arg_ptr (2, tp, tc, code); /* pick up second arg (first word to dump ) */ if code = error_table_$noarg then go to mess; first = cv_oct_ (targ); segptr = ptr (segptr, first); call ring0_get_$segptr ("", "dseg", dsp0, code); tsdwp = addr (dsp0 -> sdwa (i)); /* get a pointer to the SDW */ /* Now pick off the arguments */ i = 2; loop: i = i + 1; /* get next argument */ call cu_$arg_ptr (i, tp, tc, code); if code = error_table_$noarg then go to endarg; data1 (i-3) = cv_oct_ (targ); /* convert i'th arg */ go to loop; endarg: count = i - 3; if count = 0 then go to mess; call ring_zero_peek_ (segptr, datap, count, code); if code ^= 0 then do; call com_err_ (code, WHOAMI); return; end; do i = 0 to count-1; call ioa_ ("^6o ^w to ^w", first+i, data (i), data1 (i)); end; call command_query_$yes_no (ok_to_patch, 0, WHOAMI, "", "Type ""yes"" if patches are correct:"); if ^ok_to_patch then return; /* Now set priority so that syserr messages dont hang process */ processid = get_process_id_ (); call hphcs_$pxss_set_timax (processid, 1); /* Now check the access on the segment about to be patched */ data1p = addr (data1); call ring_zero_peek_ (tsdwp, addr (tsdw), size (tsdw), code); /* copy out the SDW */ if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot get SDW for ^o", binary (baseno (segptr))); return; end; if ^tsdw.write then do; tsdw.write = "1"b; force_sw = "1"b; call hphcs_$ring_0_patch (addr (tsdw), tsdwp, size (tsdw)); end; else force_sw = "0"b; /* indicates we don't have to restore SDW */ /* Now do the patches */ call hphcs_$ring_0_patch (data1p, segptr, count); /* Now reset access (in dseg) if necessary */ if force_sw then do; tsdw.write = "0"b; call hphcs_$ring_0_patch (addr (tsdw), tsdwp, size (tsdw)); end; if processid ^= (36)"1"b then call hphcs_$pxss_set_timax (processid, -1); return; %page; %include sdw; end;  read_early_dump_tape.pl1 01/26/85 1311.3r w 01/22/85 1300.8 138060 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ read_early_dump_tape: redt: proc () options (variable); /* Command level utility to read in the tape produced by the early dump feature of Multics initialization. The output of this program is a dump compatible with the standard analysis tools. Keith Loepere, November 1983. */ /* Modified November of 1984 by Allen Ball to fix bad reference to error_table_. */ /* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */ dcl Magic_number bit (36) aligned init ("654365234214"b3) options (constant) static; /* present in dump records to identify them */ dcl addr builtin; dcl addrel builtin; dcl arg char (arg_len) based (arg_ptr); dcl arg_len fixed bin (21); dcl arg_num fixed bin; dcl arg_ptr ptr; dcl attach_descr char (256); /* attach description for tape */ dcl bin builtin; dcl bit builtin; dcl character builtin; dcl cleanup condition; dcl clock builtin; dcl code fixed bin (35); dcl codeptr builtin; dcl com_err_ entry () options (variable); dcl current_dump_record fixed bin; /* record in dump (0 is first in 1st seg, 255 is 1st in 2nd...) */ dcl crash_dbr bit (72) aligned; /* from dump record */ dcl crash_system_type fixed bin; /* from dump record */ dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl date builtin; dcl date_str char (6); /* for building dump seg names */ dcl density char (4); /* current density we're trying */ dcl dimension builtin; dcl divide builtin; dcl dummy_ptr ptr; dcl dump_dir char (168); /* directory in which to place dump segs */ dcl dump_name char (12); /* base name of dump segs */ dcl dump_number fixed bin; /* used when naming dump */ dcl dump_seg_ptrs (0:63) ptr init ((64) null); /* ptrs to successive segs of dump */ dcl dump_segment fixed bin; /* current number (0 orig) of current seg we're writing */ dcl dump_segment_name char (32); /* name of current dump seg */ dcl 1 dump_record aligned, /* record read from tape */ 2 magic_number bit (36) aligned, /* as in Magic_number above */ 2 address fixed bin (26), /* starting address of page this is */ 2 dbr bit (72) aligned, /* at time of dump */ 2 system_type fixed bin, 2 pad fixed bin, 2 memory_record bit (1024 * 36); /* page of memory */ dcl ed_appending_simulation_$get_virtual entry (ptr, fixed bin (26), fixed bin (18), ptr, fixed bin (35)); dcl ed_appending_simulation_$init entry ((4) ptr, fixed bin); dcl ed_appending_simulation_$new_dbr entry (bit (72) aligned, fixed bin (15), fixed bin (35)); dcl ed_appending_simulation_$new_segment entry (fixed bin (15), ptr, fixed bin (35)); dcl entry char (32); /* from dump_dir expansion */ dcl error_count fixed bin; /* while reading current record */ dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$bad_density fixed bin (35) ext static; dcl error_table_$improper_data_format fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl good_records fixed bin; /* number read so far */ dcl hbound builtin; dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_ entry () options (variable); dcl iocb_ptr ptr; /* for tape */ dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl last_non_null_page fixed bin; /* used when writing seg pages to dump so we don't write trailing null pages */ dcl last_segnum fixed bin (15); /* last valid segnum in dump */ dcl ltrim builtin; dcl me char (20) static options (constant) init ("read_early_dump_tape"); dcl memory_block_num fixed bin; /* which memory page we're reading */ dcl memory_block_ptrs (4) ptr init ((4) null); /* forms a set of 4 128k areas */ dcl memory_blocks (0:127) bit (1024 * 36) based; /* a 128k area */ dcl mod builtin; dcl 1 my_dump aligned like dump; /* header for dump */ dcl my_page_buffer bit (36 * 1024) based (addr (dump_record.memory_record)); /* area for appending simulation reading of memory blocks */ dcl 1 my_seg_info aligned like seg_info;/* describe current segment being dumped */ dcl n_args fixed bin; dcl new_memory_block_num fixed bin; /* memory block alleged to be in current tape record */ dcl null builtin; dcl null_page_num fixed bin; /* loop counter */ dcl page_num fixed bin; /* loop counter */ dcl original_density char (4); /* command level specified initial density */ dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl rtrim builtin; dcl segnum fixed bin (15); /* loop counter */ dcl size builtin; dcl substr builtin; dcl tape_record_len fixed bin (21); /* for checking for valid records */ dcl tape_reel char (32); /* user name */ dcl time builtin; dcl time_str char (12); /* for building dump seg name */ dcl unspec builtin; dcl write bit (1) aligned; /* mount with ring */ %page; /* Process arguments */ call cu_$arg_count (n_args, code); if n_args = 0 | code ^= 0 then do; call com_err_ (code, me, "Usage is: read_early_dump_tape -dump {-dump_dir } {-density } {-ring}"); return; end; dump_number = -1; original_density = "1600"; tape_reel = ""; dump_dir = ">dumps"; write = "0"b; do arg_num = 1 to n_args; call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code); if arg_len > 0 then do; if substr (arg, 1, 1) ^= "-" then tape_reel = arg; else if arg = "-dump" then do; arg_num = arg_num + 1; if arg_num > n_args then do; call com_err_ (error_table_$noarg, me, "dump number"); return; end; call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code); dump_number = cv_dec_check_ (arg, code); if code ^= 0 | dump_number < 1 then do; call com_err_ (error_table_$bad_arg, me, "dump number ^a", arg); return; end; end; else if arg = "-ring" | arg = "-rg" then write = "1"b; else if arg = "-dump_dir" then do; arg_num = arg_num + 1; if arg_num > n_args then do; call com_err_ (error_table_$noarg, me, "dump dir"); return; end; call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code); call expand_pathname_ (arg, dump_dir, entry, code); if code ^= 0 then do; call com_err_ (code, me, "dump dir ^a", arg); return; end; dump_dir = rtrim (dump_dir) || ">" || entry; end; else if arg = "-density" | arg = "-den" then do; arg_num = arg_num + 1; if arg_num > n_args then do; call com_err_ (error_table_$noarg, me, "density"); return; end; call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code); if arg ^= "800" & arg ^= "1600" & arg ^= "6250" then do; call com_err_ (error_table_$bad_density, me, "^a", arg); return; end; original_density = arg; end; else do; call com_err_ (error_table_$bad_arg, me, "^a", arg); return; end; end; end; if tape_reel = "" then do; call com_err_ (0, me, "A tape reel name must be specified."); return; end; if dump_number < 1 then do; call com_err_ (0, me, "-dump must be specified"); return; end; %page; /* Read the dump tape into temp segments. */ on cleanup call clean_up; density = original_density; attach_descr = "tape_nstd_ " || rtrim (tape_reel) || " -den " || density; if write then attach_descr = rtrim (attach_descr) || " -write"; call iox_$attach_name ("redt_switch_", iocb_ptr, attach_descr, codeptr (read_early_dump_tape), code); if code ^= 0 then go to iox_error; call iox_$open (iocb_ptr, Sequential_input, "0"b, code); if code ^= 0 then do; iox_error: call com_err_ (code, me, "^a", attach_descr); go to abort; end; call get_temp_segments_ (me, memory_block_ptrs, code); if code ^= 0 then do; call com_err_ (code, me, "Getting temp segments."); go to abort; end; read: memory_block_num = -1; good_records = 0; do while (memory_block_num < 511); code = -1; do error_count = 1 to 16 while (code ^= 0); call iox_$read_record (iocb_ptr, addr (dump_record), 4 * size (dump_record), tape_record_len, code); end; if code ^= 0 then if density = original_density & good_records = 0 then do; /* try another density */ if original_density = "6250" then density = "1600"; else if original_density = "1600" then density = "6250"; else density = "1600"; call iox_$control (iocb_ptr, "rewind", null, code); call iox_$control (iocb_ptr, "d" || density, null, code); go to read; end; else do; call com_err_ (code, me, "More than 16 errors."); go to abort; end; else do; new_memory_block_num = divide (dump_record.address, 1024, 9); if tape_record_len ^= 4 * size (dump_record) | /* valid record? */ dump_record.magic_number ^= Magic_number | new_memory_block_num < memory_block_num | /* the one we expect? */ memory_block_num + 1 < new_memory_block_num then do; call com_err_ (error_table_$improper_data_format, me); go to abort; end; else do; good_records = good_records + 1; memory_block_num = new_memory_block_num; crash_dbr = dump_record.dbr; crash_system_type = dump_record.system_type; memory_block_ptrs (divide (memory_block_num, 128, 7) + 1) -> memory_blocks (mod (memory_block_num, 128)) = dump_record.memory_record; end; end; end; call clean_up_tape; %page; /* Now get the data into a regular format dump. */ dumpptr = addr (my_dump); seg_info_ptr = addr (my_seg_info); unspec (my_dump) = "0"b; call ed_appending_simulation_$init (memory_block_ptrs, crash_system_type); call ed_appending_simulation_$new_dbr (crash_dbr, last_segnum, code); if code ^= 0 then do; call com_err_ (code, me, "Bad dbr value in dump"); go to abort; end; dump.valid = "0"b; dump.erfno = dump_number; dump.words_dumped = 0; begin; dcl kludge_valid bit (36) aligned based (addr (dump.valid)); kludge_valid = "111111111111111111111111111111111111"b; /* azm expects it */ end; dump.time = clock; dump.num_segs = 0; dump.valid_355 = "0"b; dump.dumped_355s = "0"b; dump.time_355 = 0; dump.version = DUMP_VERSION_2; dump.dbr = crash_dbr; time_str = time; date_str = date; dump_name = substr (date_str, 3, 2) || substr (date_str, 5, 2) || substr (date_str, 1, 2) || "." || substr (time_str, 1, 4) || "."; dump_segment = 0; current_dump_record = 2; /* header */ dump_segment_name = dump_name || ltrim (character (dump_segment)) || "." || ltrim (character (dump_number)); call hcs_$make_seg (dump_dir, dump_segment_name, "", 10, dump_seg_ptrs (dump_segment), code); if dump_seg_ptrs (dump_segment) = null then do; call com_err_ (code, me, dump_segment_name); go to abort; end; do segnum = 0 to last_segnum; call ed_appending_simulation_$new_segment (segnum, seg_info_ptr, code); if code ^= 0 then go to next_seg; if dump.num_segs = dimension (dump.segs, 1) then do; call ioa_ ("Segment array overflow."); go to end_dump; end; dump.num_segs = dump.num_segs + 1; dump.segs.segno (dump.num_segs) = bit (bin (segnum, 18), 18); dump.segs.length (dump.num_segs) = "0"b; /* read pages from simulated segment, writing to dump. Don't write null pages. If we do find a non-null page, write it and any null pages we didn't write before. */ last_non_null_page = -1; do page_num = 0 to divide (seg_info.size + 1023, 1024, 8) - 1; call ed_appending_simulation_$get_virtual (seg_info_ptr, page_num * 1024, 1024, addr (my_page_buffer), code); if my_page_buffer ^= "0"b then do; /* output non-null page and all null pages up to it */ do null_page_num = last_non_null_page + 1 to page_num - 1; dummy_ptr = get_put (); end; get_put () -> my_page_buffer = my_page_buffer; last_non_null_page = page_num; end; end; dump.segs.length (dump.num_segs) = bit (bin ((last_non_null_page + 1) * 16, 18), 18); dump.words_dumped = dump.words_dumped + (last_non_null_page + 1) * 1024; next_seg: end; /* Write out header */ end_dump: dump_seg_ptrs (0) -> dump = my_dump; call hcs_$set_bc_seg (dump_seg_ptrs (dump_segment), (mod (current_dump_record - 1, 255) + 1) * 1024 * 36, code); abort: call clean_up; return; %page; clean_up: proc; call release_temp_segments_ (me, memory_block_ptrs, code); do dump_segment = 0 to hbound (dump_seg_ptrs, 1); if dump_seg_ptrs (dump_segment) ^= null then call hcs_$terminate_noname (dump_seg_ptrs (dump_segment), code); end; clean_up_tape: entry; call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); return; end; %page; get_put: proc () returns (ptr); /* add page to dump (returns ptr to page to place data) */ if mod (current_dump_record, 255) = 0 then do; call hcs_$set_bc_seg (dump_seg_ptrs (dump_segment), 255 * 1024 * 36, code); dump_segment = dump_segment + 1; dump_segment_name = dump_name || ltrim (character (dump_segment)) || "." || ltrim (character (dump_number)); call hcs_$make_seg (dump_dir, dump_segment_name, "", 10, dump_seg_ptrs (dump_segment), code); if dump_seg_ptrs (dump_segment) = null then do; call com_err_ (code, me, dump_segment_name); go to abort; end; end; current_dump_record = current_dump_record + 1; return (addrel (dump_seg_ptrs (dump_segment), mod (current_dump_record - 1, 255) * 1024)); end; %page; %include bce_appending_seg_info; %page; %include bos_dump; %page; %include iox_modes; end;  save_history_registers.pl1 11/15/82 1825.9rew 11/15/82 1505.7 33867 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ save_history_registers: proc; /* save_history_registers - command to set, reset or display state of the per-process switch, pds$save_history_regs or the per-system switch wired_hardcore_data$save_hregs, (with the -priv control arg). When signalable faults ocurr, history registers are either stored or not stored in the signallers stack frame (return_to_ring_0_) depending on the state of both of these switches. If the per-system switch is on, then all processes will store history registers in the signallers stack frame. If the per-system switch is off but a users per-process switch is on, then only that users process will store history registers. The default state of both the per-process and the per-system switchs is "0"b or off. Written 9/16/80 by J. A. Bush for the DPS8/70M CPU */ dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl (com_err_, ioa_) entry options (variable); dcl hcs_$history_regs_set entry (bit (1) aligned); dcl hcs_$history_regs_get entry (bit (1) aligned); dcl hphcs_$history_regs_get entry (bit (1) aligned); dcl hphcs_$history_regs_set entry (bit (1) aligned); dcl ap ptr; dcl (al, i) fixed bin; dcl code fixed bin (35); dcl (desired_state, old_state, priv_sw, print_sw, set_sw) bit (1) aligned; dcl arg char (al) based (ap); dcl pname char (22) int static options (constant) init ("save_history_registers"); dcl error_table_$bad_arg fixed bin (35) ext; priv_sw, print_sw, set_sw = "0"b; call cu_$arg_ptr (1, ap, al, code); /* get arg * */ if code ^= 0 then do; usage: call com_err_ (code, pname, "Usage: ^a {on | off} {-priv} {-print (-pr)}", pname); return; end; do i = 2 by 1 while (code = 0); if arg = "-priv" then priv_sw = "1"b; /* user wants per-system history regs */ else if arg = "-print" | arg = "-pr" then print_sw = "1"b; /* user wants old state of switch */ else if arg = "on" then /* user wants history regs turned on */ set_sw, desired_state = "1"b; else if arg = "off" then do; /* user wants saving of hregs turned off */ desired_state = "0"b; set_sw = "1"b; end; else do; code = error_table_$bad_arg; go to usage; /* tell user what is valid */ end; call cu_$arg_ptr (i, ap, al, code); /* get next arg */ end; if priv_sw then do; /* if dealing with per-system history reg saving */ if print_sw then do; /* if user wants to know old state */ call hphcs_$history_regs_get (old_state); /* get current setting */ call ioa_ ("per-system history register saving ^[was previously^;is^] turned ^[on^;off^]", set_sw, old_state); end; if set_sw then /* if user wants to change state */ call hphcs_$history_regs_set (desired_state); end; else do; /* dealing with per-process history regs */ if print_sw then do; /* if user wants to know old state */ call hcs_$history_regs_get (old_state); /* get current setting */ call ioa_ ("per-process history register saving ^[was previously^;is^] turned ^[on^;off^]", set_sw, old_state); end; if set_sw then /* if user wants to change state */ call hcs_$history_regs_set (desired_state); end; end save_history_registers; 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