bce_component_to_wordnum_.pl1 11/11/89 1134.9r w 11/11/89 0826.6 25344 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ bce_component_to_wordnum_: proc (p_segnum, p_segname, p_component, return_segnum, return_wordnum, p_code); /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ /* Program to take a segment number and an entry name which will return a word number relative to the beginning of the segment. */ /* Coded June of 1984 by Allen Ball. */ dcl bce_get_defptr_ entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl code fixed bin (35); dcl 1 component_acc aligned, 2 num_chars fixed bin (9) unsigned unaligned, 2 string char (32) unaligned; dcl crash_definitions_$ external; dcl crash_lot$ external; dcl error_table_$no_ext_sym external; dcl p_code fixed bin (35) parameter; dcl p_component char (32) parameter; dcl p_segname char (32); dcl p_segnum fixed bin (15) parameter; dcl return_segnum fixed bin (15) parameter; dcl return_wordnum fixed bin (26) parameter; dcl 1 segname_acc aligned like component_acc; dcl (addr, addrel, length, rtrim, segno, substr, unspec, wordno) builtin; code = 0; p_code = 0; unspec (component_acc) = "0"b; /* Set up acc strings for get_defptr_ */ component_acc.num_chars = length (rtrim (p_component)); substr (component_acc.string, 1, component_acc.num_chars) = rtrim (p_component); unspec (segname_acc) = "0"b; segname_acc.num_chars = length (rtrim (p_segname)); substr (segname_acc.string, 1, segname_acc.num_chars) = rtrim (p_segname); lotp = addr (crash_lot$); definitions_ptr = addr (crash_definitions_$); def_header_ptr = addrel (definitions_ptr, definitions.dot (p_segnum).offset); call bce_get_defptr_ (def_header_ptr, addr (segname_acc), addr (component_acc), def_ptr, code); if code ^= 0 then do; p_code = code; return; end; if definition.class = CLASS_TEXT then do; return_segnum = p_segnum; return_wordnum = definition.thing_relp; end; else if definition.class = CLASS_LINKAGE then do; return_segnum = segno (lot.lp (p_segnum)); return_wordnum = wordno (lot.lp (p_segnum)) + definition.thing_relp; end; /* Otherwise class is equal to CLASS_SYMBOL, CLASS_SEGNAME, or CLASS_STATIC and we are not interested in it. */ else p_code = error_table_$no_ext_sym; return; %include definition_dcls; %include hc_definitions_seg; %include lot; end /* bce_component_to_wordnum */;  bce_display_instruction_.pl1 11/11/89 1134.9r w 11/11/89 0826.6 134037 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ bce_display_instruction_ : proc (P_data_ptr, P_count, P_label); /* prints an instruction using no more than P_count words starting at P_data_ptr with label P_label. Update P_count to how many words dumped. an instruction may be several words long James R. Davis 20 May 79 Modified 21 Sept 79 to print address and raw words, too. JRD Stolen from print_instructions_ by Keith Loepere. It differs from print_instructions_ in that: 1) It doesn't take a i/o switch argument. 2) It needs a label for the display (the wordno of the pointer supplied is meaningless). 3) It displays only one instruction at a time. FEATURES that it would be nice to put in someday: decoding the special tags (used by puls1, puls2 s9bd, s6bd, s4bd, sbd,stba,stbq,stca and stcq) showing either the address of the operand (for a tra, or pl1_operators_ ref) or i$ the contents of the word addressed - one or two words, depending */ /* Fixed not to print more than P_count words despite multi-word instructions 09/01/83 S. Herbst */ dcl P_data_ptr ptr parameter; /* input: to probe_info structure */ dcl P_count fixed bin parameter; /* input/output: number of instructions to print */ dcl P_label fixed bin (26) parameter; /* label (- => none) */ /* the following variables are used globally throughout - but not altered */ dcl ip ptr; /* to current instruction's first word */ dcl op_index fixed bin; /* the op code, an index into instruction info tables */ dcl op_code char (6) aligned; /* mnemonic name of op_index */ dcl number_of_words fixed bin; /* number of words in current instruction */ dcl COLUMN_SPACING fixed bin internal static options (constant) init (8); /* bewteen op_code and address */ dcl (addrel, char, divide, hbound, lbound, min) builtin; dcl (ioa_$rsnnl, ioa_, ioa_$nnl) entry options (variable); dcl 1 instr_pr aligned based (ip), 2 address unal, 3 pr fixed bin (3) unsigned unal, 3 offset fixed bin (14) unal, 2 opcode fixed bin (10) unsigned unal, 2 inhibit bit (1) unal, 2 use_pr bit (1) unal, 2 tag fixed bin (6) unsigned unal; dcl 1 instr aligned based (ip), 2 address unal, 3 offset fixed bin (17), 2 opcode fixed bin (10) unsigned unal, 2 inhibit bit (1) unal, 2 use_pr bit (1) unal, 2 tag fixed bin (6) unsigned unal; %include op_mnemonic_format; ip = P_data_ptr; op_index = ip -> instr.opcode; op_code = op_mnemonic_$op_mnemonic (op_index).opcode; number_of_words = op_mnemonic_$op_mnemonic (op_index).num_words; if number_of_words > 1 /* must be EIS */ then call disassemble_eis; else if is_repeat_instr (op_code) then call disassemble_repeat; else call disassemble_normal; P_count = number_of_words; return; disassemble_normal: proc; call print_addr_and_raw (ip, 0); call ioa_ (" ^a^vt^a^[,^a^]", op_code, COLUMN_SPACING, address_field (ip, (ip -> instr.use_pr)), instr.tag ^= 0, tag_field ((instr.tag))); /* add code to print what is pointed to */ end disassemble_normal; disassemble_repeat: proc ; call print_addr_and_raw (ip, 0); call ioa_ (" ^a^[a^]^[b^]^[^vt^d^;x^vt^s^],^d^[,tze^]^,tmi^]^[,tpl^]^[,trc^]^[tnc^]", op_code, ip -> repeat_instr.a, ip -> repeat_instr.b, ip -> repeat_instr.use_tally, COLUMN_SPACING, ip -> repeat_instr.tally, ip -> repeat_instr.delta, ip -> repeat_instr.zero_on, ip -> repeat_instr.zero_off, ip -> repeat_instr.neg_on, ip -> repeat_instr.neg_off, ip -> repeat_instr.carry_on, /* CSNY ? */ ip -> repeat_instr.carry_off); dcl 1 repeat_instr aligned based, 2 tally fixed bin (8) unsigned unal, 2 a bit (1) unal, 2 b bit (1) unal, 2 use_tally bit (1) unal, 2 term_conditions unal, 3 zero_on bit (1) unal, 3 zero_off bit (1) unal, 3 neg_on bit (1) unal, 3 neg_off bit (1) unal, 3 carry_on bit (1) unal, 3 carry_off bit (1) unal, 2 process_overflow bit (1) unal, 2 opcode fixed bin (10) unsigned unal, 2 pad bit (2) unal, 2 delta fixed bin (6) unsigned unal; end disassemble_repeat; disassemble_eis: proc; dcl data_type fixed bin; dcl ndesc fixed bin; /* how many descriptors it has */ dcl (ALPHA_TYPE init (0), BIT_TYPE init (1), OTHER_TYPE init (2)) fixed bin internal static options (constant); dcl dp ptr; /* to a descriptor */ dcl descx fixed bin; /* index as we step over descriptors */ dcl 1 eis_instr_all_descs aligned based (ip), 2 pad1 bit (2) unal, 2 mf3 unal like mod_factor, 2 enablefault bit (1) unal, 2 pad2 bit (1) unal, 2 mf2 unal like mod_factor, 2 pad3 bit (11) unal, 2 mf1 unal like mod_factor; dcl 1 mod_factor aligned based, 2 ext_base bit (1) unal, /* there is a pr number in address */ 2 length_in_reg bit (1) unal, /* the length of the operand is in a reg */ 2 indirect_descriptor bit (1) unal, /* the descriptor is an indirect ptr */ 2 tag fixed bin (4) unsigned unal; dcl 1 eis_args_info (3) aligned like mod_factor; ndesc = op_mnemonic_$op_mnemonic (op_index).num_desc; data_type = op_mnemonic_$op_mnemonic (op_index).dtype; if data_type > OTHER_TYPE then data_type = OTHER_TYPE; eis_args_info (1) = eis_instr_all_descs.mf1; eis_args_info (2) = eis_instr_all_descs.mf2; eis_args_info (3) = eis_instr_all_descs.mf3; call print_addr_and_raw (ip, 0); call print_instr_word; number_of_words = min (number_of_words, P_count); dp = ip; do descx = 1 to number_of_words -1; dp = addrel (dp, 1); call print_addr_and_raw (dp, descx); /* CASE on what kind of descriptor we have */ if descx > ndesc /* it is an arg, not a desc */ then call print_ind_desc (dp, eis_args_info (descx)); else if eis_args_info (descx).indirect_descriptor then call print_ind_desc (dp, eis_args_info (descx)); else if desc_is_obscure (op_code, descx) /* abnormal type, such as MOP ptr of mvne */ then call print_obscure_desc (dp, eis_args_info (descx)); else if data_type = ALPHA_TYPE then call print_alpha_desc (dp, eis_args_info (descx)); else if data_type = BIT_TYPE then call print_bit_desc (dp, eis_args_info (descx)); else call print_numeric_desc (dp, eis_args_info (descx)); end; /* of loop over all descriptors */ print_instr_word: proc; dcl descx fixed bin; dcl need_comma bit (1) aligned; dcl line char (256) varying; /* holds output as built */ dcl HT char (1) internal static options (constant) init (" "); dcl 1 eis_alpha_fill based (ip), 2 field bit (9) unal, 2 pad bit (27) unal; dcl 1 eis_bit_fill based (ip), 2 field bit (1) unal, 2 pad bit (4) unal, 2 bolr fixed bin (4) unsigned unal, 2 pad1 bit (27) unal; dcl 1 eis_numeric_fill aligned based (dp), 2 pad bit (10) unal, 2 round bit (1) unal, 2 pad2 bit (25) unal; dcl bool_word (0:15) char (6) internal static options (constant) init ("clear", "and", "02", "03", "04", "05", "xor", "or", "10", "11", "12", "13", "invert", "15", "nand", "set"); line = op_code; line = line || HT; do descx = 1 to ndesc; line = line || "("; need_comma = "0"b; if eis_args_info (descx).ext_base then call add_option ("pr"); if eis_args_info (descx).length_in_reg then call add_option ("rl"); if eis_args_info (descx).indirect_descriptor then call add_option ("id"); if eis_args_info (descx).tag ^= 0 then call add_option (tag_field ((eis_args_info (descx).tag))); line = line || ")"; if descx < ndesc /* more to come */ then line = line || ","; end; /* of loop over all MFs */ if eis_instr_all_descs.enablefault then line = line || ",enablefault"; if data_type = ALPHA_TYPE then do; if has_fill (op_code) then do; line = line || ",fill("; line = line || octalize (eis_alpha_fill.field); line = line || ")"; end; else if has_mask (op_code) then do; line = line || ",mask("; line = line || octalize (eis_alpha_fill.field); line = line || ")"; end; /* mask */ end; /* ALPHA type */ else if data_type = BIT_TYPE then do; line = line || ", fill ("; line = line || char (eis_bit_fill.field); line = line || ")"; if has_boolean (op_code) then do; line = line || ", bool ("; line = line || bool_word (eis_bit_fill.bolr); line = line || ")"; end; /* bolr hacking */ end; /* BIT type */ else do; if eis_numeric_fill.round then line = line || ", round"; end; /* NUMERIC */ call ioa_ (" ^a", line); return; add_option: proc (c2); dcl c2 char (2) aligned parameter; if need_comma /* we have previously written in this MF, need a separator */ then line = line || ","; need_comma = "1"b; line = line || c2; end add_option; octalize: proc (b9) returns (char (3) aligned); dcl c3 char (3) aligned; dcl b9 bit (9) parameter; call ioa_$rsnnl ("^.3b", c3, (0), b9); return (c3); end octalize; end print_instr_word; /* here are internal procedures to print the various kinds of descriptors- obscure (which isn't nearly as clever as it ought to be) indirect alphanumeric bit numeric */ print_obscure_desc: proc (descp, mf); dcl descp ptr parameter; dcl 1 mf aligned parameter like mod_factor; call ioa_ (" too obscure a descriptor too decode"); end print_obscure_desc; print_ind_desc: proc (descp, mf); dcl descp ptr aligned parameter; dcl 1 mf aligned parameter like mod_factor; call ioa_ (" arg^vt^a^[,^a^]", COLUMN_SPACING, address_field (descp, (mf.ext_base)), descp -> instr.tag ^= 0, tag_field ((descp -> instr.tag))); end print_ind_desc; print_alpha_desc: proc (descp, mf); dcl descp ptr aligned parameter; dcl 1 mf aligned parameter like mod_factor; dcl alpha_types (0:3) char (1) internal static options (constant) init ("9", "6", "4", "?"); dcl NINE_BIT fixed bin internal static options (constant) init (0); dcl 1 alpha_desc aligned based (descp), 2 y bit (18) unal, 2 char_no fixed bin (3) unsigned unal, 2 type_code fixed bin (2) unsigned unal, 2 pad bit (1) unal, 2 length fixed bin (12) unsigned unal; call ioa_ (" desc^aa^vt^a(^[^d^s^;^s^d^]),^[^a^s^;^s^d^]", alpha_types (type_code), COLUMN_SPACING, address_field (descp, (mf.ext_base)), alpha_desc.type_code = NINE_BIT, divide (char_no, 2, 17, 0), char_no, mf.length_in_reg, tag_field ((alpha_desc.length)), alpha_desc.length); end print_alpha_desc; print_bit_desc: proc (descp, mf); dcl descp ptr aligned parameter; dcl 1 mf aligned parameter like mod_factor; dcl 1 bit_desc aligned based (descp), 2 y bit (18) unal, 2 char_no fixed bin (2) unsigned unal, 2 bit_no fixed bin (4) unsigned unal, 2 length fixed bin (12) unsigned unal; call ioa_ (" descb^vt^a(^d),^[^a^s^;^s^d^]", COLUMN_SPACING, address_field (descp, (mf.ext_base)), char_no * 9 + bit_no, mf.length_in_reg, tag_field ((bit_desc.length)), bit_desc.length); end print_bit_desc; print_numeric_desc: proc (descp, mf); dcl descp ptr aligned parameter; /* aren't you getting bored? */ dcl 1 mf aligned parameter like mod_factor; dcl sign_name (0:3) char (2) aligned internal static options (constant) init ("fl", "ls", "ts", "ns"); dcl 1 numeric_desc aligned based (descp), 2 y bit (18) unal, 2 char_no fixed bin (3) unsigned unal, 2 type4 bit (1) unal, 2 sign_type fixed bin (2) unsigned unal, 2 scale_factor fixed bin (5) unal, 2 length fixed bin (6) unsigned unal; call ioa_ (" desc^[4^;9^]^a^vt^a(^[^d^s^;^s^d^]),^[^a^s^;^s^d^]^[,^d^]", numeric_desc.type4, /* which type ? */ sign_name (numeric_desc.sign_type), COLUMN_SPACING, address_field (descp, (mf.ext_base)), type4, numeric_desc.length, divide (numeric_desc.length, 2, 17, 0), mf.length_in_reg, tag_field ((numeric_desc.length)), numeric_desc.length, scale_factor ^= 0, scale_factor); end print_numeric_desc; desc_is_obscure: proc (op_name, desc_no) returns (bit (1) aligned); /* for certain ops, one of the descriptors will not be of the expected type */ dcl op_name char (6) aligned parameter; dcl desc_no fixed bin parameter; /* input, which desc */ return ( (op_name = "btd" & desc_no = 1) | (op_name = "dtb" & desc_no = 2) | (op_name = "mvne" & desc_no = 2) ); end desc_is_obscure; end disassemble_eis; /* miscellaneous useful things */ print_addr_and_raw: proc (p, label_offset); dcl label_offset fixed bin parameter; dcl p ptr parameter; dcl based_word bit (36) aligned based (p); call ioa_$nnl ("^[^9o ^;^s^]^w", P_label >= 0, P_label + label_offset, based_word); end print_addr_and_raw; address_field: proc (p, use_pr) returns (char (10) aligned); dcl p ptr aligned parameter; /* to instruction */ dcl use_pr bit (1) aligned parameter; /* which format is it ? */ dcl rs char (9) aligned; call ioa_$rsnnl ("^[pr^d|^d^s^;^s^s^d^]", rs, (0), use_pr, p -> instr_pr.address.pr, p -> instr_pr.address.offset, p -> instr.address.offset); return (rs); end address_field; tag_field: proc (tag) returns (char (3) aligned); /* this proc exists to isolate references to the modifier data base - hope to make it part of op_mnemonic some day */ dcl tag fixed bin parameter; if tag < lbound (modifier, 1) | tag > hbound (modifier, 1) then return ("bad"); else return (modifier (tag)); end tag_field; /* predicates on instruction types */ is_repeat_instr: proc (op_name) returns (bit (1) aligned); dcl op_name char (6) aligned parameter; return (op_name = "rpd" | op_name = "rpl" | op_name = "rpt"); has_fill: entry (op_name) returns (bit (1) aligned); return (op_name = "cmpc" | op_name = "mlr" | op_name = "mvt"); has_boolean: entry (op_name) returns (bit (1) aligned); return (op_name = "csl" | op_name = "csr" | op_name = "sztl" | op_name = "sztr"); has_mask: entry (op_name) returns (bit (1) aligned); return (op_name = "scm"); end; /* is_XXXXX_instr */ end bce_display_instruction_;  bce_display_scu_.pl1 11/11/89 1134.9r w 11/11/89 0826.6 96885 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ bce_display_scu_: proc (scup, a_offset, lg_sw); /* Modification History - prtscu_ Initially coded by J. A. Bush - Dec 1975 Modified May 1977 by J. A. Bush to be intellegent about group 7 faults and not print out tsr|ca Modified Aug 1980 by R.L. Coppola to be more intelligent about IOM channels greater than 37 (octal). Also added display of the CT Hold reg in CU status. Stolen for bce use, Keith Loepere December 1983. */ dcl scup ptr; /* pointer to SCU Data */ dcl a_offset fixed bin (26); /* relative offset of SCU data */ dcl lg_sw bit (1); /* long format switch "1"b => long */ dcl (strp, byptr, refptr) ptr; dcl (lnpos, flt_lng, inst6, i, j) fixed bin; dcl reoffset fixed bin (26); dcl code fixed bin (35); dcl w (0 : 7) fixed bin based; dcl flt_ln char (100); dcl flt_bf char (24) varying; dcl iocbp ptr; dcl (length, fixed, addr, addrel, baseptr, substr, null, hbound, lbound) builtin; dcl (tsrpr, on_line) bit (1); dcl cvbinbuf char (12); dcl fltdtab (0:35) bit (1) based (byptr) unaligned; dcl cpul (0 : 7) char (1) int static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl at_by_wd char (2); dcl (ioa_, ioa_$rsnnl) entry options (variable); dcl bce_display_instruction_ entry (ptr, fixed bin, fixed bin (26)); dcl bce_segptr_to_name_ entry (ptr) returns (char (*)); dcl cv_bin_$oct entry (fixed bin, char (12)); dcl 1 scud based (scup) aligned, 2 wd0 unaligned, /* :: */ 3 prr bit (3), /* Procedure Ring Register */ 3 psr bit (15), /* Procedure Segment Register */ 3 apust bit (18), /* APU Status */ 2 wd1 unaligned, /* :: */ 3 fid bit (20), /* fault/interrupt data */ 3 ill_act_lns bit (4), /* Illegal Action Lines */ 3 ill_act_chan bit (3), /* Illegal Action Channel (Port) */ 3 con_chan bit (3), /* Connect Channel (Port) */ 3 fi bit (6), /* Fault/Interrupt Vector Address */ 2 wd2 unaligned, /* :: */ 3 trr bit (3), /* Temporary Ring Register */ 3 tsr bit (15), /* Temporary Segment Register */ 3 mbz bit (9), /* :: */ 3 cpu bit (3), /* Processor Number */ 3 tmd bit (6), /* :: */ 2 wd3 fixed bin (35), /* :: */ 2 wd4 unaligned, /* :: */ 3 ict bit (18), /* Instruction Counter */ 3 ir bit (18), /* Indicator Register */ 2 wd5 unaligned, /* :: */ 3 ca bit (18), /* Computed Address */ 3 cus bit (12), /* CU Status */ 3 ct_hold bit (6), /* remember mod field */ 2 wd6 fixed bin (35), /* Even Instruction */ 2 wd7 fixed bin (35); /* Odd Instruction */ dcl ill_act (0:15) char (37) varying int static options (constant) init ("...", "Unasigned", "Non Existant Address", "Fault on Condition", "Unassigned", "Data Parity (Store -> SCU)", "Data Parity in Store", "Data Parity (Store -> SCU & in Store)", "Not Control", "Port Not Enabled", "Illegal Command", "Store Not Ready", "ZAC Parity (Processor -> SCU)", "Data Parity (Processor -> SCU)", "ZAC parity (SCU -> Store)", "Data Parity (SCU -> Store)"); dcl indrs (18:31) char (4) varying int static options (constant) init ("zero", "neg", "cary", "ovfl", "eovf", "eufl", "oflm", "tro", "par", "parm", "^bar", "tru", "mif", "abs"); dcl APU (18:32) char (6) varying int static options (constant) init ("priv", "xsf", "sdwamm", "sd-on", "ptwamm", "pt-on", "pi-ap", "dsptw", "sdwnp", "sdwp", "ptw", "ptw2", "fap", "fanp", "fabs"); dcl CU (18:29) char (3) varying int static options (constant) init ("rf", "rpt", "rd", "rl", "pot", "pon", "xde", "xdo", "itp", "rfi", "its", "fif"); dcl g1and7flts (5) bit (6) int static options (constant) unaligned init ("01"b3, "11"b3, "21"b3, "31"b3, "37"b3); dcl grp1flt (0:19) char (24) varying int static options (constant) init ("Illegal Ring Order", "Not in Execute Bracket", "Execute Bit off", "Not In Read Bracket", "Read Bit Off", "Not In Write Bracket", "Write Bit Off", "Not A Gate", "Not In Call Bracket", "Outward Call", "Bad Outward Call", "Inward Return", "Cross Ring Transfer", "Ring Alarm", "Associative Memory", "Out of Segment Bounds", "Processor Parity Upper", "Processor Parity Lower", "SC To Proc. Seq. Error 1", "SC To Proc. Seq. Error 2"); dcl grp2flt (0:6) char (24) varying int static options (constant) init ("Illegal Segment Number", "Illegal Op Code", "Illegal Address & Mod", "Illegal Slave Procedure", "Illegal Procedure", "Non Existant Address", "Out Of Bounds"); dcl flt_int_typ (0:63) char (24) varying int static options (constant) init ("...", "Shutdown", "...", "Store", "Bulk Store 0 Term", "MME 1", "...", "Fault Tag 1", "IOM 0 Overhead", "Timer Runout", "IOM 1 Overhead", "Command", "IOM 2 Overhead", "Derail", "IOM 3 Overhead", "Lockup", "IOM 0 Terminate Ch 40-77", "Connect", "IOM 1 Terminate Ch 40-77", "Parity", "Bulk Store 1 Term", "Illegal Procedure", "...", "Op Not Complete", "IOM 0 Terminate", "Startup", "IOM 1 Terminate", "Overflow", "IOM 2 Terminate", "Divide Check", "IOM 3 Terminate", "Execute", "IOM 0 Marker Ch 40-77", "(DF0) Segment", "IOM 1 Marker Ch 40-77", "(DF1) Page", "...", "Directed Fault 2", "...", "Directed Fault 3", "IOM 0 Marker", "Access Violation", "IOM 1 Marker", "MME 2", "IOM 2 Marker", "MME 3", "IOM 3 Marker", "MME 4", "...", "(FT2) Linkage", "...", "Fault Tag 3", "...", "...", "...", "...", "IOM 0 Special", "...", "IOM 1 Special", "...", "IOM 2 Special", "...", "IOM 3 Special", "Trouble"); dcl TAG_ptr ptr; /* pointer to tag table */ dcl tag_prt bit (1) init ("0"b); dcl tag_ char (4) init (""); dcl TAG_table (8) char (40) init ( /* tag table */ " au qu du ic al ql dl ", "x0 x1 x2 x3 x4 x5 x6 x7 ", "n* aau* aqu* ailtg ic* aal* aql* ailtg ", "0* a1* a2* a3* a4* a5* a6* a7* a", "fi itp iltg its sd scr f2 f3 ", "ci i sc ad di dic aid idc a", "*n *au *qu iltg *ic *al *ql iltg ", "*0 *1 *2 *3 *4 *5 *6 *7 "); dcl 1 TAG (64) based (TAG_ptr), 2 code char (4) unal, 2 pad bit (8) unal, 2 chain bit (1); /* */ reoffset = a_offset; /* copy relative offset */ if scud.wd0.psr = "0"b then if scud.wd2.tsr = "0"b then do; call ioa_ ("No SCU data stored"); return; end; inst6 = reoffset + 6; if lg_sw then /* user wants octal dump too */ call ioa_ ("^6o^-^4(^w ^)^/^-^4(^w ^)^/", reoffset, scup -> w); flt_ln, flt_bf = ""; tsrpr = "0"b; /* assume for now don't print tsr */ flt_bf = flt_int_typ (fixed (scud.wd1.fi, 6)); if substr (flt_bf, 1, 3) = "..." then call ioa_ ("Fault/Interrupt (^o), Undefined", fixed (scud.wd1.fi, 6)); else do; flt_lng = length (flt_int_typ (fixed (scud.wd1.fi, 6))); substr (flt_ln, 1, flt_lng) = substr (flt_bf, 1, flt_lng); byptr = addrel (scup, 1); if fltdtab (35) = "1"b then do; substr (flt_ln, flt_lng + 2, 5) = "Fault"; lnpos = flt_lng + 8; do i = 1 to hbound (g1and7flts, 1); /* If grp 1 or 7 faults, don't print out tsr|ca */ if scud.wd1.fi = g1and7flts (i) then tsrpr = "1"b; end; end; else do; substr (flt_ln, flt_lng + 2, 9) = "Interrupt"; lnpos = flt_lng + 12; tsrpr = "1"b; /* don't print out tsr|ca for interrupts */ end; flt_lng = fixed (scud.wd1.fi, 6); call cv_bin_$oct (flt_lng, cvbinbuf); substr (flt_ln, lnpos, 4) = "(" || substr (cvbinbuf, 11, 2) || ")"; lnpos = lnpos + 4; j = lnpos; do i = 0 to hbound (grp1flt, 1); if fltdtab (i) then do; if substr (flt_ln, 1, 5) = "Store"|substr (flt_ln, 1, 12) = "Illegal Proc" then if i <= 6 then call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp2flt (i)); else; else call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp1flt (i)); end; end; call ioa_ ("^a", flt_ln); end; if ill_act_lns ^= "0"b then do; /* display illegal action lines if present */ call ioa_ ("Illegal Action Code (^o) - ^a", fixed (scud.wd1.ill_act_lns, 4), ill_act (fixed (scud.wd1.ill_act_lns, 4))); end; if tsrpr then at_by_wd = "At"; /* if not printing tsr */ else at_by_wd = "By"; byptr = addrel (baseptr (fixed (scud.wd0.psr, 18)), fixed (scud.wd4.ict, 18)); if ^tsrpr then refptr = addrel (baseptr (fixed (scud.wd2.tsr, 18)), fixed (scud.wd5.ca, 18)); call ioa_ ("^a: ^p ^a", at_by_wd, byptr, bce_segptr_to_name_ (byptr)); if ^tsrpr then /* if we want to print out tsr|ca */ call ioa_ ("Referencing: ^p ^a", refptr, bce_segptr_to_name_ (refptr)); call ioa_ ("On: cpu ^a (#^o)", cpul (fixed (scud.wd2.cpu, 3)), fixed (scud.wd2.cpu, 3)); flt_ln = ""; byptr = addr (scud.wd4); /* display Indicator register if any bits present */ do i = lbound (indrs, 1) to hbound (indrs, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, indrs (i)); end; if flt_ln ^= "" then do; substr (flt_ln, j, 1) = " "; call ioa_ ("Indicators: ^a", flt_ln); flt_ln = ""; end; byptr = addr (scud.wd0); /* display interpreted APU status if any bits present */ do i = lbound (APU, 1) to hbound (APU, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, APU (i)); end; if flt_ln ^= "" then do; substr (flt_ln, j, 1) = " "; call ioa_ ("APU Status: ^a", flt_ln); flt_ln = ""; end; byptr = addr (scud.wd5); /* display interprted CU status if any bits present */ do i = lbound (CU, 1) to hbound (CU, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, CU (i)); end; TAG_ptr = addr (TAG_table); i = fixed (wd5.ct_hold); if i ^= 0 then do; tag_ = TAG.code (i+1); tag_prt = "1"b; end; if (flt_ln ^= "") | (tag_ ^= "") then do; substr (flt_ln, j, 1) = " "; call ioa_ ("CU Status: ^a ^[^/CT Hold: ^a^]", flt_ln, tag_prt, tag_); end; call ioa_ ("Instructions: "); /* display Instructions (words 6 & 7) */ call bce_display_instruction_ (addr (scud.wd6), (1), reoffset + 6); call bce_display_instruction_ (addr (scud.wd7), (1), reoffset + 7); /* */ end bce_display_scu_;  bce_get_defptr_.pl1 11/11/89 1134.9r w 11/11/89 0826.6 49077 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ bce_get_defptr_: proc (p_def_header_ptr, segname_acc_ptr, symbol_acc_ptr, returned_def_ptr, code); /* 06/05/84 Program by A.Ball to replace get_defptr_.alm for use later in bce_probe. */ /* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */ dcl addrel builtin; dcl code fixed bin (35) parameter; /* Standard error code. */ dcl counter fixed bin; dcl 1 def_name like acc_string based (def_name_ptr); /* Definition name we are looking for. */ dcl def_name_ptr ptr; dcl 1 def_segname_acc aligned like acc_string based (def_segname_acc_ptr); dcl def_segname_acc_ptr ptr; dcl duplicate_table_index fixed bin; dcl error_table_$no_ext_sym external fixed bin (35); /* Error code "External symbol not found." */ dcl hash_index fixed bin; dcl mod builtin; dcl null builtin; dcl out_of_bounds condition; dcl p_def_header_ptr ptr parameter; /* Pointer to definition section. */ dcl returned_def_ptr ptr parameter; /* Pointer to found definition. */ dcl 1 segname_acc aligned like acc_string based (segname_acc_ptr); dcl segname_acc_ptr ptr parameter; /* Pointer to seg name being searched for. */ dcl 1 symbol_acc aligned like acc_string based (symbol_acc_ptr); dcl symbol_acc_ptr ptr parameter; /* Pointer to symbol name being searched for. */ dcl word fixed bin (36) unsigned unaligned based; %page; def_header_ptr = p_def_header_ptr; on out_of_bounds goto no_match; code = 0; counter = 0; /* Initiate "sanity" counter. */ if definition_header.hash_table_relp = 0 then do; /* Go here if there is no hash table. First check class 3 defs for segname. */ def_ptr = null; do segname_ptr = addrel (def_header_ptr, definition_header.def_list_relp) repeat addrel (def_header_ptr, segname_definition.next_segname_relp) while (segname_ptr -> word ^= 0); counter = counter + 1; if counter > 1000 then goto no_match; def_segname_acc_ptr = addrel (def_header_ptr, segname_definition.name_relp); if def_segname_acc.string = segname_acc.string then do; def_ptr = addrel (def_header_ptr, segname_definition.forward_relp); goto start_def_search_loop; end; end; def_ptr = addrel (def_header_ptr, definition_header.def_list_relp); start_def_search_loop: do def_ptr = def_ptr repeat addrel (def_header_ptr, definition.forward_relp) while (def_ptr -> word ^= 0 & counter < 1000); /* forwrd_relp -> (zero word) marks the end of the thread. */ counter = counter + 1; if ^definition.flags.ignore then do; def_name_ptr = addrel (def_header_ptr, definition.name_relp); /* Get the name associated with the definition. */ if symbol_acc.string = def_name.string then goto found_def; end; end; end; %page; else do; def_ht_ptr = addrel (def_header_ptr, definition_header.hash_table_relp); /* Have pointer to beginning of hash table. */ /* Hash index is determined by the length of the name string and the first three characters (the first word) mod divided by the size the table plus one. */ do hash_index = mod (symbol_acc_ptr -> word, definition_ht.n_entries) + 1 repeat hash_index + 1 while (definition_ht.table (hash_index).def_relp ^= 0 & hash_index < 1000); /* Sanity check in case definition_ht.n_entries is trashed. */ def_ptr = addrel (def_header_ptr, definition_ht.table (hash_index).def_relp); /* Get the pointer to the definition for this entry. */ if definition.forward_relp = 0 then do; /* If true there is pointing to a duplicate name table and not a definition. */ dup_table_ptr = def_ptr; if duplicate_table.n_names < 1 | duplicate_table.n_names > 999 then goto no_match; do duplicate_table_index = 1 to duplicate_table.n_names; /* Linear search through the duplicate name table. */ def_ptr = addrel (def_header_ptr, duplicate_table.table (duplicate_table_index).def_relp); def_name_ptr = addrel (def_header_ptr, definition.name_relp); segname_ptr = addrel (def_header_ptr, definition.segname_relp); def_segname_acc_ptr = addrel (def_header_ptr, segname_definition.name_relp); if symbol_acc.string = def_name.string & segname_acc.string = def_segname_acc.string then goto found_def; /* Make the comparision. */ end; end; else do; /* It is just a normal definition. */ def_name_ptr = addrel (def_header_ptr, definition.name_relp); /* Get pointer to name associated with this definition. */ if symbol_acc.string = def_name.string then goto found_def; /* Make the comparision. */ end; end; end; %page; no_match: returned_def_ptr = null (); /* Return null pointer. */ code = error_table_$no_ext_sym; /* Appropriate error code. */ return; found_def: returned_def_ptr = def_ptr; /* Return the found pointer. */ return; %page; %include definition_dcls; end /* get_def_ptr */;  bce_inst_length_.pl1 11/11/89 1134.9r w 11/11/89 0826.6 13977 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ bce_inst_length_: procedure (ip, special) returns (fixed bin); /* given a ptr to an instruction (ip) - return the number of words that must be moved to relocate the instruction. Stolen from inst_length_. */ dcl (ip pointer, /* to instruction */ special fixed bin) parameter; /* if non-EIS, nonzero means special modifiers; if EIS, then number of EIS-type descriptors */ dcl op_index fixed bin; /* op code, used as index into op_mnemonic */ dcl 1 instruction_overlay based aligned, /* for picking out op code */ 2 tag bit (3) unaligned, 2 offset fixed bin (14) unaligned, 2 opcode bit (10) unaligned; dcl (addr, addrel, fixed) builtin; /* find out length of the instruction */ op_index = fixed (ip -> instruction_overlay.opcode, 10, 0); /* get instruction_overlay.opcode */ if op_mnemonic_$op_mnemonic (op_index).opcode = "xec " then return (0); special = op_mnemonic_$op_mnemonic (op_index).num_desc; return (op_mnemonic_$op_mnemonic (op_index).num_words); %include op_mnemonic_format; end bce_inst_length_;  bce_name_to_segnum_.pl1 11/11/89 1134.9r w 11/11/89 0826.6 90819 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ bce_name_to_segnum_: proc (p_name, p_segnum, p_code); /* Look up the segnum for a hardcore seg in the image. Keith Loepere, December 1983. */ /* Changed June 1984 for the riddance of bce_probe_data - Allen Ball. */ /* Also changed to give more information in bce_segptr_to_name_ - ADB */ /* Added segnum check to segptr entry, Keith Loepere, November 1984. */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ dcl addr builtin; dcl addrel builtin; dcl bin builtin; dcl 1 closest_hi_def aligned like definition based (closest_hi_def_ptr); dcl closest_hi_def_ptr ptr; dcl 1 closest_lo_def aligned like definition based (closest_lo_def_ptr); dcl closest_lo_def_ptr ptr; dcl 1 closest_hi_segname_def aligned like segname_definition based (closest_hi_segname_def_ptr); dcl closest_hi_segname_def_ptr ptr; dcl 1 closest_lo_segname_def aligned like segname_definition based (closest_lo_segname_def_ptr); dcl closest_lo_segname_def_ptr ptr; dcl component char (32); dcl counter fixed bin; dcl crash_definitions_$ external; dcl crash_name_table$ external; dcl crash_slt$ external; dcl dimension builtin; dcl error_table_$name_not_found fixed bin (35) ext static; dcl hash_index_ entry (ptr, fixed bin (35), fixed bin (35), fixed bin (35)) returns (fixed bin (35)); dcl hash_value fixed bin (35); /* what name hashes to for hash threaded list scan */ dcl hi_offset fixed bin (26); dcl ioa_$rsnnl entry () options (variable); dcl length builtin; dcl lo_offset fixed bin (26); dcl my_name char (256); dcl my_name_len fixed bin; dcl name char (32); dcl 1 name_entry aligned like segnam.names based (name_entry_ptr); /* an entry in the hash threaded list of names */ dcl name_entry_ptr ptr; dcl name_entry_rel bit (18); /* rel ptr to name_entry */ dcl name_tries fixed bin; /* counter of tries to walk hash threads looking for a name before giving up */ dcl null builtin; dcl out_of_bounds condition; dcl p_code fixed bin (35) parameter; dcl p_name char (*) parameter; dcl p_segnum fixed bin (15) parameter; dcl return_string char (256) varying; dcl rtrim builtin; dcl seg_name char (32); dcl segno builtin; dcl segnum fixed bin (15); dcl segptr ptr parameter; dcl substr builtin; dcl word fixed bin (36) unsigned unaligned based; dcl wordno builtin; dcl wordnum fixed bin (26); p_code = 0; name = p_name; on out_of_bounds goto no_name; names_ptr = addr (crash_name_table$); hash_value = hash_index_ (addr (name), length (name), 0, dimension (name_seg.ht, 1)); name_tries = 0; do name_entry_rel = name_seg.ht (hash_value) repeat (name_entry.hp) while (name_entry_rel); /* scan down names that hash alike */ name_entry_ptr = addrel (names_ptr, name_entry_rel); if name_entry.name = name then do; p_segnum = bin (name_entry.segno, 12); return; end; name_tries = name_tries + 1; if name_tries > 100 then go to no_name; end; no_name: p_code = error_table_$name_not_found; return; %page; bce_segnum_to_name_: entry (p_segnum) returns (char (*)); /* Find the hcname for a segment. */ segnum = p_segnum; if segnum = 32767 | segnum = 32766 then return ("bad pointer"); on out_of_bounds goto no_num; sltp = addr (crash_slt$); if segnum < 0 | segnum < slt.first_sup_seg then go to no_num; if slt.last_sup_seg < segnum & segnum < slt.first_init_seg then go to no_num; if slt.last_init_seg < segnum then go to no_num; sltep = addr (slt.seg (segnum)); if slte_uns.segno ^= segnum then go to no_num; name_entry_ptr = addrel (addr (crash_name_table$), slte.names_ptr); name_entry_ptr = addrel (name_entry_ptr, 1); return (rtrim (name_entry.name)); no_num: call ioa_$rsnnl ("^o", my_name, my_name_len, segnum); return (substr (my_name, 1, my_name_len)); %page; bce_segptr_to_name_: entry (segptr) returns (char (*)); return_string = ""; counter = 1; segnum = segno (segptr); wordnum = wordno (segptr); call ioa_$rsnnl ("^o", my_name, my_name_len, segnum); return_string = return_string || substr (my_name, 1, my_name_len) || "|"; call ioa_$rsnnl ("^o", my_name, my_name_len, wordnum); return_string = return_string || substr (my_name, 1, my_name_len); sltp = addr (crash_slt$); if segnum < 0 | segnum < slt.first_sup_seg then go to return_simple_ptr; if slt.last_sup_seg < segnum & segnum < slt.first_init_seg then go to return_simple_ptr; if slt.last_init_seg < segnum then go to return_simple_ptr; on out_of_bounds goto return_simple_ptr; definitions_ptr = addr (crash_definitions_$); def_header_ptr = addrel (definitions_ptr, definitions.dot (segnum).offset); closest_hi_def_ptr = null; closest_lo_def_ptr = null; do def_ptr = addrel (def_header_ptr, definition_header.def_list_relp) repeat addrel (def_header_ptr, definition.forward_relp) while (def_ptr -> word ^= 0 & counter < 1000); /* If def_ptr -> zero word then we found the end of the string or if we see a thousand definitions the string must be bad. */ counter = counter + 1; if definition.class = CLASS_TEXT then do; /* We care only about class text definitions. */ if closest_lo_def_ptr = null then /* Find def pointing to closest address below our ptr. */ if definition.thing_relp <= wordnum then closest_lo_def_ptr = def_ptr; else ; else if closest_lo_def.thing_relp < definition.thing_relp & definition.thing_relp <= wordnum then closest_lo_def_ptr = def_ptr; else ; if closest_hi_def_ptr = null then /* Find def pointing to closest address above our ptr. */ if wordnum <= definition.thing_relp then closest_hi_def_ptr = def_ptr; else ; else if wordnum <= definition.thing_relp & definition.thing_relp < closest_hi_def.thing_relp then closest_hi_def_ptr = def_ptr; else ; end; end; seg_name = bce_segnum_to_name_ (segnum); if closest_lo_def_ptr = null then do; call ioa_$rsnnl ("^o", my_name, my_name_len, wordnum); return_string = return_string || " [" || rtrim (bce_segnum_to_name_ (segnum)) || "|" || substr (my_name, 1, my_name_len) || "]"; end; else do; return_string = return_string || " ["; closest_lo_segname_def_ptr = addrel (def_header_ptr, closest_lo_def.segname_relp); if closest_hi_def_ptr = null then do; acc_string_ptr = addrel (def_header_ptr, closest_lo_segname_def.name_relp); return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "$"; acc_string_ptr = addrel (def_header_ptr, closest_lo_def.name_relp); return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "+"; lo_offset = wordnum - closest_lo_def.thing_relp; call ioa_$rsnnl ("^o", my_name, my_name_len, lo_offset); return_string = return_string || substr (my_name, 1, my_name_len) || "]"; end; else do; closest_hi_segname_def_ptr = addrel (def_header_ptr, closest_hi_def.segname_relp); if closest_hi_segname_def_ptr = closest_lo_segname_def_ptr then do; acc_string_ptr = addrel (def_header_ptr, closest_lo_segname_def.name_relp); if closest_hi_def_ptr = closest_lo_def_ptr & wordnum - closest_lo_def.thing_relp = 0 then do; return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "$"; acc_string_ptr = addrel (def_header_ptr, closest_lo_def.name_relp); return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "+0]"; end; else do; return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "$("; acc_string_ptr = addrel (def_header_ptr, closest_lo_def.name_relp); return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "+"; lo_offset = wordnum - closest_lo_def.thing_relp; call ioa_$rsnnl ("^o", my_name, my_name_len, lo_offset); return_string = return_string || substr (my_name, 1, my_name_len); acc_string_ptr = addrel (def_header_ptr, closest_hi_def.name_relp); return_string = return_string || " " || substr (acc_string.string, 1, acc_string.count) || "-"; hi_offset = closest_hi_def.thing_relp - wordnum; call ioa_$rsnnl ("^o", my_name, my_name_len, hi_offset); return_string = return_string || substr (my_name, 1, my_name_len) || ")]"; end; end; else do; acc_string_ptr = addrel (def_header_ptr, closest_lo_segname_def.name_relp); return_string = return_string || "(" || substr (acc_string.string, 1, acc_string.count) || "$"; acc_string_ptr = addrel (def_header_ptr, closest_lo_def.name_relp); return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "+"; lo_offset = wordnum - closest_lo_def.thing_relp; call ioa_$rsnnl ("^o", my_name, my_name_len, lo_offset); return_string = return_string || substr (my_name, 1, my_name_len); acc_string_ptr = addrel (def_header_ptr, closest_hi_segname_def.name_relp); return_string = return_string || " " || substr (acc_string.string, 1, acc_string.count) || "$"; acc_string_ptr = addrel (def_header_ptr, closest_hi_def.name_relp); return_string = return_string || substr (acc_string.string, 1, acc_string.count) || "-"; hi_offset = closest_hi_def.thing_relp - wordnum; call ioa_$rsnnl ("^o", my_name, my_name_len, hi_offset); return_string = return_string || substr (my_name, 1, my_name_len) || ")]"; end; end; end; return_simple_ptr: return (return_string); %page; %include definition_dcls; %page; %include hc_definitions_seg; %page; %include slt; %page; %include slte; end;  bce_probe.pl1.pmac 11/11/89 1134.9rew 11/11/89 0826.6 639468 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-10,Farley), approve(86-01-10,MCR6979), audit(86-01-24,GDixon), install(86-03-21,MR12.0-1033): Corrected to use first_rec_num & last_rec_num instead of 0 & rec_per_dev. 2) change(86-04-11,Fawcett), approve(86-04-11,MCR7383), audit(86-05-14,Farley), install(86-07-17,MR12.0-1097): Add subvolume support, by calling disk_name_pvtx. END HISTORY COMMENTS */ bce_probe: proc (p_ss_info_ptr); /* Program to examine and change locations in the saved Multics image. Written in November of 1983 by Keith Loepere. */ /* Modified (get_address) June of 1984 to find addresses with symbolic references. - Allen Ball. */ /* Modified March 1985 to move relocate_instruction_ into hardcore, Keith Loepere. */ /* WARNING: this must be run through pl1_macro, without args, before compilation. */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ /* Types of addresses and modes... */ dcl Absolute fixed bin static options (constant) init (1); dcl Accessing_breakpoint_page char (25) static options (constant) init ("Accessing breakpoint page"); dcl Accessing_segment char (17) static options (constant) init ("Accessing segment"); dcl Address_missing char (15) static options (constant) init ("Address missing"); dcl Address_type_must_be_virtual char (28) static options (constant) init ("Address type must be virtual"); dcl Apte_number_missing char (19) static options (constant) init ("Apte number missing"); dcl Ascii fixed bin static options (constant) init (1); /* mode */ dcl Bad_apte char (8) static options (constant) init ("Bad apte"); dcl Bad_component_name char (18) static options (constant) init ("Bad component name"); dcl Bad_disk_record char (15) static options (constant) init ("Bad disk record"); dcl Bad_decimal_value char (17) static options (constant) init ("Bad decimal value"); dcl Bad_octal_value char (15) static options (constant) init ("Bad octal value"); dcl Bad_page_offset char (15) static options (constant) init ("Bad page offset"); dcl Bad_segment_offset char (18) static options (constant) init ("Bad segment offset"); dcl Base8 fixed bin static options (constant) init (8); dcl Base10 fixed bin static options (constant) init (10); dcl Bce_mode fixed bin static options (constant) init (3); dcl Break_already_set char (17) static options (constant) init ("Break already set"); dcl Break_mode fixed bin static options (constant) init (1); dcl Crash_mode fixed bin static options (constant) init (2); dcl DRL_1 bit (36) aligned static options (constant) init ("777777002000"b3); dcl Decimal fixed bin static options (constant) init (2); /* mode */ dcl Disk fixed bin static options (constant) init (2); dcl Dot_must_be_followed_by_plus_or_minus char (37) static options (constant) init ("Dot must be followed by plus or minus"); dcl Function_arg_list_missing char (25) static options (constant) init ("Function arg list missing"); dcl Function_argument_missing char (25) static options (constant) init ("Function argument missing"); dcl Improper_arg_list_end_for_function char (34) static options (constant) init ("Improper arg list end for function"); dcl Improper_syntax_in_line char (23) static options (constant) init ("Improper syntax in line"); dcl Instruction fixed bin static options (constant) init (3); /* mode */ dcl Invalid_word_offset char (19) static options (constant) init ("Invalid word offset"); dcl Instruction_cannot_be_breakpointed char (34) static options (constant) init ("Instruction cannot be breakpointed"); dcl Missing_component char (17) static options (constant) init ("Missing component"); dcl Missing_equals char (9) static options (constant) init ("Missing ="); dcl Missing_offset char (14) static options (constant) init ("Missing offset"); dcl Missing_seg_id char (14) static options (constant) init ("Missing seg id"); dcl Missing_value char (13) static options (constant) init ("Missing value"); dcl Missing_word_offset char (19) static options (constant) init ("Missing word offset"); dcl NOP bit (36) static options (constant) init ("000000011000"b3); dcl Name char (4) static options (constant) init ("Name"); dcl Name_missing char (12) static options (constant) init ("Name missing"); dcl No_break_set char (12) static options (constant) init ("No break set"); dcl No_current_address char (18) static options (constant) init ("No current address"); dcl No_current_break char (16) static options (constant) init ("No current break"); dcl No_image_to_restart char (19) static options (constant) init ("No image to restart"); dcl No_offset_may_be_added_to_register_addresses char (44) static options (constant) init ("No offset may be added to register addresses"); dcl No_such_drive char (13) static options (constant) init ("No such drive"); dcl Octal fixed bin static options (constant) init (4); /* mode */ dcl Offset_makes_address_negative char (29) static options (constant) init ("Offset makes address negative"); dcl Plus_or_minus_allowed_only_with_an_entry_name char (45) static options (constant) init ("Plus or minus allowed only with an entry name"); dcl Pointer fixed bin static options (constant) init (5); /* mode */ dcl Reading_a_line char (14) static options (constant) init ("Reading a line"); dcl Reading_disk char (12) static options (constant) init ("Reading disk"); dcl Register fixed bin static options (constant) init (3); dcl Register_address_not_allowed char (28) static options (constant) init ("Register address not allowed"); dcl Segment_name char (12) static options (constant) init ("Segment name"); dcl Segment_not_breakpointable char (26) static options (constant) init ("Segment not breakpointable"); dcl Segment_number_missing char (22) static options (constant) init ("Segment number missing"); dcl TRA bit (18) init ("710000"b3); dcl Too_many_breakpoints_in_segment char (31) static options (constant) init ("Too many breakpoints in segment"); dcl Unexpected_args_follow char (22) static options (constant) init ("Unexpected args follow"); dcl Unknown_mode char (12) static options (constant) init ("Unknown mode"); dcl Unmatched_quotes char (16) static options (constant) init ("Unmatched_quotes"); dcl Unrecognizable_address char (22) static options (constant) init ("Unrecognizable address"); dcl Unrecognizable_request char (22) static options (constant) init ("Unrecognizable request"); dcl Unrecognizable_option char (21) static options (constant) init ("Unrecognizable option"); dcl Unrecognizable_value char (20) static options (constant) init ("Unrecognizable value"); dcl Unknown_register char (16) static options (constant) init ("Unknown register"); dcl Values_being_let_too_long char (25) static options (constant) init ("Values being let too long"); dcl Virtual fixed bin static options (constant) init (4); dcl Writing_disk char (12) static options (constant) init ("Writing disk"); dcl absadr entry (ptr, fixed bin (35)) returns (fixed bin (26)); dcl addbitno builtin; dcl addcharno builtin; dcl addr builtin; dcl addrel builtin; dcl addwordno builtin; dcl arg char (arg_len) based (arg_ptr); dcl arg_index fixed bin; /* loop var for function args */ dcl arg_len fixed bin (21); dcl arg_num fixed bin; dcl arg_ptr ptr; dcl 1 arg_list aligned, /* for calling functions within us */ 2 twice_num_args fixed bin (18) uns unal, /* standard stuff */ 2 tag bit (18) unal init ("000004"b3), 2 pad_descriptors fixed bin (18) uns unal init (0), 2 arg_ptrs (8) ptr; dcl arg_str_lens (4) fixed bin; /* used as built arguments to functions we call */ dcl arg_str_ptrs (4) ptr; /* used as built arguments to functions we call */ dcl baseptr builtin; dcl bce_appending_simulation$get_absolute entry (fixed bin (26), fixed bin (18), ptr, fixed bin (35)); dcl bce_appending_simulation$get_virtual entry (ptr, fixed bin (26), fixed bin (18), ptr, fixed bin (35)); dcl bce_appending_simulation$put_absolute entry (fixed bin (26), fixed bin (18), ptr, fixed bin (35)); dcl bce_appending_simulation$put_virtual entry (ptr, fixed bin (26), fixed bin (18), ptr, fixed bin (35)); dcl bce_appending_simulation$init entry (bit (1) aligned, fixed bin (35)); dcl bce_appending_simulation$new_dbr entry (bit (72) aligned, fixed bin (15), fixed bin (35)); dcl bce_appending_simulation$new_segment entry (fixed bin (15), ptr, fixed bin (35)); dcl bce_component_to_wordnum_ entry (fixed bin (15), char (32), char (32), fixed bin (15), fixed bin (26), fixed bin (35)); dcl bce_continue entry; dcl bce_data$get_line external variable entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl disk_name_pvtx entry (char (8), fixed bin, fixed bin (35)); dcl bce_display_instruction_ entry (ptr, fixed bin, fixed bin (26)); dcl bce_display_scu_ entry (ptr, fixed bin (26), bit (1) aligned); dcl bce_inst_length_ entry (ptr, fixed bin) returns (fixed bin); dcl bce_name_to_segnum_ entry (char (*), fixed bin (15), fixed bin (35)); dcl 1 bce_probe_data aligned, 2 my_seg_info_ptr ptr, /* current seg_info */ 2 last_segnum fixed bin (15), /* highest segnum valid for this dbr */ 2 address, /* current address */ 3 type fixed bin, 3 pvtx fixed bin, /* for disk address */ 3 record_num fixed bin (18), 3 pad bit (36), 3 reg_ptr ptr, /* address of register (in toehold or breakpoint_page) */ 3 segnum fixed bin (15), 3 wordnum fixed bin (26), 3 default_mode fixed bin, 3 default_len fixed bin (24), /* in bits */ 3 error_name char (32) unal; /* used in error msgs */ dcl bce_relocate_instruction_ entry (ptr, ptr, fixed bin (18), fixed bin, fixed bin, fixed bin (35)); dcl bce_segnum_to_name_ entry (fixed bin (15)) returns (char (*)); dcl bce_segptr_to_name_ entry (ptr) returns (char (*)); dcl bin builtin; dcl bit builtin; dcl breakpoint_absadr fixed bin (26); /* to breakpoint_page */ dcl breakpoint_at ptr; /* within simulated space of active break */ dcl breakpoint_page$ external; dcl 1 breakpoint_page_buffer aligned like bkpt_page.header; dcl code fixed bin (35); dcl com_err_ entry () options (variable); dcl crash_definitions_$ ext; dcl crash_name_table$ ext; dcl crash_lot$ ext; dcl crash_slt$ ext; dcl cu_$arg_count_rel entry (fixed bin, ptr, fixed bin (35)); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl cu_$generate_call entry (entry, ptr); dcl cv_integer_string_check_ entry (char (*), fixed bin, fixed bin (35)) returns (fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl definitions_$ ext; dcl dimension builtin; dcl divide builtin; dcl error_table_$bad_arg fixed bin (35) ext static; dcl examine_mode fixed bin; /* break versus crash vs bce */ dcl fixed builtin; dcl get_ptrs_$given_segno entry (fixed bin (15)) returns (ptr); dcl index builtin; dcl ioa_ entry () options (variable); dcl length builtin; dcl line char (line_len) based (line_ptr); /* amount of input request line left to process */ dcl line_buffer char (128); /* area to hold input request line */ dcl line_len fixed bin; dcl line_ptr ptr; dcl lot$ external; dcl me char (5) static options (constant) init ("probe"); dcl min builtin; dcl mod builtin; dcl my_dbr bit (72) aligned; dcl my_initial_dbr bit (72) aligned; dcl 1 my_seg_info aligned like seg_info; /* describe seg being dumped for virtual addr */ dcl name_table$ ext; dcl null builtin; dcl old_instr_buffer (4) bit (36) aligned; dcl p_ss_info_ptr ptr parameter; dcl pc$nullify entry (ptr); dcl prs (0:7) char (4) int static options (constant) init ("(ap)", "(ab)", "(bp)", "(bb)", "(lp)", "(lb)", "(sp)", "(sb)"); dcl ptr builtin; dcl read_disk entry (fixed bin, fixed bin (18), ptr, fixed bin (35)); dcl rtrim builtin; %set reg_num to 0; %set reg_num to reg_num + 1; %set pr0_num to reg_num; %set reg_num to reg_num + 1; %set pr1_num to reg_num; %set reg_num to reg_num + 1; %set pr2_num to reg_num; %set reg_num to reg_num + 1; %set pr3_num to reg_num; %set reg_num to reg_num + 1; %set pr4_num to reg_num; %set reg_num to reg_num + 1; %set pr5_num to reg_num; %set reg_num to reg_num + 1; %set pr6_num to reg_num; %set reg_num to reg_num + 1; %set pr7_num to reg_num; %set reg_num to reg_num + 1; %set x0_num to reg_num; %set reg_num to reg_num + 1; %set x1_num to reg_num; %set reg_num to reg_num + 1; %set x2_num to reg_num; %set reg_num to reg_num + 1; %set x3_num to reg_num; %set reg_num to reg_num + 1; %set x4_num to reg_num; %set reg_num to reg_num + 1; %set x5_num to reg_num; %set reg_num to reg_num + 1; %set x6_num to reg_num; %set reg_num to reg_num + 1; %set x7_num to reg_num; %set reg_num to reg_num + 1; %set a_num to reg_num; %set reg_num to reg_num + 1; %set q_num to reg_num; %set reg_num to reg_num + 1; %set e_num to reg_num; %set reg_num to reg_num + 1; %set t_num to reg_num; %set reg_num to reg_num + 1; %set ralr_num to reg_num; %set reg_num to reg_num + 1; %set fault_num to reg_num; %set reg_num to reg_num + 1; %set ext_fault_num to reg_num; %set reg_num to reg_num + 1; %set mode_num to reg_num; %set reg_num to reg_num + 1; %set cache_num to reg_num; %set reg_num to reg_num + 1; %set dbr_num to reg_num; %set reg_num to reg_num + 1; %set bar_num to reg_num; dcl reg_lens (reg_num) fixed bin static options (constant) init /* become default lengths for register display */ (72, 72, 72, 72, 72, 72, 72, 72, 18, 18, 18, 18, 18, 18, 18, 18, 36, 36, 8, 27, 3, 36, 15, 36, 36, 72, 36); dcl reg_modes (reg_num) fixed bin init (Pointer, Pointer, Pointer, Pointer, Pointer, Pointer, Pointer, Pointer, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal, Octal); dcl reg_names (reg_num) char (9) static options (constant) init ("pr0", "pr1", "pr2", "pr3", "pr4", "pr5", "pr6", "pr7", "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7", "a", "q", "e", "t", "ralr", "fault", "ext_fault", "mode", "cache", "dbr", "bar"); dcl reg_ptrs (reg_num) ptr; /* start of reg */ dcl req_index fixed bin; /* loop index on requests */ %set req_num to 0; %set req_num to req_num + 1; %set b_req to req_num; %set req_num to req_num + 1; %set before_req to req_num; %set req_num to req_num + 1; %set c_req to req_num; %set req_num to req_num + 1; %set continue_req to req_num; %set req_num to req_num + 1; %set dbr_req to req_num; %set req_num to req_num + 1; %set display_req to req_num; %set req_num to req_num + 1; %set dot_req to req_num; %set req_num to req_num + 1; %set ds_req to req_num; %set req_num to req_num + 1; %set l_req to req_num; %set req_num to req_num + 1; %set let_req to req_num; %set req_num to req_num + 1; %set list_requests_req to req_num; %set req_num to req_num + 1; %set lr_req to req_num; %set req_num to req_num + 1; %set mc_req to req_num; %set req_num to req_num + 1; %set name_req to req_num; %set req_num to req_num + 1; %set proc_req to req_num; %set req_num to req_num + 1; %set q_req to req_num; %set req_num to req_num + 1; %set quit_req to req_num; %set req_num to req_num + 1; %set r_req to req_num; %set req_num to req_num + 1; %set reset_req to req_num; %set req_num to req_num + 1; %set segno_req to req_num; %set req_num to req_num + 1; %set sk_req to req_num; %set req_num to req_num + 1; %set st_req to req_num; %set req_num to req_num + 1; %set stack_req to req_num; %set req_num to req_num + 1; %set status_req to req_num; dcl requests (req_num) char (16) static options (constant) init ("b", "before", "c", "continue", "dbr", "display", ".", "ds", "l", "let", "list_requests", "lr", "mc", "name", "proc", "q", "quit", "r", "reset", "segno", "sk", "st", "stack", "status"); dcl search builtin; dcl segno builtin; dcl size builtin; dcl slt$ external; dcl string char (string_len) based (string_ptr); /* item in request line being examined */ dcl string_len fixed bin; dcl string_ptr ptr; dcl sub_request_abort_ condition; dcl substr builtin; dcl sys_boot_info$bce_dbr bit (72) aligned external; dcl tc_data$ external; dcl 1 toehold$ aligned like toe_hold external; dcl unspec builtin; dcl 1 value aligned, /* description of value in let request */ 2 type fixed bin, 2 length fixed bin, /* in bits */ 2 align fixed bin (71), 2 data bit (256 * 9) aligned; /* max allowed */ dcl verify builtin; dcl 1 work_area aligned, 2 left_from_before bit (4 * 36), 2 buffer bit (1024 * 36); /* for building data to write */ dcl write_disk entry (fixed bin, fixed bin (18), ptr, fixed bin (35)); dcl wordno builtin; %page; ss_info_ptr = p_ss_info_ptr; fgbxp = addr (flagbox$); if fgbx.breakpoint then examine_mode = Break_mode; else if sys_info$collection_1_phase = CRASH_INITIALIZATION | sys_info$collection_1_phase = BCE_CRASH_INITIALIZATION then examine_mode = Crash_mode; else examine_mode = Bce_mode; if ss_info_ptr ^= null then do; call cu_$arg_count_rel (arg_num, ss_info.arg_list_ptr, code); if code = 0 then do arg_index = 1 to arg_num; call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_len, code, ss_info.arg_list_ptr); if arg = "-crash" then examine_mode = Crash_mode; else if arg = "-bce" then examine_mode = Bce_mode; else if arg = "-break" then examine_mode = Break_mode; else do; call com_err_ (error_table_$bad_arg, me, "^a", arg); return; end; end; end; call ioa_ ("Using ^[breakpoint info^;Multics image^;bce^].", examine_mode); if examine_mode = Crash_mode then do; reg_ptrs (pr0_num) = addr (toehold$.mc_.prs (0)); reg_ptrs (pr1_num) = addr (toehold$.mc_.prs (1)); reg_ptrs (pr2_num) = addr (toehold$.mc_.prs (2)); reg_ptrs (pr3_num) = addr (toehold$.mc_.prs (3)); reg_ptrs (pr4_num) = addr (toehold$.mc_.prs (4)); reg_ptrs (pr5_num) = addr (toehold$.mc_.prs (5)); reg_ptrs (pr6_num) = addr (toehold$.mc_.prs (6)); reg_ptrs (pr7_num) = addr (toehold$.mc_.prs (7)); reg_ptrs (x0_num) = addr (toehold$.mc_.x (0)); reg_ptrs (x1_num) = addr (toehold$.mc_.x (1)); reg_ptrs (x2_num) = addr (toehold$.mc_.x (2)); reg_ptrs (x3_num) = addr (toehold$.mc_.x (3)); reg_ptrs (x4_num) = addr (toehold$.mc_.x (4)); reg_ptrs (x5_num) = addr (toehold$.mc_.x (5)); reg_ptrs (x6_num) = addr (toehold$.mc_.x (6)); reg_ptrs (x7_num) = addr (toehold$.mc_.x (7)); reg_ptrs (a_num) = addr (toehold$.mc_.a); reg_ptrs (q_num) = addr (toehold$.mc_.q); reg_ptrs (e_num) = addr (toehold$.mc_.e); reg_ptrs (t_num) = addr (toehold$.mc_.t); reg_ptrs (ralr_num) = addr (toehold$.mc_.ralr); reg_ptrs (fault_num) = addr (toehold$.mc_.fault_reg); reg_ptrs (ext_fault_num) = addr (toehold$.mc_.ext_fault_reg); reg_ptrs (mode_num) = addr (toehold$.mode_reg); reg_ptrs (cache_num) = addr (toehold$.cache_mode_reg); reg_ptrs (dbr_num) = addr (toehold$.multics_state.dbr); reg_ptrs (bar_num) = addr (toehold$.bar); end; else do; reg_ptrs (pr0_num) = addr (breakpoint_page_buffer.mc_.prs (0)); reg_ptrs (pr1_num) = addr (breakpoint_page_buffer.mc_.prs (1)); reg_ptrs (pr2_num) = addr (breakpoint_page_buffer.mc_.prs (2)); reg_ptrs (pr3_num) = addr (breakpoint_page_buffer.mc_.prs (3)); reg_ptrs (pr4_num) = addr (breakpoint_page_buffer.mc_.prs (4)); reg_ptrs (pr5_num) = addr (breakpoint_page_buffer.mc_.prs (5)); reg_ptrs (pr6_num) = addr (breakpoint_page_buffer.mc_.prs (6)); reg_ptrs (pr7_num) = addr (breakpoint_page_buffer.mc_.prs (7)); reg_ptrs (x0_num) = addr (breakpoint_page_buffer.mc_.x (0)); reg_ptrs (x1_num) = addr (breakpoint_page_buffer.mc_.x (1)); reg_ptrs (x2_num) = addr (breakpoint_page_buffer.mc_.x (2)); reg_ptrs (x3_num) = addr (breakpoint_page_buffer.mc_.x (3)); reg_ptrs (x4_num) = addr (breakpoint_page_buffer.mc_.x (4)); reg_ptrs (x5_num) = addr (breakpoint_page_buffer.mc_.x (5)); reg_ptrs (x6_num) = addr (breakpoint_page_buffer.mc_.x (6)); reg_ptrs (x7_num) = addr (breakpoint_page_buffer.mc_.x (7)); reg_ptrs (a_num) = addr (breakpoint_page_buffer.mc_.a); reg_ptrs (q_num) = addr (breakpoint_page_buffer.mc_.q); reg_ptrs (e_num) = addr (breakpoint_page_buffer.mc_.e); reg_ptrs (t_num) = addr (breakpoint_page_buffer.mc_.t); reg_ptrs (ralr_num) = addr (breakpoint_page_buffer.mc_.ralr); reg_ptrs (fault_num) = addr (breakpoint_page_buffer.mc_.fault_reg); reg_ptrs (ext_fault_num) = addr (breakpoint_page_buffer.mc_.ext_fault_reg); reg_ptrs (mode_num) = addr (breakpoint_page_buffer.mode_reg); reg_ptrs (cache_num) = addr (breakpoint_page_buffer.cache_mode_reg); reg_ptrs (dbr_num) = addr (breakpoint_page_buffer.dbr); reg_ptrs (bar_num) = addr (breakpoint_page_buffer.bar); end; %page; bce_probe_data.my_seg_info_ptr = addr (my_seg_info); sltp = addr (slt$); bce_probe_data.address.type = 0; do arg_index = 1 to dimension (arg_str_ptrs, 1); arg_list.arg_ptrs (arg_index * 2 - 1) = addr (arg_str_ptrs (arg_index)); arg_list.arg_ptrs (arg_index * 2) = addr (arg_str_lens (arg_index)); end; call bce_appending_simulation$init (examine_mode ^= Bce_mode, code); if examine_mode ^= Bce_mode then my_dbr = toehold$.multics_state.dbr; else my_dbr = sys_boot_info$bce_dbr; my_initial_dbr = my_dbr; call new_dbr (my_dbr); breakpoint_absadr = absadr (addr (breakpoint_page$), (0)); breakpoint_at = null; if examine_mode = Break_mode then do; call bce_appending_simulation$get_absolute (breakpoint_absadr, size (breakpoint_page_buffer), addr (breakpoint_page_buffer), code); if code ^= 0 then do; call com_err_ (code, me, "Cannot process break info."); return; end; scup = addr (breakpoint_page_buffer.mc_.scu); breakpoint_at = addrel (baseptr (bin (scu.ppr.psr, 15)), bin (scu.ilc, 18) - 1); /* the drl - start of breakpoint info */ call bce_appending_simulation$new_segment (segno (breakpoint_at), bce_probe_data.my_seg_info_ptr, code); if code = 0 then do; breakpoint_ptr = addr (buffer); call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, wordno (breakpoint_at), size (breakpoint), breakpoint_ptr, code); if code = 0 then do; breakpoint_at = breakpoint.original_instr_ptr; call ioa_ ("Break before ^a.", bce_segptr_to_name_ (breakpoint_at)); end; else breakpoint_at = null; end; else breakpoint_at = null; end; line_len = 0; on sub_request_abort_ begin; line_len = 0; go to request_done; end; do while ("1"b); string_len = 0; do while (string_len = 0); /* find a command name */ do while (line_len = 0); /* get a line */ line_ptr = addr (line_buffer); code = 1; do while (code ^= 0); call bce_data$get_line (addr (bce_data$get_line), addr (line_buffer), length (line_buffer), line_len, code); if code ^= 0 then call line_error_code (code, Reading_a_line); end; end; /* extract command name */ call get_string; if string_len = 0 then do; /* we have found a delimiter */ if substr (line, 1, 1) = ";" | substr (line, 1, 1) = " " /* NL */ then do; line_len = line_len - 1; /* pass ; or NL */ line_ptr = addcharno (line_ptr, 1); end; else call line_error (Improper_syntax_in_line); end; end; do req_index = 1 to dimension (requests, 1) while (requests (req_index) ^= string); end; if req_index > dimension (requests, 1) then call line_error (Unrecognizable_request); else go to do_request (req_index); %page; do_request (b_req /* b_req */): go to do_request (before_req /* before_req */); %page; do_request (before_req /* before_req */): begin; dcl bkpt_num fixed bin; /* loop counter */ dcl 1 bkpt_tra_instr aligned based (addr (old_instr_buffer)), 2 offset fixed bin (18) uns unal, /* tra instruction that the breakpoint becomes */ 2 op bit (18) unal; dcl eis_len fixed bin; /* num of eis descrs */ dcl instr_delta fixed bin (18); /* amt to reloacte instr being broken at */ dcl instr_len fixed bin; /* of instr being reloacted */ dcl instr_num fixed bin; /* loop counter */ dcl instr_ptr ptr; /* to instruction to set break at */ call pass_white; if line_len > 0 then if substr (line, 1, 1) ^= ";" & substr (line, 1, 1) ^= " " /* nl */ then call get_address; if bce_probe_data.address.type ^= Virtual then call line_error (Address_type_must_be_virtual); call check_no_more_args; sltp = addr (crash_slt$); sltep = addr (slt.seg (bce_probe_data.address.segnum)); bce_probe_data.address.error_name = bce_segnum_to_name_ (bce_probe_data.address.segnum); if ^slte.breakpointable then call line_error_arg (Segment_not_breakpointable, bce_probe_data.address.error_name); call bce_appending_simulation$new_segment (bce_probe_data.address.segnum, bce_probe_data.my_seg_info_ptr, code); if code ^= 0 then go to before_bad_access; bkpt_page_ptr = addr (buffer); call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, my_seg_info.size - 1024, 1024, bkpt_page_ptr, code); if code ^= 0 then go to before_bad_access; instr_ptr = addrel (baseptr (bce_probe_data.address.segnum), bce_probe_data.address.wordnum); do bkpt_num = 1 to dimension (bkpt_page.bkpts, 1); if bkpt_page.bkpts (bkpt_num).original_instr_ptr = instr_ptr then call line_error (Break_already_set); end; do bkpt_num = 1 to dimension (bkpt_page.bkpts, 1) while (unspec (bkpt_page.bkpts (bkpt_num)) ^= "0"b); end; if bkpt_num > dimension (bkpt_page.bkpts, 1) then call line_error_arg (Too_many_breakpoints_in_segment, bce_probe_data.address.error_name); breakpoint_ptr = addr (bkpt_page.bkpts (bkpt_num)); instr_delta = my_seg_info.size - 1024 + wordno (addr (breakpoint.instructions)) - wordno (bkpt_page_ptr) - bce_probe_data.address.wordnum; call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, bce_probe_data.address.wordnum, size (old_instr_buffer), addr (old_instr_buffer), code); if code ^= 0 then go to before_bad_access; do instr_num = 1 to dimension (breakpoint.instructions, 1); breakpoint.instructions (instr_num) = NOP; end; instr_len = bce_inst_length_ (addr (old_instr_buffer), eis_len); if instr_len = 0 then go to bad_instr_error; call bce_relocate_instruction_ (addr (old_instr_buffer), addr (breakpoint.instructions), -instr_delta, instr_len, eis_len, code); if code ^= 0 then bad_instr_error: call line_error (Instruction_cannot_be_breakpointed); breakpoint.breakpoint_drl = DRL_1; breakpoint.tra_back = TRA; breakpoint.tra_back_offset = instr_len + bce_probe_data.address.wordnum; breakpoint.original_instr_ptr = instr_ptr; breakpoint.original_instr = old_instr_buffer (1); call bce_appending_simulation$put_virtual (bce_probe_data.my_seg_info_ptr, my_seg_info.size - 1024 + wordno (breakpoint_ptr) - wordno (bkpt_page_ptr), size (breakpoint), breakpoint_ptr, code); if code ^= 0 then go to before_bad_access; bkpt_tra_instr.op = TRA; bkpt_tra_instr.offset = instr_delta - 1 + bce_probe_data.address.wordnum; call bce_appending_simulation$put_virtual (bce_probe_data.my_seg_info_ptr, bce_probe_data.address.wordnum, 1, addr (old_instr_buffer), code); if code ^= 0 then before_bad_access: call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name); call ioa_ ("Break set before ^a.", bce_segptr_to_name_ (instr_ptr)); go to request_done; end; %page; do_request (c_req /* c_req */): go to do_request (continue_req /* continue_req */); %page; do_request (continue_req /* continue_req */): call check_no_more_args; if ^(sys_info$collection_1_phase = CRASH_INITIALIZATION | sys_info$collection_1_phase = BCE_CRASH_INITIALIZATION) then call line_error (No_image_to_restart); call bce_continue; go to request_done; %page; do_request (dbr_req /* dbr_req */): begin; dcl dbr_value bit (72) aligned; /* new value being built */ dcl dbr_word fixed bin (35); /* single part of new value */ call get_string; if string_len = 0 then do; call check_no_more_args; my_dbr = my_initial_dbr; call new_dbr (my_dbr); call ioa_ ("dbr = ^24.3b", my_dbr); goto request_done; end; dbr_word = cv_integer_string_check_ (string, Base8, code); if code ^= 0 then go to bad_octal; dbr_value = my_dbr; substr (dbr_value, 1, 36) = unspec (dbr_word); call get_string; if string_len > 0 then do; dbr_word = cv_integer_string_check_ (string, Base8, code); if code ^= 0 then bad_octal: call line_error (Bad_octal_value); substr (dbr_value, 37, 36) = unspec (dbr_word); end; call check_no_more_args; call new_dbr (dbr_value); go to request_done; end; %page; do_request (display_req /* display_req */): begin; dcl bits_left_over fixed bin; /* amt of previous buffer we couldn't display */ dcl buffer_data_ptr ptr; /* where in buffer data starts */ dcl data_address fixed bin (26); /* relative to address type */ dcl data_bits_done fixed bin (24); /* normally for instruction mode - => how many bits not done because of chance that instr wrapped onto next buffer */ dcl data_label fixed bin (26); /* for display */ dcl data_length fixed bin (24); /* in bits */ dcl data_part_bits fixed bin (24); /* number of bits in this bunch to dump */ dcl data_part_words fixed bin (18); /* number of words in this bunch to dump */ dcl display_buffer_ptr ptr; /* start of bits to display taking into account amount scrolled from previous buffer */ dcl mode fixed bin; /* display mode */ call get_address; mode = bce_probe_data.address.default_mode; data_length = bce_probe_data.address.default_len; call get_string; if string_len > 0 then do; if string = "a" then do; mode = Ascii; data_length = 9; end; else if string = "d" then mode = Decimal; else if string = "i" then mode = Instruction; else if string = "o" then mode = Octal; else if string = "p" then do; mode = Pointer; data_length = 72; end; else call line_error (Unknown_mode); call get_string; if string_len > 0 then if string = "*" & bce_probe_data.address.type = Virtual then data_length = 36 * (my_seg_info.size - bce_probe_data.address.wordnum); else do; data_length = cv_integer_string_check_ (string, Base10, code); if code ^= 0 then call line_error (Bad_decimal_value); if mode = Ascii then data_length = data_length * 9; else if mode = Pointer then data_length = data_length * 72; else data_length = data_length * 36; end; end; call check_no_more_args; if bce_probe_data.address.type = Register then do; data_length = min (data_length, bce_probe_data.address.default_len); call display (bce_probe_data.address.reg_ptr, data_length, -1, mode, data_bits_done, "0"b); end; else do; data_address = bce_probe_data.address.wordnum; data_label = data_address; bits_left_over = 0; do while (data_length > 0); /* do a page at a time */ data_part_words = 1024 - mod (data_address, 1024); buffer_data_ptr = addrel (addr (buffer), mod (data_address, 1024)); data_part_bits = min (36 * data_part_words, data_length); data_part_words = divide (data_part_bits + 35, 36, 18); call fetch_ (buffer_data_ptr, data_part_words, data_address - bce_probe_data.address.wordnum, code); if code ^= 0 then call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name); display_buffer_ptr = addwordno (buffer_data_ptr, -divide (bits_left_over, 36, 17)); call display (display_buffer_ptr, data_part_bits + bits_left_over, data_label, mode, data_bits_done, data_part_bits < data_length); data_length = data_length - data_part_bits; data_address = data_address + data_part_words; bits_left_over = data_part_bits - data_bits_done; data_label = data_label + data_part_words - divide (bits_left_over, 36, 17); if bits_left_over > 0 then substr (left_from_before, length (left_from_before) - bits_left_over + 1) = substr (buffer, length (buffer) - bits_left_over + 1); /* scroll bits */ end; end; go to request_done; end; %page; do_request (dot_req /* dot_req */): call check_no_more_args; call ioa_ ("probe: Using ^[breakpoint info^;Multics image^;bce^], dbr = ^24.3b", examine_mode, my_dbr); go to request_done; %page; do_request (ds_req /* ds_req */): go to do_request (display_req /* display_req */); %page; do_request (l_req /* l_req */): go to do_request (let_req /* let_req */); %page; do_request (let_req /* let_req */): begin; dcl data_length fixed bin (24); /* in bits */ dcl register bit (data_length) based (bce_probe_data.address.reg_ptr); /* overlay to overwrite register */ dcl starting_bit fixed bin; /* first bit in buffer containing data to move into patch area */ call get_address; starting_bit = 1; if bce_probe_data.address.type = Disk then do; if bce_probe_data.address.wordnum < 0 | bce_probe_data.address.wordnum > 1023 then call line_error (Bad_page_offset); call read_disk (bce_probe_data.address.pvtx, bce_probe_data.address.record_num, addr (buffer), code); if code ^= 0 then call line_error_arg_code (code, Reading_disk, bce_probe_data.address.error_name); starting_bit = bce_probe_data.address.wordnum * 36 + 1; end; call pass_white; data_length = 0; if substr (line, 1, 1) ^= "=" then call line_error (Missing_equals); line_len = line_len - 1; line_ptr = addcharno (line_ptr, 1); call get_value; if starting_bit + data_length > length (buffer) then go to let_values_too_long; substr (buffer, starting_bit + data_length, value.length) = substr (value.data, 1, value.length); data_length = data_length + value.length; call pass_white; do while (substr (line, 1, 1) ^= ";" & substr (line, 1, 1) ^= " " /* NL */); call get_value; if starting_bit + data_length > length (buffer) then let_values_too_long: call line_error (Values_being_let_too_long); substr (buffer, starting_bit + data_length, value.length) = substr (value.data, 1, value.length); data_length = data_length + value.length; call pass_white; end; if bce_probe_data.address.type = Virtual then do; call bce_appending_simulation$put_virtual (bce_probe_data.my_seg_info_ptr, bce_probe_data.address.wordnum, divide (data_length, 36, 18), addr (buffer), code); if code ^= 0 then go to let_bad_access; end; else if bce_probe_data.address.type = Absolute then do; call bce_appending_simulation$put_absolute (bce_probe_data.address.wordnum, divide (data_length, 36, 18), addr (buffer), code); if code ^= 0 then let_bad_access: call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name); end; else if bce_probe_data.address.type = Register then do; data_length = min (data_length, bce_probe_data.address.default_len); if bce_probe_data.address.default_len > 36 then starting_bit = 72 - mod (data_length - 1, 72); else starting_bit = 36 - mod (data_length - 1, 36); register = substr (buffer, starting_bit, data_length); if examine_mode = Break_mode then do; call bce_appending_simulation$put_absolute (breakpoint_absadr, size (breakpoint_page_buffer), addr (breakpoint_page_buffer), code); if code ^= 0 then call line_error_code (code, Accessing_breakpoint_page); end; end; else do; /* Disk */ call write_disk (bce_probe_data.address.pvtx, bce_probe_data.address.record_num, addr (buffer), code); if code ^= 0 then call line_error_arg_code (code, Writing_disk, bce_probe_data.address.error_name); end; go to request_done; end; %page; do_request (list_requests_req /* list_requests_req */): call check_no_more_args; call ioa_ ("Requests are:"); call ioa_ ("before, b continue, c dbr"); call ioa_ ("display, ds let, l list_requests, lr"); call ioa_ ("mc name proc"); call ioa_ ("quit, q reset, r segno"); call ioa_ ("stack, sk status, st"); go to request_done; %page; do_request (lr_req /* lr_req */): go to do_request (list_requests_req /* list_requests_req */); %page; do_request (mc_req /* mc_req */): begin; dcl j fixed bin; dcl long bit (1) aligned; dcl ptr_from_mc ptr; dcl time char (32); call get_address; long = "0"b; call get_string; if string_len > 0 then if string = "lg" | string = "long" then long = "1"b; else call line_error (Unrecognizable_option); call check_no_more_args; mcp = addr (buffer); scup = addr (mcp -> mc.scu); call fetch_ (mcp, size (mc), 0, code); if code ^= 0 then call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name); if long then do; do j = 0 to 7; ptr_from_mc = validate_ptr (unspec (mc.prs (j))); call ioa_ ("pr^d ^4a^2x^20p^a", j, prs (j), ptr_from_mc, bce_segptr_to_name_ (ptr_from_mc)); end; call ioa_; call ioa_ ("x0 ^6o^3xx1 ^6o^3xx2 ^6o^3xx3 ^6o", fixed (mc.x (0), 18), fixed (mc.x (1), 18), fixed (mc.x (2), 18), fixed (mc.x (3), 18)); call ioa_ ("x4 ^6o^3xx5 ^6o^3xx6 ^6o^3xx7 ^6o", fixed (mc.x (4), 18), fixed (mc.x (5), 18), fixed (mc.x (6), 18), fixed (mc.x (7), 18)); call ioa_ ("a ^w q ^w e ^o", fixed (mc.a, 35), fixed (mc.q, 35), fixed (mc.e, 8)); call ioa_ ("Timer reg - ^o, Ring alarm reg - ^1.3b", fixed (mc.regs.t, 27), mc.regs.ralr); if mc.fault_reg ^= "0"b then /* display fault reg if present */ call ioa_ ("Fault reg - ^12.3b", mc.fault_reg); end; call ioa_ ("^/SCU Data:^/"); call bce_display_scu_ (scup, bce_probe_data.address.wordnum + wordno (scup) - wordno (mcp), "0"b); if mc.fault_time then do; /* print out time of day if available */ call date_time_ (fixed (mc.fault_time, 71), time); call ioa_ ("Time stored: ^a (^18.3b)", time, mc.fault_time); end; call ioa_ ("Ring:^10x^o", fixed (scu.ppr.prr, 3)); if substr (scu.even_inst, 28, 1) & long then do; /* if bit 27 of instruction on display spl data */ call ioa_ ("^/EIS Pointers and Lengths:^/"); call ioa_ ("^6x^-^w ^w ^w ^w^/^-^w ^w ^w ^w", mc.eis_info (0), mc.eis_info (1), mc.eis_info (2), mc.eis_info (3), mc.eis_info (4), mc.eis_info (5), mc.eis_info (6), mc.eis_info (7)); end; go to request_done; end; %page; do_request (name_req /* name_req */): begin; dcl segnum fixed bin (15); /* segnum supplied */ call get_string; if string_len = 0 then call line_error (Segment_number_missing); segnum = cv_integer_string_check_ (string, Base8, code); if code ^= 0 then call line_error (Bad_octal_value); call check_no_more_args; call ioa_ ("^a", bce_segnum_to_name_ (segnum)); go to request_done; end; %page; do_request (proc_req /* proc_req */): begin; dcl apte_num fixed bin; dcl 1 my_apte aligned like apte; call get_string; if string_len = 0 then call line_error (Apte_number_missing); apte_num = cv_integer_string_check_ (string, Base10, code); if apte_num < 1 | code ^= 0 then call line_error (Bad_decimal_value); call check_no_more_args; tcmp = addr (tc_data$); call bce_appending_simulation$new_segment (segno (tcmp), bce_probe_data.my_seg_info_ptr, code); if code ^= 0 then go to bad_apte; aptep = addr (my_apte); call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, wordno (addr (tcm.apt)) + (apte_num - 1) * size (apte), size (apte), aptep, code); if code ^= 0 then go to bad_apte; if apte.state = Empty_apte then bad_apte: call line_error (Bad_apte); call ioa_ ("dbr = ^24.3b", unspec (apte.dbr)); call new_dbr (unspec (apte.dbr)); go to request_done; end; %page; do_request (q_req /* q_req */): go to do_request (quit_req /* quit_req */); %page; do_request (quit_req /* quit_req */): call check_no_more_args; go to finish; %page; do_request (r_req /* r_req */): go to do_request (reset_req /* reset_req */); %page; do_request (reset_req /* reset_req */): begin; dcl bkpt_num fixed bin; /* loop counter */ dcl instr_ptr ptr; /* to instruction to set break at */ call pass_white; instr_ptr = null; if line_len > 0 then if substr (line, 1, 1) ^= ";" & substr (line, 1, 1) ^= " " /* nl */ then do; call get_address; if bce_probe_data.address.type ^= Virtual then call line_error (Address_type_must_be_virtual); instr_ptr = addrel (baseptr (bce_probe_data.address.segnum), bce_probe_data.address.wordnum); end; call check_no_more_args; if instr_ptr = null then do; if breakpoint_at = null then call line_error (No_current_break); instr_ptr = breakpoint_at; bce_probe_data.address.segnum = segno (instr_ptr); bce_probe_data.address.wordnum = wordno (instr_ptr); bce_probe_data.address.type = Virtual; call bce_appending_simulation$new_segment (bce_probe_data.address.segnum, bce_probe_data.my_seg_info_ptr, code); if code ^= 0 then go to reset_bad_access; end; sltp = addr (crash_slt$); sltep = addr (slt.seg (bce_probe_data.address.segnum)); if ^slte.breakpointable then call line_error_arg (Segment_not_breakpointable, bce_probe_data.address.error_name); bkpt_page_ptr = addr (buffer); call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, my_seg_info.size - 1024, 1024, bkpt_page_ptr, code); if code ^= 0 then go to reset_bad_access; do bkpt_num = 1 to dimension (bkpt_page.bkpts, 1) while (bkpt_page.bkpts (bkpt_num).original_instr_ptr ^= instr_ptr); end; if bkpt_num > dimension (bkpt_page.bkpts, 1) then call line_error (No_break_set); breakpoint_ptr = addr (bkpt_page.bkpts (bkpt_num)); if instr_ptr = breakpoint_at then do; /* fix up scu data for breakpoint restart since we will move breakpoint code */ scup = addr (breakpoint_page_buffer.mc_.scu); scu.ilc = bit (bin (bce_probe_data.address.wordnum, 18), 18); /* redo instr */ call bce_appending_simulation$put_absolute (breakpoint_absadr, size (breakpoint_page_buffer), addr (breakpoint_page_buffer), code); if code ^= 0 then go to reset_bad_access; breakpoint_at = null; end; call bce_appending_simulation$put_virtual (bce_probe_data.my_seg_info_ptr, bce_probe_data.address.wordnum, 1, addr (breakpoint.original_instr), code); if code ^= 0 then go to reset_bad_access; unspec (breakpoint) = "0"b; call bce_appending_simulation$put_virtual (bce_probe_data.my_seg_info_ptr, my_seg_info.size - 1024 + wordno (breakpoint_ptr) - wordno (bkpt_page_ptr), size (breakpoint), breakpoint_ptr, code); if code ^= 0 then reset_bad_access: call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name); call ioa_ ("Break reset before ^a.", bce_segptr_to_name_ (instr_ptr)); go to request_done; end; %page; do_request (segno_req /* segno_req */): begin; dcl segname char (32); dcl segnum fixed bin (15); /* segnum supplied */ call get_string; if string_len = 0 then call line_error (Name_missing); segname = string; call check_no_more_args; call bce_name_to_segnum_ (segname, segnum, code); if code ^= 0 then call line_error_arg_code (code, Name, segname); call ioa_ ("^o", segnum); go to request_done; end; %page; do_request (sk_req /* sk_req */): go to do_request (stack_req /* stack_req */); %page; do_request (st_req /* st_req */): go to do_request (status_req /* status_req */); %page; do_request (stack_req /* stack_req */): begin; dcl current_sp ptr; dcl last_sp ptr; dcl prev_sp ptr; call get_address; if bce_probe_data.address.type ^= Virtual then call line_error (Address_type_must_be_virtual); call check_no_more_args; prev_sp = baseptr (bce_probe_data.address.segnum); current_sp = ptr (baseptr (bce_probe_data.address.segnum), bce_probe_data.address.wordnum); sb, sp = addr (buffer); call fetch_ (sb, size (stack_header), -bce_probe_data.address.wordnum, code); if code ^= 0 then go to stack_bad_access; last_sp = validate_ptr (unspec (stack_header.stack_end_ptr)); if wordno (current_sp) = 0 then current_sp = validate_ptr (unspec (stack_header.stack_begin_ptr)); do while ("1"b); if wordno (current_sp) < wordno (prev_sp) + 16 | segno (current_sp) ^= segno (last_sp) | wordno (current_sp) >= wordno (last_sp) then do; call ioa_ ("Bad next stack frame ptr ^p", current_sp); go to request_done; end; call fetch_ (sp, size (stack_frame), wordno (current_sp) - bce_probe_data.address.wordnum, code); if code ^= 0 then stack_bad_access: call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name); call ioa_ ("frame ptr: ^p", current_sp); call ioa_ ("arg ptr: ^p", validate_ptr (unspec (stack_frame.arg_ptr))); call ioa_ ("return ptr: ^a", bce_segptr_to_name_ (validate_ptr (unspec (stack_frame.return_ptr)))); call ioa_ ("entry ptr: ^a^/", bce_segptr_to_name_ (validate_ptr (unspec (stack_frame.entry_ptr)))); prev_sp = current_sp; current_sp = validate_ptr (unspec (stack_frame.next_sp)); end; go to request_done; end; %page; do_request (status_req /* status_req */): begin; dcl any_breaks bit (1) aligned; dcl segnum fixed bin (15); call pass_white; segnum = -1; call get_string; if string_len > 0 then do; segnum = cv_integer_string_check_ (string, Base8, code); if code ^= 0 then do; /* name? */ call bce_name_to_segnum_ (string, segnum, code); if code ^= 0 then call line_error (Unrecognizable_address); end; end; call check_no_more_args; any_breaks = "0"b; if segnum < 0 then do; sltp = addr (crash_slt$); do segnum = slt.first_sup_seg to slt.last_sup_seg, slt.first_init_seg to slt.last_init_seg; call status (segnum, "1"b, any_breaks); end; end; else call status (segnum, "0"b, any_breaks); if ^any_breaks then call ioa_ ("No breaks set."); go to request_done; end; %page; request_done: end; finish: return; %page; check_no_more_args: proc; /* make sure that only white space follows */ call pass_white; if line_len > 0 then if substr (line, 1, 1) ^= ";" & substr (line, 1, 1) ^= " " then call line_error (Unexpected_args_follow); string_len = 0; /* don't confuse error messages */ return; end; %page; display: proc (p_data_ptr, p_data_bit_lth, p_word_label, mode, data_bits_done, partial); /* display a buffer in the current mode for the given bit length */ dcl data_area bit (4 * 36) aligned; /* area in whcih to place and nicely align data for display */ dcl data_area_ptr ptr; /* ptr to place in data_area to move */ dcl data_bits_done fixed bin (24); dcl data_in_ascii (item_num) char (1) unal based (addr (data_area)); dcl data_in_decimal (item_num) fixed bin (35) aligned based (addr (data_area)); dcl data_in_octal (item_num) bit (36) aligned based (addr (data_area)); dcl data_in_pointer (item_num) ptr aligned based (addr (data_area)); dcl data_bit_lth fixed bin (24); /* to display this line */ dcl data_ptr ptr; /* to user area to move and display for this line */ dcl item_num fixed bin; /* how many display items on this line */ dcl mode fixed bin parameter;/* display mode */ dcl p_data_bit_lth fixed bin (24) parameter; /* total bits to display */ dcl p_data_ptr ptr parameter; /* to user area to move and display */ dcl p_word_label fixed bin (26) parameter; /* address label for first word, auto incr, < 0 => no label */ dcl partial bit (1) aligned; /* if we approach the end of data and we can not print a full line or instruction, stop and return how much done */ dcl this_data_lth fixed bin; /* data to move for this line */ dcl user_data bit (this_data_lth) based (data_ptr); /* data being moved for this line */ dcl word_label fixed bin (26); /* label for this line */ data_bit_lth = p_data_bit_lth; data_bits_done = 0; data_ptr = p_data_ptr; word_label = p_word_label; do while (data_bit_lth > 0); this_data_lth = min (4 * 36, data_bit_lth); data_area = "0"b; if mode = Ascii then data_area_ptr = addbitno (addr (data_area), 8 - mod (this_data_lth - 1, 9)); else if mode = Pointer then data_area_ptr = addbitno (addr (data_area), 71 - mod (this_data_lth - 1, 72)); else data_area_ptr = addbitno (addr (data_area), 35 - mod (this_data_lth - 1, 36)); data_area_ptr -> user_data = user_data; /* copy user data right aligned into buffer */ if mode = Ascii then item_num = divide (this_data_lth + 8, 9, 17); else if mode = Pointer then item_num = divide (this_data_lth + 71, 72, 17); else item_num = divide (this_data_lth + 35, 36, 17); if partial & this_data_lth < 4 * 36 then return; /* stop when we can't be sure all of data is present */ if mode = Ascii then call ioa_ ("^[^9o ^;^s^]^v(^1a^)", word_label >= 0, word_label, item_num, data_in_ascii); else if mode = Decimal then call ioa_ ("^[^9o ^;^s^]^v(^12d ^)", word_label >= 0, word_label, item_num, data_in_decimal); else if mode = Octal then call ioa_ ("^[^9o ^;^s^]^v(^w ^)", word_label >= 0, word_label, item_num, data_in_octal); else if mode = Pointer then call ioa_ ("^[^9o ^;^s^]^v(^18p ^)", word_label >= 0, word_label, item_num, data_in_pointer); else if mode = Instruction then do; call bce_display_instruction_ (data_area_ptr, item_num, word_label); this_data_lth = item_num * 36; end; data_bit_lth = data_bit_lth - this_data_lth; data_ptr = addbitno (data_ptr, this_data_lth); if word_label >= 0 then word_label = word_label + divide (this_data_lth, 36, 17); data_bits_done = data_bits_done + this_data_lth; end; return; end; %page; function: proc (entry_var, num_args); /* extracts from the line num_args args. A call is generated to the routine supplied with these char strings. */ dcl arg_index fixed bin; /* loop var */ dcl entry_var entry variable; /* routine to call */ dcl num_args fixed bin; /* number of args that we must find */ arg_list.twice_num_args = num_args * 4; /* 2 * because its a rule; 2 * for ptr and len for each char str arg */ call pass_white; if line_len = 0 then go to arg_list_missing; if substr (line, 1, 1) ^= "(" then arg_list_missing: call line_error (Function_arg_list_missing); do arg_index = 1 to num_args; line_len = line_len - 1; /* pass ( or , */ line_ptr = addcharno (line_ptr, 1); call get_string; if string_len = 0 then go to arg_missing; arg_str_ptrs (arg_index) = string_ptr; arg_str_lens (arg_index) = string_len; call pass_white; if line_len = 0 then go to arg_missing; if arg_index = num_args then if substr (line, 1, 1) ^= ")" then call line_error (Improper_arg_list_end_for_function); else ; else if substr (line, 1, 1) ^= "," then arg_missing: call line_error (Function_argument_missing); end; line_len = line_len - 1; /* pass ) */ line_ptr = addcharno (line_ptr, 1); call cu_$generate_call (entry_var, addr (arg_list)); return; end; %page; fetch_: proc (data_ptr, data_lth, address_offset, code); dcl address_offset fixed bin (26) parameter; dcl buffer (1024) bit (36) aligned; dcl code fixed bin (35) parameter; dcl data_area (data_lth) bit (36) aligned based; dcl data_lth fixed bin (18); dcl data_ptr ptr; dcl error_table_$boundviol fixed bin (35) ext static; if bce_probe_data.address.type = Absolute then call bce_appending_simulation$get_absolute (bce_probe_data.address.wordnum + address_offset, data_lth, data_ptr, code); else if bce_probe_data.address.type = Virtual then call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, bce_probe_data.address.wordnum + address_offset, data_lth, data_ptr, code); else if bce_probe_data.address.type = Disk then if bce_probe_data.address.wordnum + address_offset < 0 | bce_probe_data.address.wordnum + address_offset + data_lth > 1024 then code = error_table_$boundviol; else do; call read_disk (bce_probe_data.address.pvtx, bce_probe_data.address.record_num, addr (buffer), code); data_ptr -> data_area = addrel (addr (buffer), bce_probe_data.address.wordnum + address_offset) -> data_area; end; else code = error_table_$bad_arg; return; end; %page; get_address: proc; /* Find the desired address of an object. */ dcl component char (32); dcl component_delim_pos fixed bin; /* Position of "$". */ dcl new_segnum fixed bin (15); dcl new_wordnum fixed bin (26); /* after incrementing */ dcl number fixed bin (35); /* result of ascii - numeric conversions */ dcl offset char (16); dcl offset_delim_pos fixed bin; /* Position of "|", "+", or "-". */ dcl seg_id char (32); call get_string; if string_len = 0 then call line_error (Address_missing); if substr (string, 1, 1) = "." then do; /* relative address */ if bce_probe_data.address.type = 0 then call line_error (No_current_address); if string_len = 1 then go to done; /* same addr */ if bce_probe_data.address.type = Register then call line_error (No_offset_may_be_added_to_register_addresses); if string_len < 3 then call line_error (Missing_offset); if substr (string, 2, 1) ^= "+" & substr (string, 2, 1) ^= "-" then call line_error (Dot_must_be_followed_by_plus_or_minus); number = cv_integer_string_check_ (substr (string, 3), Base8, code); if code ^= 0 then call line_error (Bad_octal_value); if substr (string, 2, 1) = "+" then new_wordnum = bce_probe_data.address.wordnum + number; else new_wordnum = bce_probe_data.address.wordnum - number; if new_wordnum < 0 then call line_error (Offset_makes_address_negative); bce_probe_data.address.wordnum = new_wordnum; go to done; end; /* a new address is desired - wipe out old address */ bce_probe_data.address.type = 0; bce_probe_data.address.default_mode = Octal; bce_probe_data.address.default_len = 36; component_delim_pos = index (string, "$"); offset_delim_pos = search (string, "|+-"); if component_delim_pos > 0 | offset_delim_pos > 0 then do; /* Virtual address */ if offset_delim_pos < component_delim_pos & offset_delim_pos > 0 then call line_error (Invalid_word_offset); if component_delim_pos > 0 then do; if component_delim_pos = 1 then call line_error (Missing_seg_id); if offset_delim_pos > 0 then do; if offset_delim_pos = string_len then call line_error (Missing_word_offset); if offset_delim_pos = component_delim_pos + 1 then call line_error (Missing_component); seg_id = substr (string, 1, component_delim_pos - 1); component = substr (string, component_delim_pos + 1, offset_delim_pos - component_delim_pos - 1); offset = substr (string, offset_delim_pos + 1); end; else do; if component_delim_pos = string_len then call line_error (Missing_component); seg_id = substr (string, 1, component_delim_pos - 1); component = substr (string, component_delim_pos + 1); offset = "0"; end; end; else do; if substr (string, offset_delim_pos, 1) = "+" | substr (string, offset_delim_pos, 1) = "-" then call line_error (Plus_or_minus_allowed_only_with_an_entry_name); if offset_delim_pos = string_len then call line_error (Missing_word_offset); if offset_delim_pos = 1 then call line_error (Missing_seg_id); seg_id = substr (string, 1, offset_delim_pos - 1); component = ""; offset = substr (string, offset_delim_pos + 1); end; if component = "" then bce_probe_data.address.error_name = seg_id; else bce_probe_data.address.error_name = rtrim (seg_id) || "$" || rtrim (component); number = cv_integer_string_check_ (seg_id, Base8, code); if code = 0 then bce_probe_data.address.segnum = number; else do; call bce_name_to_segnum_ (seg_id, bce_probe_data.address.segnum, code); if code ^= 0 then call line_error_code (code, Segment_name); end; if component ^= "" then do; call bce_component_to_wordnum_ (bce_probe_data.address.segnum, seg_id, component, new_segnum, new_wordnum, code); if code ^= 0 then call line_error_code (code, Bad_component_name); bce_probe_data.address.segnum = new_segnum; bce_probe_data.address.wordnum = new_wordnum; end; else bce_probe_data.address.wordnum = 0; number = cv_integer_string_check_ (offset, Base8, code); if code ^= 0 | number < 0 then call line_error (Bad_segment_offset); else do; if substr (string, offset_delim_pos, 1) ^= "-" then bce_probe_data.address.wordnum = bce_probe_data.address.wordnum + number; else do; if bce_probe_data.address.wordnum - number < 0 then call line_error (Offset_makes_address_negative); else bce_probe_data.address.wordnum = bce_probe_data.address.wordnum - number; end; bce_probe_data.address.type = Virtual; end; goto done; end; if string = "reg" | string = "register" then do; call function (reg_address, 1); go to done; end; if string = "disk" then do; call function (disk_address, 3); go to done; end; number = cv_integer_string_check_ (string, Base8, code); /* must be just a number */ if code = 0 then do; bce_probe_data.address.type = Absolute; bce_probe_data.address.wordnum = number; bce_probe_data.address.error_name = string; go to done; end; else call line_error (Unrecognizable_address); done: if bce_probe_data.address.type = Virtual then do; call bce_appending_simulation$new_segment (bce_probe_data.address.segnum, bce_probe_data.my_seg_info_ptr, code); if code ^= 0 then call line_error_code (code, Accessing_segment); end; return; %page; disk_address: proc (disk_name_ptr, disk_name_len, disk_record_str_ptr, disk_record_str_len, disk_offset_str_ptr, disk_offset_str_len); dcl disk_name char (disk_name_len) based (disk_name_ptr); dcl disk_name_len fixed bin; dcl disk_name_ptr ptr; dcl disk_offset_str char (disk_offset_str_len) based (disk_offset_str_ptr); dcl disk_offset_str_len fixed bin; dcl disk_offset_str_ptr ptr; dcl disk_record_str char (disk_record_str_len) based (disk_record_str_ptr); dcl disk_record_str_len fixed bin; dcl disk_record_str_ptr ptr; pvtp = addr (pvt$); pvt_arrayp = addr (pvt.array); call lookup_disk; bce_probe_data.address.error_name = disk_name; bce_probe_data.address.record_num = cv_integer_string_check_ (disk_record_str, Base8, code); if code ^= 0 | bce_probe_data.address.record_num < first_rec_num (pvt_array (bce_probe_data.address.pvtx).device_type) | bce_probe_data.address.record_num > last_sv_rec_num (pvt_array (bce_probe_data.address.pvtx).device_type) then call line_error_arg (Bad_disk_record, disk_record_str); bce_probe_data.address.wordnum = cv_integer_string_check_ (disk_offset_str, Base8, code); if code ^= 0 | bce_probe_data.address.wordnum < 0 then call line_error_arg (Bad_page_offset, disk_offset_str); bce_probe_data.address.type = Disk; return; lookup_disk: proc; /* find the disk in the pvt */ dcl devname char (8); devname = disk_name; call disk_name_pvtx (devname, bce_probe_data.address.pvtx, code); if code ^= 0 then do; bad_disk_name: call line_error_arg_code (code, No_such_drive, disk_name); return; end; end; end; %page; reg_address: proc (reg_name_ptr, reg_name_len); dcl reg_index fixed bin; /* loop var */ dcl reg_name char (reg_name_len) based (reg_name_ptr); dcl reg_name_len fixed bin; dcl reg_name_ptr ptr; if examine_mode = Bce_mode then call line_error (Register_address_not_allowed); bce_probe_data.address.error_name = reg_name; do reg_index = 1 to dimension (reg_names, 1) while (reg_names (reg_index) ^= reg_name); end; if reg_index > dimension (reg_names, 1) then call line_error_arg (Unknown_register, reg_name); bce_probe_data.address.reg_ptr = reg_ptrs (reg_index); bce_probe_data.address.default_mode = reg_modes (reg_index); bce_probe_data.address.default_len = reg_lens (reg_index); bce_probe_data.address.type = Register; return; end; end; %page; get_string: proc; /* Set string_(ptr len) to indicate the next string of chars */ call pass_white; string_ptr = line_ptr; string_len = search (line, "=,""(); "); /* ; NL (delimiters) FF SP VT HT (whitespace) */ if string_len = 0 then string_len = line_len; else string_len = string_len - 1; line_len = line_len - string_len; line_ptr = addcharno (line_ptr, string_len); return; end; %page; get_value: proc; /* Setup value given the next set of strings */ dcl ascii_value char (256) aligned based (addr (value.data)); dcl decimal_value fixed bin (35) based (addr (value.data)); dcl number fixed bin (35); /* result of ascii to numeric conversions */ dcl pointer_value ptr based (addr (value.data)); dcl seg_id_len fixed bin; /* length of segid portion of virtual pointer */ dcl segnum fixed bin (15); /* for virtual pointer */ dcl substr_len fixed bin; /* portion of ascii string being extracted */ call pass_white; if substr (line, 1, 1) = ";" | substr (line, 1, 1) = " " /* NL */ then call line_error (Missing_value); string_len = 0; /* don't confuse error routines */ if substr (line, 1, 1) = """" then do; /* ascii string */ value.type = Ascii; value.length = 0; do while (substr (line, 1, 1) = """"); line_ptr = addcharno (line_ptr, 1); line_len = line_len - 1; substr_len = index (line, """"); if substr_len = 0 then call line_error (Unmatched_quotes); if substr (line, substr_len, 2) ^= """""" then do; substr (ascii_value, value.length + 1, substr_len - 1) = substr (line, 1, substr_len - 1); value.length = value.length + (substr_len - 1); end; else do; substr (ascii_value, value.length + 1, substr_len) = substr (line, 1, substr_len); /* take one " */ value.length = value.length + substr_len; end; line_ptr = addcharno (line_ptr, substr_len); line_len = line_len - substr_len; end; substr (ascii_value, value.length + 1) = " "; value.length = divide (value.length + 3, 4, 17) * 36; /* integral num of words */ return; end; call get_string; if string_len = 0 then call line_error (Missing_value); seg_id_len = index (string, "|"); if seg_id_len > 0 then do; /* pointer? */ if seg_id_len = 1 then call line_error (Missing_seg_id); segnum = cv_integer_string_check_ (substr (string, 1, seg_id_len - 1), Base8, code); if code ^= 0 then do; /* segname? */ call bce_name_to_segnum_ (substr (string, 1, seg_id_len - 1), segnum, code); if code ^= 0 then call line_error_code (code, Segment_name); end; if seg_id_len = string_len then call line_error (Missing_word_offset); number = cv_integer_string_check_ (substr (string, seg_id_len + 1), Base8, code); if code ^= 0 | number < 0 | number >= 256 * 1024 then call line_error (Bad_segment_offset); value.type = Pointer; value.length = 72; pointer_value = ptr (baseptr (segnum), number); return; end; number = cv_integer_string_check_ (string, Base10, code); if code = 0 then do; /* just a number */ value.type = Decimal; value.length = 36; decimal_value = number; return; end; else call line_error (Unrecognizable_value); end; %page; line_error: proc (message); /* Report syntax error in line */ dcl arg char (*) parameter; /* argument of function to print */ dcl code fixed bin (35) parameter; dcl int_code fixed bin (35); /* internal version of sometimes supplied parameter */ dcl message char (*) parameter; /* message text for error message */ int_code = 0; go to error; line_error_code: entry (code, message); int_code = code; error: call com_err_ (int_code, me, "^a^[: ^a^;^s^]", message, string_len > 0, string); line_len = 0; /* abort */ go to request_done; line_error_arg: entry (message, arg); int_code = 0; go to arg_error; line_error_arg_code: entry (code, message, arg); int_code = code; arg_error: call com_err_ (int_code, me, "^a: ^a", message, arg); line_len = 0; go to request_done; end; %page; new_dbr: proc (dbr_value); /* Change the dbr_value for simulation. Also, set up various segments. */ dcl dbr_value bit (72) aligned parameter; call bce_appending_simulation$new_dbr (dbr_value, bce_probe_data.last_segnum, code); if code = 0 then do; call pc$nullify (get_ptrs_$given_segno (segno (addr (crash_slt$)))); /* free previous contents */ call bce_appending_simulation$new_segment (segno (addr (slt$)), bce_probe_data.my_seg_info_ptr, code); if code ^= 0 then call com_err_ (code, me, "no slt"); else do; call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, 0, (my_seg_info.sdwi.size), addr (crash_slt$), code); if code ^= 0 then call com_err_ (code, me, "cannot copy slt"); end; call pc$nullify (get_ptrs_$given_segno (segno (addr (crash_name_table$)))); /* free previous contents */ call bce_appending_simulation$new_segment (segno (addr (name_table$)), bce_probe_data.my_seg_info_ptr, code); if code ^= 0 then call com_err_ (code, me, "no name_table"); else do; call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, 0, (my_seg_info.sdwi.size), addr (crash_name_table$), code); if code ^= 0 then call com_err_ (code, me, "cannot copy name_table"); end; call pc$nullify (get_ptrs_$given_segno (segno (addr (crash_definitions_$)))); /* free previous contents */ call bce_appending_simulation$new_segment (segno (addr (definitions_$)), bce_probe_data.my_seg_info_ptr, code); if code ^= 0 then call com_err_ (code, me, "no definitions_"); else do; call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, 0, (my_seg_info.sdwi.size), addr (crash_definitions_$), code); if code ^= 0 then call com_err_ (code, me, "cannot copy definitions_"); end; call pc$nullify (get_ptrs_$given_segno (segno (addr (crash_lot$)))); /* free previous contents */ call bce_appending_simulation$new_segment (segno (addr (lot$)), bce_probe_data.my_seg_info_ptr, code); if code ^= 0 then call com_err_ (code, me, "no lot"); else do; call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, 0, (my_seg_info.sdwi.size), addr (crash_lot$), code); if code ^= 0 then call com_err_ (code, me, "cannot copy lot"); end; end; else call com_err_ (code, me, "No virtual addresses will be allowed because of error initting appending simulation."); bce_probe_data.address.type = 0; /* no current */ return; end; %page; pass_white: proc; /* pass by whitespace in request line */ dcl white_len fixed bin; white_len = verify (line, " "); /* FF SP VT HT */ if white_len = 0 then line_len = 0; else if white_len > 1 then do; line_len = line_len - (white_len - 1); line_ptr = addcharno (line_ptr, white_len - 1); end; return; end; %page; status: proc (segnum, brief, any_breaks); dcl any_breaks bit (1) aligned; dcl bkpt_num fixed bin; dcl brief bit (1) aligned parameter; dcl 1 packed_ptr aligned, 2 bitnum fixed bin (6) uns unal, 2 segnum fixed bin (12) uns unal, 2 wordnum fixed bin (18) uns unal; dcl segnum fixed bin (15) parameter; sltp = addr (crash_slt$); sltep = addr (slt.seg (segnum)); if ^slte.breakpointable then if brief then return; else call line_error_arg (Segment_not_breakpointable, bce_probe_data.address.error_name); call bce_appending_simulation$new_segment (segnum, bce_probe_data.my_seg_info_ptr, code); if code ^= 0 then if brief then return; else go to status_bad_access; bkpt_page_ptr = addr (buffer); call bce_appending_simulation$get_virtual (bce_probe_data.my_seg_info_ptr, my_seg_info.size - 1024, 1024, bkpt_page_ptr, code); if code ^= 0 then if brief then return; else status_bad_access: call line_error_arg_code (code, Accessing_segment, bce_probe_data.address.error_name); do bkpt_num = 1 to dimension (bkpt_page.bkpts, 1); unspec (packed_ptr) = unspec (bkpt_page.bkpts (bkpt_num).original_instr_ptr); if packed_ptr.segnum = segnum & packed_ptr.bitnum = 0 then do; any_breaks = "1"b; if brief then do; call ioa_ ("Breaks set in ^a.", bce_segnum_to_name_ (segnum)); return; end; else call ioa_ ("Break before ^a.", bce_segptr_to_name_ ((bkpt_page.bkpts (bkpt_num).original_instr_ptr))); end; end; return; end; %page; validate_ptr: proc (ptr_bits) returns (ptr); /* See if dump ptr is good, or make null */ dcl my_ptr ptr; dcl 1 my_ptr_bits aligned like its based (addr (ptr_bits)); dcl ptr_bits bit (72) aligned parameter; if my_ptr_bits.its_mod = ITS_MODIFIER & my_ptr_bits.pad1 = "0"b & my_ptr_bits.pad2 = "0"b & my_ptr_bits.mod = "0"b then unspec (my_ptr) = ptr_bits; else my_ptr = null; return (my_ptr); end; %page; %include apte; %page; %include bce_appending_seg_info; %page; %include bce_breakpoint_page; %page; %include bce_subsystem_info_; %page; %include collection_1_phases; %page; %include flagbox; %page; %include fs_dev_types; %page; %include hc_lock; %page; %include its; %page; %include pvt; %page; %include pvte; %page; %include slt; %page; %include slte; %page; %include stack_frame; %page; %include stack_header; %page; %include state_equs; %page; %include tcm; %page; %include toe_hold; end; 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