binoct_tv_.alm 11/04/82 1959.8rew 11/04/82 1633.7 5373 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " Transfer vector for binoct in lang_util " entry binoct binoct: tra |[binoct] end  comp_8_to_ascii_.alm 11/04/82 1959.8rew 11/04/82 1633.7 13527 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " This procedure returns a character string representing the input " bit string as comp-8 format. " " dcl comp_8_to_ascii_ entry (bit (*), char (*)); " call comp_8_to_ascii_ (bit_string, char_string); " " bit_string bit string of comp-8 (INPUT) " char_string ASCII representation of comp-8 (OUTPUT) " name comp_8_to_ascii_ segdef comp_8_to_ascii_ comp_8_to_ascii_: epp2 ap|2,* pr2 = address of bit string epp3 ap|4,* pr3 = address of character string ldx3 0,du compute address of descriptors lxl2 ap|0 get arg list header word canx2 =o4,du tnz *+2 no display ptr ldx3 2,du add 2 word offset if display ptr ldq ap|6,x3* q = length of bit string anq =o000077777777 get size portion qls 1 convert bits to digits div 9,dl length*2/9 lda ap|8,x3* a = length of character string ana =o000077777777 get size portion of descriptor mvt (pr,rl),(pr,rl),fill(17) desc4a pr2|0,ql desc9a pr3|0,al arg table short_return table: aci "0123456789x+x-xx" end  db_assign.pl1 11/04/82 1959.8rew 11/04/82 1628.2 186984 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_assign: proc (il, lin, ill, data_ptr, sntp, db_mc_ptr, old_type, a_cur_size, a_old_size, print_mode, dec_default); %include db_ext_stat_; dcl db_mc_ptr ptr; dcl il char (132) aligned, (lin, ill) fixed bin, print_mode fixed bin, data_ptr ptr; dcl a_cur_size fixed bin; dcl cur_size fixed bin; dcl a_old_size fixed bin; dcl old_type fixed bin; dcl old_size fixed bin; dcl new_size fixed bin; dcl last_char fixed bin; /* ill -1 (line ends with new_line) */ dcl com_err_ entry options (variable), cu_$level_get entry returns (fixed bin), db_get_count ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin), db_get_count$dec ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin), db_regs$get ext entry (ptr, char (4), bit (72), fixed bin), db_sym ext entry (char (72) var, ptr, ptr, fixed bin, fixed bin, char (1) aligned, char (*) aligned, fixed bin, fixed bin, fixed bin), print_text_$format ext entry (ptr, char (*) var), hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)), hcs_$delete_acl_entries entry (char (*)aligned, char (*)aligned, ptr, fixed, fixed bin (35)), get_group_id_ entry returns (char (32) aligned), hcs_$fs_get_mode ext entry (ptr, fixed bin (5), fixed bin (35)), ioa_$ioa_stream ext entry options (variable), db_parse_arg ext entry (char (132) aligned, fixed bin, fixed bin, ptr, fixed bin, fixed bin); dcl fix_bit entry (bit (*) aligned, fixed bin) returns (fixed bin); dcl fix_bit$double entry (bit (*) aligned, fixed bin) returns (fixed bin (71)); dcl access_ok fixed bin (1), base fixed bin, code fixed bin, code35 fixed bin (35), emode fixed bin (5), off fixed bin, offset fixed bin, op fixed bin, rb (0:2) fixed bin, rep_count fixed bin, size fixed bin, max_size fixed bin, tag fixed bin, type fixed bin, (i, j, k) fixed bin; dcl index_start_no fixed bin; /* index in il of the beginning of a type 1 no. string */ dcl 1 delete_acl aligned, 2 access_name char (32), 2 status_code fixed bin (35); dcl 1 segment_acl aligned, 2 access_name char (32), 2 modes bit (36) init ("111000000000000000000000000000000000"b), 2 zero_pad bit (36) init ("0"b), 2 status_code fixed bin (35); dcl (old_sign, new_sign) fixed bin; dcl pad_bits fixed bin; dcl off_inc fixed bin; dcl (old_bit_off, new_bit_off) fixed bin; dcl fword fixed bin based; dcl flword float bin based; dcl two_words bit (72) based; dcl words (2) bit (36) aligned based; dcl tw_flag fixed bin init (0); dcl reg_name char (4); dcl len_ptr ptr; dcl dp ptr, tp ptr, tem (17) ptr, temp ptr, bptr ptr based; dcl packed_ptr ptr unal based; dcl (old_ptr, new_ptr) ptr; dcl ones bit (72) int static init ((72)"1"b); dcl TOO_BIG fixed bin int static init(1); dcl BAD_SYNTAX fixed bin int static init(2); dcl MISS_PAREN fixed bin int static init(3); dcl BAD_PR fixed bin int static init(4); dcl NO_REG fixed bin int static init(5); dcl NO_SYM fixed bin int static init(6); dcl OPCODE fixed bin int static init(7); dcl TAG fixed bin int static init(8); dcl SYNTAX fixed bin int static init(9); dcl BAD_REP fixed bin int static init(10); dcl mess (10) char(40) var int static init ( "Value too large", /* TOO_BIG */ "Bad syntax in instruction input", "Missing "")""", "Invalid pointer register", "Register name missing", "Variable not defined", "Bad opcode", "Bad tag", "Syntax error scanning input", "Illegal repetition factor"); dcl sign_bit bit (1) unal based; dcl dec_default bit (1) unal; /* 1 = decimal default 0 = octal default ( registers, temporaries ) */ dcl (old_word, new_word) bit (36) aligned; dcl (old_double, new_double) fixed bin (71); dcl control char (8) aligned; /* variable ioa_ control string */ dcl mode char (1) aligned, old_str char (old_size) based (dp), str char (size) based (tp), repstr char (size*rep_count) based, old_bits bit (old_size) based (dp), new_bits bit (size) based (tp), chars (0:10000) char (1) unal based, bitarr (0:10000) bit (1) unal based, sym_name char (72) aligned, opcode6 char (6) aligned, c2 char (2) aligned, c4 char (4) aligned, (name1, name2) char (72) var, db_sym_name char (72) var, (type_char, mode_char) char (1) aligned; /* The following declaration is included(temporarily) to allow * the use of the old-style names of the pointer registers. */ dcl old_pr_names (0:7) char (2) int static init ("ap", "ab", "bp", "bb", "lp", "lb", "sp", "sb"); dcl conversion condition; dcl underflow condition; dcl ffdouble fixed bin (71) based; /* used for printing double words in ^d */ dcl 1 ff aligned based, 2 (w0, w1, w2, w3, w4, w5, w6, w7) fixed bin; dcl (addr, addrel, bit, char, fixed, index, max, min, mod, null, substr, unspec, rel) builtin; dcl (abs, binary, divide, search, verify) builtin; /* */ %include db_snt; /* */ %include db_inst; /* */ %include its; /* */ dcl 1 op_mnemonic_$op_mnemonic (0:1023) ext static aligned, 2 opcode char (6) unal, 2 dtype fixed bin (2) unal, /* 0 - desc9a, 1 - descb, 2 - decimal */ 2 num_desc fixed bin (5) unal, 2 num_words fixed bin (8) unal; %include db_data_map; /* */ temp = addr (tem); /* get pointer to temporary storage */ dp = data_ptr; /* get pointer to first word to change */ cur_size = a_cur_size; old_size = a_old_size; /* If the user does not have w access on the segment, try to add w user.proj.tag */ call hcs_$fs_get_mode (dp, emode, code35); /* see if the user has write permit on the segment */ if code35 = 0 then do; if bit (emode, 5) & "00010"b then access_ok = 1; /* if write permit is there, OK */ else do; access_ok = 0; /* hasn't got write permit, change the access */ segment_acl.access_name = get_group_id_ (); call hcs_$add_acl_entries (snt.dir_name, snt.ent_name, addr (segment_acl), 1, code35); end; end; if code35 ^= 0 then do; /* Can't get write access on segment */ call com_err_ (code35, "debug", "Cannot change ^p", dp); return; end; if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "Changing ^p", dp); /* print out location changings */ last_char = ill -1; do while (get_char (lin)); rep_count = 1; if mode = "(" then call get_rep_count (rep_count); if mode = "(" then call get_instruction; /* instruction format (opcode) */ else if mode = "$" then do; /* register being used as value */ dec_default = "0"b; i = search (substr (il, lin, ill-lin+1), " ;"); if i = 0 then i = ill; else i = lin + i -1; if i-lin-1 < 1 then call error (NO_REG, ""); sym_name = substr (il, lin+1, i-lin-1); /* copy register name into temporary */ lin = i; reg_name = substr (sym_name, 1, 4); type = 1; size = 36; call db_regs$get (db_mc_ptr, reg_name, temp -> two_words, print_mode); if reg_name = "aq" then size = 72; do i = 0 to 7; if reg_name = db_data$names (i) then do; size = 72; type = 13; end; end; if size ^= 72 then tp = addrel (temp, 1); else tp = temp; call store_value; end; else do; /* call db_parse_arg to pick off the other types */ index_start_no = lin; /* patch for octal default */ type = 0; if ^dec_default then do; temp -> fword = db_get_count (il, lin, i); if i > lin then if index (", ; ", substr (il, i, 1)) ^= 0 then do; type = 1; lin = i; end; end; if type = 0 then call db_parse_arg (il, lin, ill, temp, type, size); /* scan for next item */ tp = temp; if type = -1 then goto reset; /* goto reset if ";", etc. */ if type = 1 | type = 3 then size = 36; /* arithmetic type s go in fullword */ if type = 13 then size = 72; /* pointer on double-word */ if type = 0 then do; /* a variable as input parameter */ db_sym_name = str; /* copy variable name into temporary */ call db_sym (db_sym_name, sntp, tp, offset, type, type_char, mode_char, size, max_size, code); if code ^= 0 then call error (NO_SYM, (name1)); end; call store_value; end; end; reset: if access_ok = 0 then call hcs_$delete_acl_entries (snt.dir_name, snt.ent_name, addr (segment_acl), 1, code35); return; /* */ bump: proc; /* This internal procedure is used to bump the data pointer * to the next item after the one just assigned to. */ off_inc = divide (old_size, 36, 17, 0); old_bit_off = fixed (addr (dp) -> its.bit_offset, 6); new_bit_off = old_bit_off + mod (old_size, 36); if new_bit_off > 36 then do; /* into next word */ new_bit_off = new_bit_off - 36; off_inc = off_inc + 1; /* must bump word offset */ end; dp = addrel (dp, off_inc); /* this will set bit offset */ /* to zero, so we may have */ if new_bit_off ^= 0 then /* to set it again */ addr (dp) -> its.bit_offset = bit (fixed (new_bit_off, 6), 6); rep_count = rep_count - 1; return; end bump; /* This procedure is an error exit from db_assign. It prints an error message and goes to reset. */ error: proc (mess_code, illegal_string); dcl mess_code fixed bin; /* error codes for db_assign */ dcl illegal_string char (*) aligned; /* offending character or string */ call ioa_$ioa_stream (debug_output, "^a ^a", mess (mess_code), illegal_string); goto reset; end error; /* This procedure looks for a non_blank character and sets mode to it. If mode is ";" or there are no more characters left in the line, then get_char returns "0"b. Otherwise it returns "1"b (for found next character). */ get_char: proc (index) returns (bit (1)); dcl index fixed bin; dcl i fixed; lin = index; if lin <= last_char then do; i = verify (substr (il, lin, last_char - lin + 1), " "); if i > 0 then do; lin = lin + i -1; mode = substr (il, lin, 1); if mode ^= ";" then return ("1"b); end; else lin = last_char + 1; end; return ("0"b); end get_char; /* This procedure attempts to parse an instruction of the form: ( opcode base|offset,tag ) */ get_instruction: proc; if ^get_char (lin + 1) then call error (MISS_PAREN, ""); j = search (substr (il, lin, last_char - lin + 1), " )"); /* blank or ) follows opcode */ if j = 0 then call error (MISS_PAREN, ""); opcode6 = substr (il, lin, j -1); /* copy opcode name */ lin = lin + j -1; op = -1; do i = 0 to 1023 while (op = -1); /* search for the opcode */ if opcode6 = op_mnemonic_$op_mnemonic (i).opcode then op = i; end; if op = -1 then call error (OPCODE, opcode6); if ^get_char (lin) then call error (SYNTAX, ""); base = -1; /* -1 indicates no pr specified */ if substr (il, lin+3, 1) = "|" then do; /* standard pointer register prN|NN */ if substr (il, lin, 2) ^= "pr" then call error (BAD_PR, ""); lin = lin + 2; base = index ("01234567", substr (il, lin, 1)) -1; if base = -1 then call error (BAD_PR, ""); lin = lin + 2; end; else if substr (il, lin+2, 1) = "|" then do; /* old-style pointer pp|NN */ c2 = substr (il, lin, 2); /* copy it for compare */ lin = lin + 3; /* increment index */ base = -1; do i = 0 to 7 while (base = -1); /* search for the base name */ if c2 = old_pr_names (i) then base = i; end; if base = -1 then call error (BAD_PR, ""); end; j = lin; /* check for number */ off = db_get_count (il, lin, lin); /* pick up the offset specified by the user */ if j = lin then if substr (il, lin, 1) = ")" then off = 0; /* not a number */ else call error (SYNTAX, ""); tag = 0; /* indicates tag not yet specified */ if substr (il, lin, 1) = "," then do; /* a tag was specified */ j = index (substr (il, lin+1, 4), ")"); /* find location of the ")" */ if j = 0 then call error (MISS_PAREN, ""); /* error condition */ c4 = substr (il, lin, j); /* pick up the tag field */ lin = lin+j+1; /* skip over rest of instruction input */ tag = -1; do i = 0 to 63 while (tag = -1); if db_data$tags (i) = c4 then tag = i; end; if tag = -1 then call error (TAG, c4); end; else do; if ^get_char (lin) then call error (MISS_PAREN, ""); if mode ^= ")" then call error (SYNTAX, ""); lin = lin + 1; end; do rep_count = rep_count to 1 by -1; if print_mode ^= 0 then call print_text_$format (dp, name1); k = dp -> ff.w0; /* save the old value */ if base = -1 then do; /* a base was never spec ified */ dp -> instr.offset = off; /* copy full offset into instruction */ dp -> instr.pr_bit = "0"b; /* make sure don't use base */ end; else do; dp -> instr_pr.pr = bit (fixed (base, 3)); /* copy base into instruction */ dp -> instr_pr.offset = off; /* copy offset */ dp -> instr.pr_bit = "1"b; /* turn on bit 29 */ end; dp -> instr.opcode = bit (fixed (op, 10)); /* fill in opcode */ dp -> instr.tag = bit (fixed (tag, 6)); /* fill in tag */ dp -> instr.inhibit = "0"b; i = dp -> ff.w0; /* get new value */ if print_mode ^= 0 then do; call print_text_$format (dp, name2); call ioa_$ioa_stream (debug_output, "^a^/to^/^a", name1, name2); end; dp = addrel (dp, 1); end; return; end get_instruction; /* This procedure has a value and stores it at the location given with dp. Rep_count is the number of times to repeat a given value. */ store_value: proc; len_ptr = null; if old_type = 0 then cur_size, old_size = size; else if cur_size < old_size then len_ptr = addrel (dp, -1); if type <= 4 then do; /* for arithmetic values, if not a variable specified on left, just fill in rest of word */ if old_type = 0 then old_size = 36 - fixed (addr (dp) -> its.bit_offset, 6); end; if type = 21 then do; /* character string */ if old_type ^= 21 & old_type ^= 0 then do; old_size = divide (old_size, 9, 17, 0); /* convert size from bits to chars */ cur_size = divide (cur_size, 9, 17, 0); end; if old_size <= 0 then call error (TOO_BIG, ""); size = min (old_size, size); new_size = rep_count*size; if print_mode ^= 0 then do; if rep_count > 1 then call ioa_$ioa_stream (debug_output, """^a"" to (^d)""^a""", substr (dp -> repstr, 1, new_size), rep_count, str); else call ioa_$ioa_stream (debug_output, """^a"" to ""^a""", substr (dp -> old_str, 1, cur_size), str); end; do rep_count = rep_count to 1 by -1; old_str = str; dp = addr (dp -> chars (size)); end; if len_ptr ^= null then do; /* if a varying string, update length */ len_ptr -> fword = min (new_size, old_size); cur_size = old_size; /* so we won't do it again */ end; rep_count = 1; end; else if type = 19 then do; /* bit string */ if old_type = 21 then do; /* if char string, convert size to bits */ old_size = 9*old_size; cur_size = 9*cur_size; end; size = min (old_size, size); /* bit string */ new_size = rep_count*size; do rep_count = rep_count to 1 by -1; if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, """^a""b to ""^a""b", char (substr (dp -> old_bits, 1, cur_size)), char (tp -> new_bits)); dp -> old_bits = new_bits; dp = addr (dp -> bitarr (size)); end; if len_ptr ^= null then do; len_ptr -> fword = min (new_size, old_size); cur_size = old_size; end; end; else if type = 13 then do while (rep_count > 0); /* pointer */ if old_type = 0 then dp = addrel (dp, 0); /* eliminate bit offset if not var. */ if old_size < 36 then call error (TOO_BIG, ""); if old_size < 72 then do; /* into packed ptr */ unspec (old_ptr) = unspec (dp -> packed_ptr); if size = 36 then unspec (new_ptr), unspec (dp -> packed_ptr) = unspec (tp -> packed_ptr); else unspec (new_ptr), unspec (dp -> packed_ptr) = unspec (tp -> bptr); end; else do; unspec (old_ptr) = unspec (dp -> bptr); if size = 36 then unspec (new_ptr), unspec (dp -> bptr) = unspec (tp -> packed_ptr); else unspec (new_ptr), unspec (dp -> bptr) = unspec (tp -> bptr); end; if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "^p to ^p", old_ptr, new_ptr); call bump; end; else if type = 14 then do while (rep_count > 0); /* offset variable */ if old_size < 36 then call error (TOO_BIG, ""); if print_mode ^= 0 then do; old_word = old_bits; new_word = new_bits; call ioa_$ioa_stream (debug_output, "^w to ^w", old_word, new_word); end; old_bits = new_bits; call bump; end; else if type = 1 | type = 2 then do; /* fixed bin */ if ^dec_default then do; if substr (il, index_start_no, 2) = "&d" then control = "^d to ^d"; else if old_size = 36 then control = "^w to ^w"; else control = "^o to ^o"; end; else do; /* decimal default assumed unles &o was used */ if substr (il, index_start_no, 2) = "&o" then control = "^o to ^o"; else control = "^d to ^d"; end; do while (rep_count > 0); if abs (fix_bit$double ((new_bits), size)) >= binary (2)** (old_size) then call error (TOO_BIG, ""); if dp -> sign_bit then old_sign = -1; else old_sign = 1; if tp -> sign_bit then new_sign = -1; else new_sign = 1; if print_mode ^= 0 then do; if old_size <= 36 then do; old_word = old_bits; new_word = new_bits; call ioa_$ioa_stream (debug_output, control, fix_bit (old_word, old_size), fix_bit (new_word, size)); end; else do; old_double = fix_bit$double ((old_bits), old_size); new_double = fix_bit$double ((new_bits), size); if dec_default then call ioa_$ioa_stream (debug_output, control, addr (old_double) -> ffdouble, addr (new_double) -> ffdouble); else call ioa_$ioa_stream (debug_output, "^w^w to ^w^w", addr (old_double) -> ff.w0, addr (old_double) -> ff.w1, addr (new_double) -> ff.w0, addr (new_double) -> ff.w1); end; end; if size >= old_size then old_bits = substr (new_bits, size-old_size+1); else do; pad_bits = old_size - size; if new_sign < 0 then substr (old_bits, 1, pad_bits) = ones; else substr (old_bits, 1, pad_bits) = "0"b; substr (old_bits, pad_bits+1) = new_bits; end; call bump; end; end; else if type = 3 | type = 4 then do; do while (rep_count > 0); if old_size < 9 then call error (TOO_BIG, ""); if print_mode ^= 0 then do; on underflow begin; /* maybe some value wasn't really */ /* floating, so print it out octal */ call ioa_$ioa_stream (debug_output, "^w to ^w", dp -> fword, tp -> fword); goto rev_under; end; call ioa_$ioa_stream (debug_output, "^12.4f to ^12.4f", addr (old_bits) -> flword, addr (new_bits) -> flword); rev_under: revert underflow; end; old_bits = substr (new_bits, 1, min (old_size, size)); call bump; end; end; else call error (SYNTAX, ""); return; end store_value; /* This procedure attempts to get a repetition count. It assumes a format: [blank(s)] [decimal digit(s)] [blank(s)] If the string is not a repetion count, lin and mode are restored. The main procedure will then try to parse an instruction */ get_rep_count: proc (rep); dcl rep fixed bin; rep = 1; i = lin; /* save in case this is not repetition */ if get_char (lin + 1) then do; k = lin; j = db_get_count$dec (il, lin, lin); if lin = k then do; lin = i; mode = "("; return; end; if get_char (lin) then if mode = ")" then do; if j < 1 then call error (BAD_REP, ""); if ^get_char (lin + 1) then call error (SYNTAX, ""); rep = j; return; end; end; call error (MISS_PAREN, ""); end get_rep_count; end db_assign;  db_break.pl1 11/04/82 1959.8rew 11/04/82 1628.3 383508 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_break: proc; /* This procedure is part of the debug package. All of the mechanism required to * handle break points is contained in this procedure. This procedure alone, * maintains the user's break segment found in his home directory. This * procedure, along with db_break_map, maintains the break map needed in each * segment which has breaks. Note, what this procedure does NOT know about * is the semantics of the debug language. * Rewritten Dec 72 for the 6180 by Bill Silver. * * db_break has the following entry points: * * check_break: Returns info about a break, especially whether or not a * condition has been met. * * global: Performs a specified action on all the breaks known to the * user in all segments. * * print_bseg: Prints the number of breaks in all the segments which the user * has breaks. Cleans up this break segment. * * print_default: Prints the path name of the current default segment. * * restart: Restarts a break - executes the instruction replaced by * the mme2. * * set_break: Sets up a break. * * set_default: Establishes a segment as the default segment. * * set_skips: Sets a number of skips in a specified break. * * single: Performs a specified action on ONE specified break. * * sub_global: Performs a specified action on all the breaks in the * default segment. */ /* PARAMETER DATA */ dcl arg_action_code fixed bin, /* (INPUT) Implies action to perform on break. * A_C_T_I_O_N_ C_O_D_E_ * list 1 * reset 2 * disable 3 * enable 4 * set command 5 * set condition 6 */ arg_break_num fixed bin, /* (INPUT) The number of a break in the * default segment. */ arg_break_ptr ptr, /* (INPUT) A pointer to the word where * the break will be set. */ arg_cond_flag fixed bin, /* (OUTPUT) A flag indicating whether or not the * condition of a conditional break has been met. * 0 => No condition or condition not met. * 1 => Condition not met - skip break. */ arg_comd_len fixed bin, /* (OUTPUT) The length of the command line * found in a break. 0 => no command. */ arg_comd_ptr ptr, /* (OUTPUT) A pointer to the command line * found in a break. */ arg_line char (236), /* (INPUT) A string that can be either a * command line or condition data. */ arg_line_len fixed bin, /* (INPUT) The length of the above string. */ arg_line_no fixed bin, /* (OUTPUT) Source line number. */ arg_num_skips fixed bin, /* (INPUT/OUTPUT) The number of skips * ( to set/that are set ) in a break. */ arg_print_mode fixed bin, /* (INPUT) 0 => SHORT, 1 => LONG. */ arg_scu_ptr ptr, /* (INPUT) Points to the SCU data * generated by a mme2 fault. */ arg_seg_ptr ptr, /* (INPUT) Pointer to a segment that is * to become the default segment. */ arg_snt_ptr ptr, /* (INPUT) Pointer to debug's arg_snt data. */ arg_type fixed bin; /* (INPUT) The type of break. * 0 => regular, * 1 => temporary, * 2 => disabled. */ /* INTERNAL STATIC DATA */ /* Note, since the following variables must be preserved from one call to another * they are static. Any procedures which need this information therefore must be * part of db_break or called by db_break. */ /* Pointer to the user's break segment. */ dcl break_seg_ptr ptr internal static init (null); /* The following variables are used to define the default segment. * def_seg is the number of the break segment array entry which corresponds * to the default segment. def_break_map_ptr points to the break map in * the default segment. */ dcl def_segx fixed bin internal static init (0), def_break_map_ptr ptr internal static; /* Below is the mme2 instruction that is put into a break word. */ dcl 1 mme2 aligned internal static, 2 break_num fixed bin (17) unaligned, 2 op_code bit (36) unaligned init ("000000100000000000"b); /* An array used to print the type of a break. */ dcl break_type_name (0:3) char (24) internal static aligned init ("Break ", "Temporary break", "Disabled break", "Temporary disabled break"); %include db_ext_stat_; /* AUTOMATIC DATA */ dcl action_code fixed bin, /* These variables are used to copy arguments. */ break_num fixed bin, break_ptr ptr, line_len fixed bin, print_mode fixed bin, snt_ptr ptr, type fixed bin; dcl break_word_ptr ptr, /* Pointer to the word where the break is. */ break_offset fixed bin (18); /* Word offset of the break word. */ dcl dir_name char (168), /* Directory name of a segment. */ ent_name char (32); /* Entry name of a segment. */ /* This is the array of data returned by the calls to hcs_$status_long. */ dcl 1 branch aligned, (2 type bit (2), 2 nnames bit (16), 2 nrp bit (18), 2 dtm bit (36), 2 dtu bit (36), 2 mode bit (5), 2 padding bit (13), 2 records bit (18), 2 dtd bit (36), 2 dtem bit (36), 2 acct bit (36), 2 curlen bit (12), 2 bitcnt bit (24), 2 did bit (4), 2 mdid bit (4), 2 copysw bit (1), 2 pad2 bit (9), 2 rbs (0:2) bit (6), 2 uid bit (36)) unaligned; dcl action_flag bit (1), /* Used to denote if an action has been * performed for any breaks. */ cond_flag fixed bin, /* Used to determine condition state. */ delete_seg_entry_flag bit (1), /* Denotes whether a segment entry in the break * segment array has been deleted. */ inst_ptr ptr, /* Pointer to instruction after break. */ new_bnum fixed bin, /* Temporary break number. */ seg_ptr ptr, /* Temporary segment pointer. */ segx fixed bin; /* Index into break segment array. */ dcl print_num_breaks char (6), /* A word string for printing, */ source_string char (72) var; /* Used to get info back from other procs. */ dcl bit_count fixed bin (24), /* Returned from hcs_$initiate count. */ code fixed bin (35), /* Error return code. */ (i, j) fixed bin; /* Work variables. */ /* BASED DATA */ /* This is a map of the user's break segment. */ dcl 1 bseg based (break_seg_ptr) aligned, 2 num_segs fixed bin, /* Number of segments in seg array. */ 2 seg (1), /* Array of segment entries. Each entry * corresponds to one segment which should * have a break map. */ 3 uid bit (36), /* UID of segment. This field remains * constant for the life of the entry. */ 3 dir_name char (168) unal, /* Directory name of segment. */ 3 ent_name char (32) unal; /* Entry name of the segment. Note, these * two fields may change since the segment * may be moved, renamed, or referenced * via a link. */ /* This is an overlay of the break segment used to move whole entries around. */ dcl 1 bseg_map based (break_seg_ptr) aligned, 2 num_segs fixed bin, 2 array (1), 3 entry char (204); /* This is a map of the mme2 word that is moved into the break word. */ dcl 1 mme2_map based aligned, 2 break_num fixed bin (17) unaligned, 2 op_code bit (18) unaligned; /* This is used to reference one word. */ dcl based_word bit (36) based aligned; /* EXTERNAL ENTRIES */ dcl (addr, addrel, divide, fixed, index, max, null, ptr, rel, size, substr) builtin; dcl com_err_ external entry options (variable), db_break_map$check external entry (ptr, fixed bin (24), ptr), db_break_map$delete external entry (ptr), db_break_map$get_slots external entry (ptr), db_break_map$init external entry (ptr, fixed bin (24), ptr), db_line_no external entry (ptr, fixed bin (18), fixed bin, fixed bin, fixed bin), db_parse_condition$check external entry (ptr, ptr, ptr, fixed bin), db_parse_condition$print_line external entry (ptr, char (72) var), hcs_$fs_get_path_name external entry (ptr, char (*), fixed bin, char (*), fixed bin (35)), hcs_$initiate_count external entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)), hcs_$make_seg external entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$set_bc_seg external entry (ptr, fixed bin (24), fixed bin (35)), hcs_$status_long external entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)), hcs_$truncate_seg external entry (ptr, fixed bin (18), fixed bin (35)), ioa_$ioa_stream external entry options (variable), ioa_$rsnnl external entry options (variable), user_info_ external entry (char (*)), print_text_$real_offset external entry (ptr, char (*) var, fixed bin (18)), user_info_$homedir external entry (char (*)); /* */ %include db_break_map_map; /* */ dcl 1 op_mnemonic_$op_mnemonic (0:1023) ext static aligned, 2 opcode char (6) unal, 2 dtype fixed bin (2) unal, 2 num_desc fixed bin (5) unal, 2 num_words fixed bin (8) unal; /* */ %include db_inst; /* */ %include mc; /* */ print_bseg: entry (arg_print_mode); /* This entry is called to print the contents of the users break segment. It will * print the number of breaks that are set for each segment referenced in the break * segment. It will also clean up the break segment. This involves deleting any * entries which are no longer valid or whose segments have no breaks set. */ print_mode = arg_print_mode; /* Copy argument. */ if break_seg_ptr = null () /* Make sure we have a break segment. */ then call INIT_BREAK_SEG; do segx = 1 to bseg.num_segs; /* Process each entry in break segment. */ call CHECK_SEGMENT; /* This will return the segment's break * map pointer if the segment entry was OK * and wasn't deleted. */ /* Was the segment entry deleted. If so, segx now refers to the last segment entry. * It just replaced the one we were working on. Thus segx must be decremented * so it can reference this same entry again on the next iteration. However, * if this is the last entry in the array, we must not decrement segx because we want * to get out of the loop since bseg.num_segs was also decremented when the * segment entry was deleted. */ if delete_seg_entry_flag /* Was segment entry deleted? */ then do; /* YES, thus there were no breaks. */ if segx <= bseg.num_segs /* But is it last entry. */ then segx = segx -1; /* NO, decrement segment index. */ else; /* YES, lets get out of the loop. */ end; else do; /* No, there are breaks. */ if bmap.num_set = 1 then print_num_breaks = "break "; else print_num_breaks = "breaks"; call ioa_$ioa_stream (debug_output, "^d ^a set in ^a>^a", bmap.num_set, print_num_breaks, bseg.seg (segx).dir_name, bseg.seg (segx).ent_name); end; end; /* We have just processed one segment entry. */ /* The only segment entries left in the break segment array will be those of segments * which have breaks set. If there are no entries left, then there were no breaks set. */ if bseg.num_segs = 0 then call ioa_$ioa_stream (debug_output, "No breaks set."); return; /* */ set_default: entry (arg_seg_ptr); /* This entry will establish the specified segment as the default segment. */ break_ptr = arg_seg_ptr; /* Not really a break pointer. */ call SET_DEFAULTS; return; print_default: entry; /* This entry is called to print the name of the default segment. */ break_num = 1; /* Set dummy break number. */ call CHECK_DEFAULT; call ioa_$ioa_stream (debug_output, "Default segment is ^a>^a", bseg.seg (segx).dir_name, bseg.seg (segx).ent_name); return; /* */ check_break: entry (arg_break_ptr, arg_break_num, arg_snt_ptr, arg_cond_flag, arg_num_skips, arg_comd_len, arg_comd_ptr, arg_line_no); /* This entry returns data about the specified break. Especially important is the * condition flag which tells whether or not a conditional break has been satisfied * 0 => either this is not a conditional break or condition has been satisfied, * 1 => conditional break and condition has not been satisfied. */ break_ptr = arg_break_ptr; /* Copy arguments. */ break_num = arg_break_num; snt_ptr = arg_snt_ptr; call SET_DEFAULTS; /* Establish this segment as the default segment. */ call CHECK_BREAK_NUM; /* Validate the break number. */ /* Now set the condition flag. If the length of the condition data is zero, then we * know that this is not a conditional break and we can set the condition flag to * zero. If this is a conditional break, then we must call out to a procedure that * understands the condition data semantics so it can determaine if the condition * has been met. */ arg_num_skips = break_slot.skip_count; /* no. of times to skip this break */ if arg_num_skips > 0 then do; cond_flag = 0; /* Ignore condition because break will be skiped */ break_slot.skip_count = break_slot.skip_count - 1; end; else if break_slot.cond_len = 0 /* Is this a conditional break? */ then cond_flag = 0; /* NO. */ else call db_parse_condition$check (break_map_ptr, addr (break_slot.cond_data), snt_ptr, cond_flag); arg_cond_flag = cond_flag; /* Return info about break. */ arg_comd_len = break_slot.comd_len; arg_comd_ptr = addr (break_slot.comd_line); arg_line_no = break_slot.line_no; return; /* The end of the check_break entry. */ /* */ set_break: entry (arg_break_ptr, arg_type, arg_snt_ptr, arg_print_mode); /* This entry is called to set a break. Unless it is a disabled break, the word * referenced by break_ptr will be set up to take a fault when executed. */ break_ptr = arg_break_ptr; /* Copy arguments. */ type = arg_type; snt_ptr = arg_snt_ptr; print_mode = arg_print_mode; call SET_DEFAULTS; /* Set up this segment as the default segment. */ /* Now we know that we have pointers to the break map of the default segment and * to the user's break segment. Next, we will look for a free slot in the break map * where we can put this new break. If no slots are available, we will try to allocate * some. */ break_offset = fixed (rel (break_ptr)); /* Get word offset of where the break is to go. * This is used to identify the break. */ new_bnum = -1; /* Initialize the new break number to indicate that * we don't have a slot for the break yet. */ do break_num = 1 to bmap.num_slots; /* Search through all the break slots in * this break map. */ call GET_BREAK_SLOT_PTR; /* Get pointer to this slot. */ if break_slot.type = -1 /* Is this break slot free? */ then if new_bnum = -1 /* YES, but is it the first free slot? */ then new_bnum = break_num; /* YES, this is the slot we will use. */ else; /* NO, this slot is not free. There is a break set in it. See if it is the break * we are trying to set now. If it is a temporary break, we still want to set it. */ else if break_slot.offset = break_offset then do; /* This is the break we are trying to set. */ if (break_slot.type ^= 1) & (break_slot.type ^= 3) then do; /* This is not a temporary break. */ call ioa_$ioa_stream (debug_output, "Break ^d already set at ^p", break_num, break_ptr); return; end; new_bnum = break_num; /* Temp break. Use this slot. Restore inst. */ break_ptr -> based_word = break_slot.old_word; end; end; /* We have just checked one break slot in the map. */ if new_bnum = -1 /* Did we find a free break slot? */ then do; /* No, try to allocate more slots. */ call db_break_map$get_slots (break_map_ptr); if break_map_ptr = null () /* Did we get more slots? */ then do; /* NO. */ call ioa_$ioa_stream (debug_output, "Unable to allocate more break slots in ^a>^a", bseg.seg (segx).dir_name, bseg.seg (segx).ent_name); return; end; new_bnum = bmap.num_set + 1; /* Get number of first new slot. */ end; /* Now we have an index to the break slot we will use for this new break. We * must increment the count of breaks that are set and we must initialize the * break itself. */ break_num = new_bnum; /* Use new break number. */ bmap.num_set = bmap.num_set + 1; /* One more break is being set. */ call GET_BREAK_SLOT_PTR; /* Get pointer to new break slot. */ break_slot.type = type; /* Now fill in the break slot. */ break_slot.offset = break_offset; break_slot.old_word = break_ptr -> based_word; /* Get the line number associated with the location (if possible). */ call db_line_no (snt_ptr, fixed (rel (break_ptr), 18), i, j, break_slot.line_no); /* Get the number of words used by this instruction. If there are more * than one, this is an EIS instruction. */ break_slot.num_words = op_mnemonic_$op_mnemonic (fixed (break_ptr -> instr.opcode, 17)).num_words; /* Initially there are no skips set, there is no command to execute, and there is * no condition set. */ break_slot.reserved (*), break_slot.skip_count, break_slot.comd_len, break_slot.cond_len = 0; call LIST; /* Tell user that break is set. */ if type < 2 /* Is break a disabled type? */ then do; /* No, set break. */ mme2.break_num = break_num; /* Connect mme2 to break slot via break index. */ break_ptr -> mme2_map = mme2; /* Move mme2 into break location. */ end; return; /* This is the end of the set_break entry. */ /* */ set_skips: entry (arg_break_num, arg_num_skips); /* This entry is called to set the skip count in the specified break of the * default segment. */ break_num = arg_break_num; /* Copy argument. */ call CHECK_DEFAULT; /* Make sure default segment set up * and break number valid. */ break_slot.skip_count = arg_num_skips; return; /* */ restart: entry (arg_break_ptr, arg_break_num, arg_num_skips, arg_scu_ptr, arg_print_mode); /* This entry is called to restart a break. To do this we must modify the SCU * data in the stack frame of the debug break handler. When the break handler * returns, the instruction that was replaced by the mme2 will be executed. */ break_ptr = arg_break_ptr; /* Copy some arguments. */ break_num = arg_break_num; scup = arg_scu_ptr; print_mode = arg_print_mode; if break_ptr -> mme2_map.op_code ^= mme2.op_code /* Break has alredy been reset */ then scup -> scu.even_inst = break_ptr -> based_word; else do; /* Break is still set. */ call SET_DEFAULTS; call CHECK_BREAK_NUM; /* Make sure it is still valid. */ scup -> scu.even_inst = break_slot.old_word; if break_slot.type = 1 /* Is this a temporary break? */ then call RESET; /* Temporary break */ else do; /* Regular break */ if arg_num_skips >= 0 then break_slot.skip_count = arg_num_skips - 1; if break_slot.num_words > 1 /* EIS instruction */ & bmap.version = "ver3" then do; inst_ptr = addrel (break_ptr, break_slot.num_words); bmap.eis.mme2_indw = rel (break_ptr); bmap.eis.inst_indw = rel (inst_ptr); bmap.eis.mme2 = break_ptr -> based_word; bmap.eis.inst = inst_ptr -> based_word; break_ptr -> based_word = break_slot.old_word; inst_ptr -> based_word = bmap.eis.tra; end; end; end; scup -> scu.apu.xsf = "0"b; /* These fields must be zero. */ addr (scup -> scu.word3) -> based_word = "0"b; scup -> scu.cu.its = "0"b; /* If a break has just been set in the following word (.ct request or by the < request), the odd instruction will have to be set since it has already been fetched. */ break_ptr = addrel (break_ptr, 1); if break_ptr -> mme2_map.op_code = mme2.op_code then scup -> scu.odd_inst = break_ptr -> based_word; return; /* This is the end of the restart entry. */ /* */ single: entry (arg_break_num, arg_action_code, arg_line_len, arg_line, arg_print_mode); /* This entry is called to perform an action on ONE break that is assumed to * be in the default segment. */ break_num = arg_break_num; /* Copy arguments. */ action_code = arg_action_code; line_len = arg_line_len; print_mode = arg_print_mode; call CHECK_DEFAULT; /* Make sure everything is OK. */ if break_slot.type ^= -1 /* Is break really set? */ then call DO_ACTION; /* YES, go perform action on this break. */ else call ioa_$ioa_stream (debug_output, "Break ^d not set.", break_num); return; /* */ sub_global: entry (arg_action_code, arg_line_len, arg_line, arg_print_mode); /* This entry is called to perform an action on all of the breaks set in the * DEFAULT SEGMENT. */ action_flag = "0"b; /* Initialize flag. */ action_code = arg_action_code; /* Copy arguments. */ line_len = arg_line_len; print_mode = arg_print_mode; break_num = 1; /* Set up dummy break number. */ call CHECK_DEFAULT; /* If there are no breaks set in this segment, we will delete its break map. * This will also delete this segment's entry in the break segment array. */ if bmap.num_set = 0 /* Any breaks set? */ then do; /* NO. */ call DELETE_BMAP; call ioa_$ioa_stream (debug_output, "No breaks set."); return; end; /* There are breaks set in the default segment. We have to look at all of the slots * in this segments break map. We will perform the specified action on all of the * breaks that are found. */ do break_num = 1 to bmap.num_slots while (break_map_ptr ^= null ()); call GET_BREAK_SLOT_PTR; if break_slot.type ^= -1 /* Is there a break in this slot? */ then call DO_ACTION; /* YES. */ end; if ^action_flag then call ioa_$ioa_stream (debug_output, "No breaks set."); return; /* End of sub_global entry. */ /* */ global: entry (arg_action_code, arg_line_len, arg_line, arg_print_mode); /* This entry is called to perform a specified action an all of the breaks the user * has in ALL of the segments referenced by his break segment. */ action_flag = "0"b; /* Initialize flag. */ action_code = arg_action_code; /* Copy arguments. */ line_len = arg_line_len; print_mode = arg_print_mode; if break_seg_ptr = null () /* Make sure we have a break segment. */ then call INIT_BREAK_SEG; /* We don't care about any default segment. */ if bseg.num_segs > 0 then do; /* Breaks are set */ segx = 1; do while (segx <= bseg.num_segs); /* Process all segments in user's break segment. * If not, the segment entry will be deleted * and delete_seg_entry_flag will be ON. */ call CHECK_SEGMENT; if ^ delete_seg_entry_flag then do; /* Segment not deleted; at least one break */ do break_num = 1 to bmap.num_slots while (break_map_ptr ^= null ()); call GET_BREAK_SLOT_PTR; if break_slot.type ^= -1 then call DO_ACTION; end; if ^delete_seg_entry_flag then segx = segx + 1; end; end; end; if ^action_flag then call ioa_$ioa_stream (debug_output, "No breaks set."); return; /* The end of the global entry. */ /* */ SET_DEFAULTS: procedure; /* This procedure establishes the segment with the break as the default segment. * It also makes sure that we have a break segment to work with - it sets up the * pointer to the break segment. The default segment index references this segment's * entry in the user's break segment and the default break map pointer references the * break map in this segment. The entry for this segment in the user's break segment * is initialized. If none exists, one will be created. */ if break_seg_ptr = null () /* Has the break segment been set up? */ then call INIT_BREAK_SEG; /* No, do it now. */ /* Get the name of the new default segment. */ call hcs_$fs_get_path_name (break_ptr, dir_name, (0), ent_name, code); if code ^= 0 then goto SET_DEF_ERR; /* Get the bit count and the uid of this segment. Note, if the path name is for * a link, then we will chase the link, and get the status of the branch itself. */ call hcs_$status_long (dir_name, ent_name, 1b, addr (branch), null (), code); if code ^= 0 then goto SET_DEF_ERR; /* Now get the pointer to the break map for this segment. If no break map exists, it * will be created. */ call db_break_map$init (break_ptr, fixed (branch.bitcnt, 24), break_map_ptr); if break_map_ptr = null () | break_ptr = null then do; arg_break_ptr = null; goto RETURN_FROM_DB_BREAK; end; /* Now we must find the entry in the break segment which corresponds to the new * default segment. If there is no entry for this segment, then one will be created. * Note, the search through the break segment entries is done for uid's and not * for path names since they may have been changed. */ do segx = 1 to bseg.num_segs; if bseg.seg (segx).uid = branch.uid then goto SET_DEF_SEG_FOUND; end; /* This break segment doesn't contain an entry for the dafault segment. Thus we * will create one. */ call set_break_seg_bc (segx, "0"b); bseg.num_segs = segx; /* Up count of segments. */ bseg.seg (segx).uid = branch.uid; /* This relates the entry to the segment. */ /* Now that we know the index of the break segment entry for the default segment we * can fill in the names of the segment. These must be reset each time the segment * is established as the default segment. */ SET_DEF_SEG_FOUND: bseg.seg (segx).dir_name = dir_name; bseg.seg (segx).ent_name = ent_name; def_break_map_ptr = break_map_ptr; /* Set up default break map pointer. */ def_segx = segx; /* Set up default segment index. */ return; SET_DEF_ERR: call com_err_ (code, "debug", "Cannot make ^p the default break segment.", break_ptr); goto RETURN_FROM_DB_BREAK; /* Transfer out of this internal procedure and * return directly to the caller of db_break. */ end SET_DEFAULTS; /* */ CHECK_DEFAULT: procedure; /* This internal procedure checks to see if there is a default segment established. * If not, there is an error. It will also check to see if the break number passed * as an argument is valid for this segment. If everything is OK, it will copy the * default variables, which are in internal static, and the break number, which is an * argument, into automatic variables. */ if def_segx = 0 /* Has default segment been established? */ then do; /* NO, error. */ call ioa_$ioa_stream (debug_output, "No default break segment."); goto RETURN_FROM_DB_BREAK; end; break_map_ptr = def_break_map_ptr; /* Copy default variables. */ segx = def_segx; call VALIDATE_BREAK_NUM; /* Check boonds of break number. */ call GET_BREAK_SLOT_PTR; /* Get pointer to its break slot. */ end CHECK_DEFAULT; /* */ CHECK_BREAK_NUM: procedure; /* This internal procedure is called to perform special validation on the break number. * It checks to see if the break number is within valid bounds and it also checks to * see that the specified breakis enabled. If the break number is valid, * it sets up the break slot pointer to point to the break slot associated * with this break number. */ call VALIDATE_BREAK_NUM; /* Check bounds of break number. */ call GET_BREAK_SLOT_PTR; /* Get pointer to this break's slot. */ if (break_slot.type = -1) | /* Is break not set? */ (break_slot.type > 1) /* Or is break disabled? */ then do; /* Yes, break not enabled. */ call ioa_$ioa_stream (debug_output, "Break ^d should be enabled but isn't. Segment must be recompiled.", break_num); arg_break_ptr = null; goto RETURN_FROM_DB_BREAK; end; end CHECK_BREAK_NUM; /* */ VALIDATE_BREAK_NUM: procedure; /* This procedure is called to check that the current break number is * within valid bounds for the current default segment. */ if (break_num <= 0) | /* Is break number within bounds. */ (break_num > bmap.num_slots) then do; /* No, outside bounds of break map. */ call ioa_$ioa_stream (debug_output, "Illegal break number ^d for segment ^a>^a", break_num, bseg.seg (segx).dir_name, bseg.seg (segx).ent_name); goto RETURN_FROM_DB_BREAK; end; end VALIDATE_BREAK_NUM; /* */ CHECK_SEGMENT: procedure; /* This procedure is called to get the break map of a segment and to validate the * fact that the segment has breaks set. The first thing that we must do is to * initiate this segment so we can get a pointer to it and get its bit count. * If any of the following four conditions occur, we will delete this entry in * the break segment: * 1. The segment does not exist. * 2. The uid of the segment doesn't match the uid in the break segment entry. * This implies that the name of the segment was changed and a new * segment was created with its old name. * 3. There is no break map for this segment; => it has no breaks. * 4. There is a break map, but there are no breaks set. * If the segment entry is deleted and there is a break map, the break map will * also be deleted. If for any of the above reasons the segment entry is deleted * the delete_seg_entry_flag will be turned ON. */ delete_seg_entry_flag = "0"b; /* Assume seg entry OK. */ call hcs_$initiate_count (bseg.seg (segx).dir_name, bseg.seg (segx).ent_name, "", bit_count, 0, seg_ptr, code); if seg_ptr = null () /* Does segment exist? */ then do; /* NO. */ call DELETE_SEG_ENTRY; return; end; call hcs_$status_long (bseg.seg (segx).dir_name, bseg.seg (segx).ent_name, 1b, addr (branch), null (), code); if bseg.seg (segx).uid ^= branch.uid /* Is it realy the same segment? */ then do; /* NO. */ call ioa_$ioa_stream (debug_output, "Path name ^a>^a now references new segment.", bseg.seg (segx).dir_name, bseg.seg (segx).ent_name); call DELETE_SEG_ENTRY; return; end; call db_break_map$check (seg_ptr, bit_count, break_map_ptr); if seg_ptr = null then return; /* error return for illegal break format */ if break_map_ptr = null () /* Does it have a break map? */ then do; /* NO. */ if print_mode = 1 /* Only print this message in LONG mode. */ then call ioa_$ioa_stream (debug_output, "^a>^a has no break map.", bseg.seg (segx).dir_name, bseg.seg (segx).ent_name); call DELETE_SEG_ENTRY; return; end; /* This segment has a break map. Does it have any breaks set? If not, we will * delete its break map. This will also result in deleteing its segment entry. */ if bmap.num_set = 0 /* Does it have any breaks set? */ then do; /* NO. */ call DELETE_BMAP; return; end; end CHECK_SEGMENT; /* */ GET_BREAK_SLOT_PTR: procedure; /* This internal procedure is called to get a pointer to the break slot * referenced by "break_num". Temporarily, there are two versionb of * the break_map_header. This procedure must decide which version is being used. */ break_slot_ptr = addr (bmap.breaks (break_num)); end GET_BREAK_SLOT_PTR; /* */ INIT_BREAK_SEG: procedure; /* This procedure is called to get a pointer to the user's break segment in his * home directory. The pointer is set in "break_seg_ptr" which is in internal * static. If no break segment exists for this user, then one will be created. */ call user_info_$homedir (dir_name); /* Get the name of the user's * home directory. */ call user_info_ (ent_name); /* Get the user's login name. * Note, it is a max of 24 chars. */ i = index (ent_name, " "); /* Get index of first blank. */ substr (ent_name, i, 7) = ".breaks"; /* Add debug suffix. */ /* The following call will get a pointer to the segment. If none exists, it will * create the segment. In any case, there is an error only if we don't get a * valid pointer back. We don't use a reference name and we want RWA access to * the segment. */ call hcs_$make_seg (dir_name, ent_name, "", 01011b, break_seg_ptr, code); if break_seg_ptr = null () then do; call com_err_ (code, "debug", "^a>^a", dir_name, ent_name); goto RETURN_FROM_DB_BREAK; end; end INIT_BREAK_SEG; /* */ DO_ACTION: procedure; /* This internal procedure acts as a transfer vector. It calls the db_break * procedure which will perform the specified action. The action code * indicates the type of action. The action flag is turned on in order to * indicate that the action has been performed for at least one break. */ action_flag = "1"b; goto ACTION_LABEL (action_code); /* Go to specified call. */ ACTION_LABEL (1): /* LIST a break. */ call LIST; return; ACTION_LABEL (2): /* RESET a break. */ call RESET; return; ACTION_LABEL (3): /* DISABLE a break. */ call DISABLE; return; ACTION_LABEL (4): /* ENABLE a break. */ call ENABLE; return; ACTION_LABEL (5): /* Set a COMMAND in a break. */ call SET_COMMAND; return; ACTION_LABEL (6): /* Set a CONDITION in a break. */ call SET_CONDITION; end DO_ACTION; /* */ LIST: procedure; /* This procedure is called to print the contents of one break. The print_mode flag * determines the mode of printing. There are two modes: * SHORT (print_mode = 0) Print as little as possible. * LONG (print_mode = 1) Print as much as possible. */ dcl line_info char (14) aligned; /* Char representation of line num. (if available) */ if break_slot.line_no > 0 then call ioa_$rsnnl (" (line ^d)", line_info, j, break_slot.line_no); else line_info = ""; /* Print short mode information first. */ call ioa_$ioa_stream (debug_output, "^a ^d set at ^a|^o^a", break_type_name (break_slot.type), break_num, bseg.seg (segx).ent_name, break_slot.offset, line_info); if print_mode = 0 /* If short mode, that's all. */ then return; /* Now we must print the long mode data. First print the instruction where the * break is. */ call print_text_$real_offset (addr (break_slot.old_word), source_string, break_slot.offset); call ioa_$ioa_stream (debug_output, "^-At instruction: ^a", source_string); /* Now print the command line and the condition line if they exist. */ if break_slot.comd_len ^= 0 then call ioa_$ioa_stream (debug_output, "Command = ^a", substr (break_slot.comd_line, 1, break_slot.comd_len)); if break_slot.cond_len ^= 0 /* Is there a condition line? */ then do; /* Yes, call routine that knows condition format. */ call db_parse_condition$print_line (addr (break_slot.cond_data), source_string); call ioa_$ioa_stream (debug_output, "Condition = ^a", source_string); end; end LIST; /* */ RESET: procedure; /* This procedure is called to reset a break. Resetting a break involves * removing the mme2 instruction from the break word and freeing the break slot * used by the break. When the last break in a segment is reset, its * break map will be deleted. Also, its entry in the break segment array will * be deleted. */ call DISABLE; /* First disable the mme2. */ break_slot.type = -1; /* Now free the break slot. */ bmap.num_set = bmap.num_set -1; /* Segment has one less break set. */ if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "Break ^d at ^a|^o reset.", break_num, bseg.seg (segx).ent_name, break_slot.offset); /* Now that the break has been reset, we must check to see if there are any breaks left * in the segment. If not, we will delete its break map. */ if bmap.num_set = 0 /* Any breaks left in segment? */ then call DELETE_BMAP; /* NO. */ end RESET; /* */ DISABLE: procedure; /* This procedure is called to disable a break. Disabling a break involves * putting the word that was originally in the break word back into the break word. * This overlays the mme2 that is there while the break is enabled. */ if break_slot.type > 1 /* Is break already disabled? */ then return; /* YES. */ /* Get a pointer to the break and set up our own mme2 word to look like what should * be in the break word now. */ break_word_ptr = ptr (break_map_ptr, break_slot.offset); mme2.break_num = break_num; /* Now check to see that this is a valid break. The break word should contain a * mme2 instruction with an address equal to this break number. */ if break_word_ptr -> based_word ^= addr (mme2) -> based_word then do; call ioa_$ioa_stream (debug_output, "Break ^d at ^a|^o is invalid.", break_num, bseg.seg (segx).ent_name, break_slot.offset); return; end; /* It is a valid break so we disable it now. */ break_word_ptr -> based_word = break_slot.old_word; /* Now set the type to indicate that this is a disabled break. Regular breaks * are now type 2 and temporary breaks are now type 3. */ break_slot.type = break_slot.type + 2; end DISABLE; /* */ ENABLE: procedure; /* This procedure is called to enable a break. Enabling a break involves simply * putting a mme2 instruction the the break word. */ if break_slot.type < 2 /* Is break already enabled */ then return; /* YES, don't bother. */ mme2.break_num = break_num; /* Addr field of mme2 = break num. */ ptr (break_map_ptr, break_slot.offset) -> mme2_map = mme2; /* Now set the type to indicate that the break is enabled. If it is a regular * break it will go from 2 -> 0 and if it is a temporary break if will go from * 3 -> 1. */ break_slot.type = break_slot.type - 2; end ENABLE; /* */ SET_COMMAND: procedure; /* This procedure sets up a command in the specified break. */ break_slot.comd_len = line_len; if line_len ^= 0 /* Is there really a command line? */ then substr (break_slot.comd_line, 1, line_len) = substr (arg_line, 1, line_len); end SET_COMMAND; SET_CONDITION: procedure; /* This procedure is called to set or to reset a condition in a break. The type of * break is not considered and is not changed. Only the condition information * in the break slot is changed. We must determine if we are to set the condition * or reset the condition. If the condition length is zero, we must reset. */ if line_len = 0 /* Are we to SET or RESET? */ then break_slot.cond_len = 0; /* RESET - this implies no condition. */ else do; /* SET condition, there is data. */ break_slot.cond_len = line_len; substr (break_slot.cond_data, 1, line_len) = substr (arg_line, 1, line_len); end; end SET_CONDITION; /* */ DELETE_BMAP: procedure; /* This procedure is called to delete a beak map from a segment. This is done * whenever a segment is referenced which has a break map but does not have any * breaks set. This will also result in deleting the segment's entry in * the break segment array. */ call db_break_map$delete (break_map_ptr); break_map_ptr = null; /* Make sure no attempt is made * look at this break map again */ call DELETE_SEG_ENTRY; /* If this segment is the default segment, we must reset the default segment * variables to indicate that there is no default segment. */ if def_segx = segx /* Is this the default segment? */ then def_segx = 0; /* YES, but no longer. */ end DELETE_BMAP; /* */ DELETE_SEG_ENTRY: procedure; /* This procedure is called to delete an entry in the user's break segment. * We will move the last entry in the break segment array into the entry * that is being deleted. Then we will clear the last entry and decrement * the count of entries. */ /* Move last entry into the one being deleted. */ break_seg_ptr -> bseg_map.array (segx).entry = break_seg_ptr -> bseg_map.array (bseg.num_segs).entry; bseg.num_segs = bseg.num_segs - 1; /* Decrement the count of entries. */ delete_seg_entry_flag = "1"b; call set_break_seg_bc (bseg.num_segs, "1"b); end DELETE_SEG_ENTRY; /* */ /* This procedure sets the bit count on the user's break segment. It is called when a new segment slot is added or deleted. */ set_break_seg_bc: proc (num_slots, truncate); dcl num_slots fixed bin; /* size the break map will become */ dcl truncate bit (1) unal; /* truncate the break segment */ dcl 1 break_slot aligned like bseg.seg based; dcl word_count fixed bin (18); dcl size builtin; word_count = size (break_slot) * num_slots + 1; call hcs_$truncate_seg (break_seg_ptr, word_count, code); if code = 0 then call hcs_$set_bc_seg (break_seg_ptr, 36 * word_count, code); if code ^= 0 then call com_err_ (code, "break segment"); return; end set_break_seg_bc; /* */ /* This statement is part of the main db_break block. It is provided so that * internal procedures may return directly to the caller of db_break. Thus the * db_break entry which called the internal procedure doesn't have to check for * error conditions. */ RETURN_FROM_DB_BREAK: return; end db_break;  db_break_map.pl1 11/04/82 1959.8rew 11/04/82 1609.4 198666 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_break_map: procedure; /* This procedure is called to manipulate break maps. It is called by db_break * to perform the following tasks: * * init: Returns a pointer to the break map in a specified segment. * If no break map exists then one will be created. * * check: Returns a pointer to the break map in a specified segment. * However, if no break map exists it will not create one. * * get_slots: It will add anothere page full of break slots to an existing * break map. * * delete: It deletes the break map from the specified segment. * * Rewritten Dec 72 for the 6180 by Bill Silver. */ /* PARAMETERS */ dcl arg_seg_ptr ptr, /* (I) Pointer to segment that contains * or will contain a break map. */ arg_bit_count fixed bin(24), /* (I) Bit count of this segment. */ arg_break_map_ptr ptr; /* (I/O) Pointer to break map of a segment. * If there is any ERROR it is returned null. */ /* AUTOMATIC DATA */ dcl access_mode fixed bin(5), /* Access mode of the segment. */ bit_count fixed bin(24), /* The total number of bits in a segment. */ bits_left fixed bin, /* The number of bits left unused in the * last page of the segment. */ code fixed bin(35), /* Error return code. */ dir_name char(168) aligned, /* Directory name of the segment. */ ent_name char(32) aligned, /* Entry name of the segment. */ end_ptr ptr, /* Pointer to the last word in the segment or * where the last word in the segment will be. */ i fixed bin, /* A work index. */ mapp ptr, /* Just declared to get rid of warning. */ max_length fixed bin(19), /* The max number of words in the object segment. */ max_num_pages fixed bin, /* Number of pages in object segment. */ new_bits fixed bin(24), /* Number of new bits being added to a segment. */ new_slots fixed bin, /* Number of new break slots being added * to the break map. */ new_words fixed bin(18), /* Number of new words being added to a segment. */ new_slots_ptr ptr, /* Pointer to where new break slots will be added. */ obj_map_ptr ptr, /* Pointer to the object map in the segment * or where the object map will go. */ page_bits fixed bin, /* The number of bits in a page. */ page_num fixed bin, /* The number of the last page in the segment - * starting with page 1. */ page_words fixed bin, /* The number of words in a page. */ seg_ptr ptr, /* Pointer to the base of the object segment. */ word_count fixed bin(19); /* Total number of words in segment. */ dcl 1 seg_acl aligned, /* Structure used to add an ACL entry to the object segment. */ 2 user_id char(32), 2 access bit(36), 2 pad bit(36), 2 status fixed bin(35); dcl 1 delete_acl aligned, /* Used to delete an ACL. */ 2 user_id char(32), 2 status fixed bin(35); dcl 1 oi like object_info; /* BASED DATA */ /* This is an overlay of an instruction. We only want to reference the offset * field of the instruction. */ dcl 1 based_inst based aligned, ( 2 offset bit(18), 2 pad bit(18)) unaligned; /* These are the two formats of the object map offset found at the end of an object segment. */ dcl ns_obj_map_off fixed bin(18) based aligned, stand_obj_map_off bit(18) based aligned; dcl 1 map_ver_1 aligned based (obj_map_ptr), /* version 1 object map */ 2 decl_vers fixed bin, /* version number of current structure format */ 2 identifier char(8) aligned, /* must be the constant "obj_map" */ 2 text_offset bit(18) unaligned, /* offset rel to base of object segment of base of text section */ 2 text_length bit(18) unaligned, /* length in words of text section */ 2 def_offset bit(18) unaligned, /* offset rel to base of object seg of base of definition section */ 2 def_length bit(18) unaligned, /* length in words of definition section */ 2 link_offset bit(18) unaligned, /* offset rel to base of object seg of base of linkage section */ 2 link_length bit(18) unaligned, /* length in words of linkage section */ 2 symb_offset bit(18) unaligned, /* offset rel to base of object seg of base of symbol section */ 2 symb_length bit(18) unaligned, /* length in words of symbol section */ 2 bmap_offset bit(18) unaligned, /* offset rel to base of object seg of base of break map */ 2 bmap_length bit(18) unaligned; /* length in words of break map */ /* INTERNAL STATIC DATA */ /* The following constants are used to restart a break that was set on an EIS type * instruction. The transfer constant is a "tra" instruction which temporarily replaces * the instruction which follows the EIS instruction. This "tra" transfers to the * first instruction in the break map header. When the break map header is created * the "tra" is saved in the break map header and its offset is relocated. * The following seven instructions in the break map header put the mme2 back into * the break location, replace the tra with the instruction that originally followed * the eis instruction, and returns control to the instruction after the eis instruction. */ dcl tra_con bit(36) internal static init ( "000000000000000000111001000000000000"b); /* 000000710000 tra eis.instructions */ /* EXTERNAL ENTRIES */ dcl ( addr, addrel, bit, divide, fixed, null, ptr, rel, size ) builtin; dcl sys_info$page_size fixed bin external; %include db_ext_stat_; dcl com_err_ entry options(variable), get_group_id_ entry returns (char(32) aligned), hcs_$add_acl_entries entry (char(*) aligned, char(*) aligned, ptr, fixed bin, fixed bin(35)), hcs_$delete_acl_entries entry (char(*) aligned, char(*) aligned, ptr, fixed bin, fixed bin(35)), hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin(35)), hcs_$fs_get_path_name entry (ptr, char(*) aligned, fixed bin, char(*) aligned, fixed bin(35)), hcs_$get_max_length_seg entry (ptr, fixed bin(19), fixed bin(35)), hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35)), hcs_$truncate_seg entry (ptr, fixed bin(19), fixed bin(35)), ioa_$ioa_stream entry options (variable), object_info_$brief entry (ptr, fixed bin(24), ptr, fixed bin(35)); /* */ %include object_info; %include object_map; /* */ %include obj_map_old_1_; /* */ %include db_break_map_map; /* */ init: entry (arg_seg_ptr, arg_bit_count, arg_break_map_ptr); /* This entry is called to return a pointer to the break map in the specified segment. * If this segment does not have a break map then one will be created. Note, when * a break map is created we make sure that the user has write access to the * segment. Also note that the number of break slots initially allocated to the * break map will vary from segment to segment. Enough slots will be allocated * so that all of the last page of the segment will be used. Only if there is no * room for at least one break slot will another page be used for the break map. * If the user needs more break slots he will get them - a page full at a time. */ call CHECK_MAP; /* See if there is a break map and copy args. */ call CHECK_ACCESS; /* Even if there is a break map already in ... */ if arg_break_map_ptr ^= null then return; /* There is no break map. Before we create one we have to see if there is room * in this segment for a break map with at least one break. If not we can't make * the break map. First get the number of pages in the segment. */ page_words = sys_info$page_size; page_bits = page_words * 36; page_num = divide((bit_count + page_bits -1),page_bits, 17, 0); bits_left = page_num * page_bits - bit_count; /* Num unused bits in last page. */ if bits_left < ((size(bmap)+size(break_slot)+2)*36) then do; /* Won't fit on last page, get max length of segment. */ call hcs_$get_max_length_seg (seg_ptr, max_length, code) ; if code ^= 0 then goto ERROR; /* Get num of pages in segment. */ max_num_pages = divide (max_length+page_words-1, page_words, 17, 0) ; if page_num = max_num_pages /* Last page in seg? */ then do; /* YES, can't create break map. */ call ioa_$ioa_stream (debug_output, " No room for break map."); return; end; end; /* There is room for a break map. We have to determine how may break slots we * can initially allocate. First, we must see how many bits will be left in the last * page of the segment after the break map header has been allocated. NOTE, we must * allow for two extra words that may be needed in the object map. */ bits_left = bits_left - (size(bmap)*36) - (2*36); /* If we can't fit at least one break slot on this page we will add another page * to the segment. */ if bits_left < (size(break_slot)*36) /* Room on this page? */ then bits_left = bits_left + page_bits; /* NO, add page. */ /* Now we can get the number of full break slots we can allocate. Then we can * determine the total number of words and bits in the break map. */ new_slots = divide(bits_left , (size(break_slot)*36), 17, 0); new_words = (new_slots * size(break_slot)) + size(bmap); new_bits = new_words * 36; /* The last word of the segment will contain a relative word * offset to the beginning of the object map. */ end_ptr = ptr(seg_ptr,divide((bit_count-35),36,24,0));/* Get pointer to last word in segment. */ /* STANDARD object map. This new type of object map is easier to handle since: * 1. It does not have to be moved. Only the obj_map_off has to be moved. * 2. The break map entries are already there. They just have to be filled in. * The break map will start where the obj_map_off word is now. The obj_map_off word * will be moved to the new last word in the segment. Its value will not be changed. */ break_map_ptr = end_ptr; obj_map_ptr = ptr(end_ptr, end_ptr -> stand_obj_map_off); end_ptr = addrel(break_map_ptr, new_words); /* Now we will move the obj_map_off word. The old one will get overlayed by the * break map header. Break map length is in WORDS. */ end_ptr -> stand_obj_map_off = break_map_ptr -> stand_obj_map_off; if obj_map_ptr -> object_map.decl_vers = 1 then do; map_ver_1.bmap_offset = rel(break_map_ptr); map_ver_1.bmap_length = bit (fixed (new_words, 18), 18); end; else do; obj_map_ptr -> object_map.break_map_offset = rel (break_map_ptr); obj_map_ptr -> object_map.break_map_length = bit (fixed (new_words, 18), 18); end; /* Now that the break map has been inserted into the segment, we can set the bit count * of the segment and then initialize the header of the break map and the new break * slots. We will also return a pointer to the new break map. */ bit_count = bit_count + new_bits; call hcs_$set_bc_seg (seg_ptr, bit_count, code); if code ^= 0 then goto ERROR; bmap.num_slots = new_slots; /* Initialize break map header info. */ bmap.num_set = 0; bmap.bit_count = bit_count; bmap.version = "ver3"; bmap.eis.tra = tra_con; /* Set up EIS restart instructions. */ addr(bmap.eis.tra)->based_inst.offset = rel(addr(bmap.eis.instructions)); bmap.eis.mme2_indw, bmap.eis.inst_indw = "0"b; do i = 1 to 9; bmap.eis.instructions(i) = db_ext_stat_$break_instructions (i); end; do i = 1 to new_slots; /* Initialize the new break slots. */ addr(bmap.breaks(i))->break_slot.type = -1; end; arg_break_map_ptr = break_map_ptr; /* Return ptr to break map. */ return; /* This is the end of the init entry. */ /* */ get_slots: entry (arg_break_map_ptr); /* This entry is called to add more break slots to the break map. We know that * this segment does not have room for even one more break slot on its last * page. Thus, if this is the last page in the segment, we will not be * able to add more break slots. If there are free pages left in the segment, * we will allocate one full page of break slots. */ break_map_ptr = arg_break_map_ptr; /* Copy argument. */ bit_count = bmap.bit_count; /* Bit count of segment is saved in break map. */ page_words = sys_info$page_size; /* Set up some constants we need. */ page_bits = page_words * 36; /* Get number of pages in this segment. */ page_num = divide((bit_count + page_bits -1), page_bits, 17, 0); seg_ptr = ptr(break_map_ptr, 0); /* Get pointer to base of segment. */ /* Get max length of segment. */ call hcs_$get_max_length_seg (seg_ptr, max_length, code) ; if code ^= 0 then goto ERROR; max_num_pages = divide (max_length+page_words-1, page_words, 17, 0) ; if page_num = max_num_pages /* Is this the last page? */ then do; /* YES, can't add more slots. */ arg_break_map_ptr = null(); /* Denote ERROR by returning null pointer. */ return; end; /* We do have room for another page of break slots. We must get some info about * this segment and we must get the number of bits that are left unused on * the last page of the segment. This will always be less than the number of * bits needed for one break slot so we will add a page to the segment. */ oi.version_number = object_info_version_2; call object_info_$brief (seg_ptr, bit_count, addr(oi), code); if code ^= 0 then goto ERROR; if oi.old_format then goto ERROR_OLD_FORMAT; bits_left = page_num * page_bits - bit_count + page_bits; /* We can now figure out how many new break slots to add. From this we can * directly get the number of word and bits that are being added to the segment. */ new_slots = divide(bits_left, (size(break_slot)*36), 17, 0); new_words = new_slots * size(break_slot); new_bits = new_words * 36; end_ptr = ptr(seg_ptr, divide((bit_count-35), 36, 24, 0)); /* Now that we are all set up and have a pointer to the last word in the segment - * where the obj_map_off word is - we can insert the new break slots. */ /* STANDARD type object map. All we have to do is update the length of the break * map in the object map and then move the obj_map_off word down to the new end of * the segment. */ obj_map_ptr = ptr(end_ptr, end_ptr -> stand_obj_map_off); if obj_map_ptr -> object_map.decl_vers = 1 then map_ver_1.bmap_length = bit(fixed((fixed (map_ver_1.bmap_length, 18) + new_words), 18), 18); else obj_map_ptr -> object_map.break_map_length = bit(fixed((fixed (obj_map_ptr -> object_map.break_map_length, 18) + new_words), 18), 18); addrel(end_ptr, new_words) -> stand_obj_map_off = end_ptr->stand_obj_map_off; /* Now that we have made room for the new break slots, we must update the bit count * and update the break map header info. We must also initialize the new break * slots. */ bit_count = bit_count + new_bits; call hcs_$set_bc_seg(seg_ptr, bit_count, code); if code ^= 0 then goto ERROR; bmap.bit_count = bit_count; do i = (bmap.num_slots + 1) to (bmap.num_slots + new_slots); if bmap.version = "ver3" then break_slot_ptr = addr(bmap.breaks(i)); break_slot.type = -1; end; bmap.num_slots = bmap.num_slots + new_slots; return; /* This is the end of the get_slots entry. */ /* */ check: entry (arg_seg_ptr, arg_bit_count, arg_break_map_ptr); /* This entry is called to return a pointer to the break map of the specified segment. * If no break map exists, we will return a null pointer and we will not try * to create a break map. Note, if there is a break map, we will check the user's * access to this segment to ensure that he has write access. */ call CHECK_MAP; /* Get break map pointer. */ if code ^= 0 then goto ERROR; if arg_break_map_ptr = null() /* Is there a break map? */ then return; /* NO. */ call CHECK_ACCESS; /* YES, make sure access is OK. */ if code ^= 0 then goto ERROR; return; /* This is the end of the check entry. */ /* */ delete: entry (arg_break_map_ptr); /* This entry is called to delete an existing break map from a segment. The * break map will be deleted and the object map will be updated to denote this * fact. We will reset the bit count to what its original value was before the * break map was added to the segment. Also, we will truncate the segment so that it * will actually be its former size. * First we will copy the argument and get some info about the segment. */ break_map_ptr = arg_break_map_ptr; bit_count = bmap.bit_count; seg_ptr = ptr(break_map_ptr, 0); /* Get pointer to base of segment. */ oi.version_number = object_info_version_2; call object_info_$brief (seg_ptr, bit_count, addr(oi), code); if code ^= 0 then goto ERROR; if oi.old_format then goto ERROR_OLD_FORMAT; /* Now we will get a pointer to the end of the segment where the object map offset * word is. We will also get the number of bits in the break map. This is the * number of words that must be deleted from the segment. */ end_ptr = ptr(seg_ptr, divide((bit_count - 35), 36, 24, 0)); new_bits = oi.blng * 36; /* Num of bits in break map. */ /* STANDARD object map. All we have to do is zero out the break map entries in * the object map (they stay there) and to move the object map offset word to * to the new end of the segment. It will go where the first word of the break * map is now. */ obj_map_ptr = ptr(seg_ptr, end_ptr -> stand_obj_map_off); if obj_map_ptr -> object_map.decl_vers = 1 then do; map_ver_1.bmap_offset, map_ver_1.bmap_length = "0"b; end; else do; obj_map_ptr -> object_map.break_map_offset = "0"b; obj_map_ptr -> object_map.break_map_length = "0"b; end; break_map_ptr -> stand_obj_map_off = end_ptr -> stand_obj_map_off; /* Now that we have correctly rearrainged the segment we can reset the bit count * and truncate the unused portion of the segment. */ bit_count = bit_count - new_bits; call hcs_$set_bc_seg (seg_ptr, bit_count, code); if code ^= 0 then goto ERROR; word_count= divide(bit_count+35, 36, 17, 0); call hcs_$truncate_seg(seg_ptr, word_count, code); if code ^= 0 then goto ERROR; /* Now all we have to do is reset that ACL entry that we added (possibly) * when the beak map was created. */ call hcs_$fs_get_path_name (seg_ptr, dir_name, (0), ent_name, code); if code ^= 0 then goto ERROR; delete_acl.user_id = get_group_id_(); call hcs_$delete_acl_entries (dir_name, ent_name, addr(delete_acl), 1, code); return; /* End of the delete entry. */ /* */ CHECK_MAP: procedure; dcl probe (3) char(4) based (arg_break_map_ptr); /* (2,3) = "breakmap" in a probe break map */ /* This procedure initializes some variables and then checks to see if we have a * break map in this segment. The break map pointer (either valid or null) will * br put in arg_break_map_ptr. */ seg_ptr = ptr(arg_seg_ptr, 0); /* Get pointer to the base of segment. */ bit_count = arg_bit_count; /* Copy argument. */ /* Get some info about this segment. This will tell us whether there is a * break map or not. */ oi.version_number = object_info_version_2; call object_info_$brief (seg_ptr, bit_count, addr(oi), code); if code ^= 0 then goto ERROR; if oi.old_format then goto ERROR_OLD_FORMAT; arg_break_map_ptr = oi.bmapp; /* Get break map pointer. */ /* The 2-3 words of a probe break map are "breakmap". The probe and debug break maps are not compatible */ if arg_break_map_ptr ^= null then if probe (2) = "brea" then do; call ioa_$ioa_stream (debug_output, "probe breaks are still set in this segment"); arg_break_map_ptr = null(); goto ERROR; end; /* Convert from version 2 to version 3 break map */ if arg_break_map_ptr ^= null() then do; break_map_ptr = arg_break_map_ptr; if bmap.version = "ver2" then do; bmap.version = "ver3"; do i = 1 to 9; bmap.instructions (i) = db_ext_stat_$break_instructions (i); end; end; return; end; end CHECK_MAP; /* */ CHECK_ACCESS: procedure; /* This procedure is called to check that this segment has write access. Since * we must write into the break map this is necessary. If we don't have W access * we will try to add ourselves to the ACL of the segment and thus give ourselves * W access. */ call hcs_$fs_get_mode (seg_ptr, access_mode, code); if code ^= 0 then goto ERROR; if (bit(access_mode,5) & ("00010"b)) ^= "00000"b then return; /* YES, we do have W access. */ /* NO, we don't have write access. The W bit is off. We will get the path name * of the segment and the validation level and we will try to add ourselves to the * ACL of the segment. Note we will be added under the group_id name and with * REWA access. */ call hcs_$fs_get_path_name (seg_ptr, dir_name, (0), ent_name, code); if code ^= 0 then goto ERROR; seg_acl.user_id = get_group_id_(); seg_acl.access = "1111"b; seg_acl.pad = "0"b; call hcs_$add_acl_entries (dir_name, ent_name, addr(seg_acl), 1, code); if code ^= 0 then goto ERROR; end CHECK_ACCESS; /* */ /* This is the location transfered to when any error occurs due to a call to one * of the system procedures. This is part of the main block of db_break_map so * when it is called by an internal procedure control will be returned directly * to the caller of db_break_map. Note, regardless of the error, we will * return a null break map pointer. */ ERROR: arg_break_map_ptr = null(); call com_err_(code, "debug", "Error in db_break_map. "); return; ERROR_OLD_FORMAT: call com_err_ (0, "debug", "Version 1 object segments are not supported by debug"); arg_seg_ptr = null; return; end db_break_map;  db_data.alm 11/04/82 1959.8rew 11/04/82 1633.7 53001 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name db_data segdef names segdef tags segdef fault_names segdef acv_names segdef ipr_names segdef n_regs " This procedure is used as a constant data base for the MULTICS on-line debug " programs. It is written in ALM so that it can be part of the text section of the " bound debug program. This allows it to be shared by all processes without any copying. " " Rewritten Nov 72 for the 6180 by Bill Silver. " " This table contains the names of the debug defined data items. They correspond to " the data fields found in the machine conditions. Each name must be four (4) characters " long. If this table is changed the db_regs program must also be changed. names: aci "pr0 " The eight pointer registers aci "pr1 " aci "pr2 " aci "pr3 " aci "pr4 " aci "pr5 " aci "pr6 " aci "pr7 " aci "x0 " The eight index registers aci "x1 " aci "x2 " aci "x3 " aci "x4 " aci "x5 " aci "x6 " aci "x7 " aci "aq " The combined A and Q registers aci "all " Used to print all debug data. aci "prs " Used to print all eight pointer regs. aci "regs" Used to print index regs, a,q,exp,tr, and ralr. aci "scu " Used to print all the SCU data. aci "user" Used to print all of the user registers. aci "a " A register aci "q " Q register aci "exp " Exponent register aci "tr " Timer register aci "ralr" Ring Alarm Register aci "ppr " Procedure Pointer Register aci "tpr " Temporary Pointer Register aci "even" Even instruction at fault time aci "odd " Odd instruction at fault time aci "ind " Indicators aci "eaq " Floating point accumulator n_regs: vfd 36/*-names-1 Number of names (-1 becuse array is (0:n)) " tags: aci " " Register Modification (R ) aci ",au " aci ",qu " aci ",du " aci ",ic " aci ",al " aci ",ql " aci ",dl " aci ",0 " aci ",1 " aci ",2 " aci ",3 " aci ",4 " aci ",5 " aci ",6 " aci ",7 " aci ",* " Register then Indirect (RI) aci ",au*" aci ",qu*" aci " " aci ",ic*" aci ",al*" aci ",ql*" aci " " aci ",0* " aci ",1* " aci ",2* " aci ",3* " aci ",4* " aci ",5* " aci ",6* " aci ",7* " aci ",f1 " Indirect then Tally (IT) aci ",itp" aci " " aci ",its" aci ",sd " aci ",scr" aci ",f2 " aci ",f3 " aci ",ci " aci ",i " aci ",sc " aci ",ad " aci ",di " aci ",dic" aci ",id " aci ",idc" aci ",*n " Indirect then Register (IR) aci ",*au" aci ",*qu" aci " " aci ",*ic" aci ",*al" aci ",*ql" aci " " aci ",*0 " aci ",*1 " aci ",*2 " aci ",*3 " aci ",*4 " aci ",*5 " aci ",*6 " aci ",*7 " " fault_names: aci "shutdown " aci "store " aci "mme1 " aci "fault_tag_1 " aci "timer_runout " aci "command " aci "derail " aci "lockup " aci "connect " aci "parity " aci "IPR: " aci "ONC: " aci "startup " aci "overflow " aci "zerodivide " aci "execute " aci "directed_fault_0 " aci "seg_fault_error " aci "page_fault_error " aci "gate_error " aci "ACV: " aci "mme2 " aci "mme3 " aci "mme4 " aci "linkage_error " aci "fault_tag_3 " aci "undefined_fault " aci "undefined_fault " aci "undefined_fault " aci "undefined_fault " aci "undefined_fault " aci "trouble " " acv_names: aci "illegal_ring_order " aci "out_of_execute_bracket " aci "no_execute_permission " aci "out_of_read_bracket " aci "no_read_permission " aci "out_of_write_bracket " aci "no_write_permission " aci "not_a_gate " aci "out_of_call_bracket " aci "outward_call " aci "bad_outward_call " aci "inward_return " aci "cross_ring_transfer " aci "ring_alarm_register " aci "associative_memory " aci "out_of_segment_bounds " " ipr_names: aci "illegal_segment_number " aci "illegal_opcode " aci "illegal_modifier " aci "illegal_slave_procedure " aci "other_illegal " aci "nonexistent_address " aci "out_of_bounds " " end  db_ext_stat_.alm 11/04/82 1959.8rew 11/04/82 1633.7 26856 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " db_ext_stat_.alm contains the external static data for debug. " " Modified 7/75 by S.E. Barr to add instructions to restart an EIS break. " " dcl 1 db_ext_stat_$db_ext_stat_ ext static aligned, " " 2 debug_input char(32) aligned, /* Input switch name. Initially 'user_input' */ " 2 debug_output char(32) aligned, /* output switch name. Initially 'user_output' */ " 2 return_label label, /* The label used to do a non local goto out of debug when " it was entered via a fault. It will go to debug in " another frame. */ " " 2 debug_io_ptr(2) ptr, /* pointers to iocb for i/o " 1 = input switch iocb ptr " 2 = output switch iocb ptr */ " 2 flags aligned, " 3 debug_io_attach(2) bit(1) unaligned, /* 1= debug made the attachment */ " 3 debug_io_open(2) bit(1) unaligned, /* 1 = debug opened the switch */ " 3 in_debug bit(1) unaligned, /* Switch for the any_other condition. 0 = send the " condition on. 1 = use the debug condition handler */ " 3 static_handler_call bit (1) unal, /* ON if static handler */ " 3 pad bit(30) unaligned, /* Reserved for future use */ " 2 instructions (9) bit (36) aligned /* Instructions to restart EIS breaks */ " " name db_ext_stat_ segdef db_ext_stat_ segdef break_instructions " " These instructions are used to restart a break at an EIS instruction. The EIS instruction must be restored " because the hardware may restart an EIS instruction in certain cases. The break restart code restores the EIS " instruction and places a transfer in the word following the EIS instruction. The transfer is to these instructions " which have been copied into the break map header in the object segment. The instructions put the mme2 back " into the text and restore the word following the eis instruction. " break_instructions: sti ind_save-*,ic sta a_reg-*,ic lda mme2-*,ic sta mme2_indw-*,ic* lda inst-*,ic sta inst_indw-*,ic* lda a_reg-*,ic ldi ind_save-*,ic tra inst_indw-*,ic* mme2_indw: arg 0 " Offset of EIS break inst_indw: arg 0 " Offset of instruction following EIS break a_reg: arg 0 " Contents of a reg. mme2: arg 0 " Used to save mme2 inst: arg 0 " Used to save instruction following EIS break ind_save: arg 0 " Used to save indicators use linkc join /link/linkc db_ext_stat_: aci "user_input " aci "user_output " bss ,9 end  db_fill_snt.pl1 11/05/86 1217.3r w 11/04/86 1033.9 52956 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_fill_snt: procedure( arg_sp, arg_snt_ptr ); /* This procedure fills in the SNT table with data from the specified stack frame. */ /* PARAMETER DATA */ dcl arg_sp ptr, /* Pointer to the stack frame where we * will get our data. */ arg_snt_ptr ptr; /* Pointer to the SNT table. */ /* AUTOMATIC DATA */ dcl code fixed bin, /* Return code. */ dummy fixed bin; /* Dummy argument. */ dcl lot_ptr ptr, /* Pointer to the LOT table. */ isot_ptr ptr, /* Pointer to the ISOT table. */ proc_segno fixed bin; /* Segment number of the procedure which * owns the stack frame. */ dcl procedure_ptr ptr, /* Pointer to the procedure which owns * the stack frame. */ dum_string char (32) aligned; /* dummy string used as argument */ dcl 1 situation aligned, 2 bad_frame bit (1) unal, 2 pad1 bit (4) unal, 2 entry_ptr_bad bit (1) unal, 2 pad2 bit (30) unal; dcl 1 cond_info aligned, %include cond_info; /* BASED DATA */ dcl 1 lot_array ( 0:1023 ) aligned based, /* Map of LOT table. Used to reference * specific entries in the LOT. */ 2 segno bit(18) unaligned, 2 offset bit(18) unaligned; dcl based_name_string char(ent_pt_name_len) based; /* EXTERNAL DATA */ dcl db_stack_util$procedure_ptr ext entry ( ptr, ptr, fixed bin ), hcs_$fs_get_path_name ext entry ( ptr, char(*) aligned, fixed bin, char(*) aligned, fixed bin ), find_condition_info_ ext entry ( ptr, ptr, fixed bin ); dcl stack_frame_exit_ ext entry ( ptr, ptr, ptr, bit (1) aligned, ptr, char(32) aligned, ptr ); dcl get_entry_name_ ext entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin ); dcl ( addr, baseno, baseptr, fixed, null, ptr, rel ) builtin; /* */ %include db_snt; /* */ %include its; /* */ %include stack_header; /* */ %include stack_frame; /* */ sp = arg_sp; /* Copy arguments. */ sntp = arg_snt_ptr; snt.sp = sp; /* Save pointer to this stack frame. */ call get_proc_ptr; /* get a pointer to the point */ /* where the frame was exited */ if procedure_ptr = null() /* Pointer is either invalid or is null. Set up null SNT data. */ then do; bad_proc_ptr: snt.ent_pt_name, snt.ent_name = "(unknown procedure)"; snt.dir_name = " "; snt.pp, snt.lp, snt.symp = null(); snt.symflag = "0"b; return; end; /* Procedure pointer is OK. Fill with what should be good data. */ snt.symflag = "1"b; /* Indicate that we don't have a symbol * table pointer yet. */ snt.symp = null(); /* We will get the lot pointer for this procedure from the actual entry in the * lot for this procedure. We can get a pointer to the beginning of the lot from * the stack header. */ lot_ptr = ptr( sp, 0 ) -> stack_header.lot_ptr; proc_segno = fixed ( baseno( procedure_ptr )); snt.lp = ptr( baseptr( lot_ptr -> lot_array(proc_segno).segno), lot_ptr -> lot_array(proc_segno).offset ); isot_ptr = ptr (sp, 0) -> stack_header.isot_ptr; snt.static_ptr = ptr( baseptr( isot_ptr -> lot_array(proc_segno).segno), isot_ptr -> lot_array(proc_segno).offset ); snt.pp = procedure_ptr; /* For crawl-out frame don't try to get pathname, just stuff it in */ if fixed( sp -> stack_frame.translator_id, 18) = 3 then do; snt.ent_pt_name, snt.ent_name = "signal_caller"; snt.dir_name = "signal_caller_directory"; return; end; /* Get the path name of the procedure. If we can't get the path name then see * if the frame belongs to the signaller. If it doesn't then we don't know who * it belongs to. */ call hcs_$fs_get_path_name( procedure_ptr, snt.dir_name, dummy, snt.ent_name, code ); if code ^= 0 /* Did we get a path name. */ then do; /* NO, check for signaller. */ if fixed (sp -> stack_frame.translator_id, 18) = 4 then do; /* It is the signaller. */ snt.ent_pt_name, snt.ent_name = "return_to_ring_0_"; snt.dir_name = "signaller_directory"; return; end; else do; /* It isn't the signaller. */ snt.ent_name = "(unknown procedure)"; snt.dir_name = " "; end; end; /* Now try to get the entry point name of the procedure. If we can't * get it, we'll just use the entry name of the segment. */ if ^situation.entry_ptr_bad then do; /* don't bother if we don't have entry ptr */ call get_entry_name_ (sp -> stack_frame.entry_ptr, snt.ent_pt_name, proc_segno, dum_string, code ); if code = 0 then return; end; snt.ent_pt_name = snt.ent_name; /* couldn't get entry name */ return; proc_ptr: entry (arg_sp, arg_pp); /* entry to get just a procedure pointer */ dcl arg_pp ptr; sp = arg_sp; call get_proc_ptr; arg_pp = procedure_ptr; return; get_proc_ptr: proc; /* internal procedure to figure out where a stack frame comes from */ call find_condition_info_ ( sp, addr(cond_info), code); /* get stuff that stack_frame_exit_ wants */ /* now let stack_frae_exit_ do the real work */ call stack_frame_exit_ (sp, cond_info.mcptr, cond_info.wcptr, (cond_info.crawlout), procedure_ptr, dum_string, addr(situation)); if situation.bad_frame | addr (procedure_ptr) -> its.its_mod ^= "100011"b /* no good */ then procedure_ptr = null; return; end; end db_fill_snt;  db_find_mc.pl1 11/04/82 1959.8rew 11/04/82 1627.5 15066 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_find_mc: procedure (a_sp, co_flag, ret_mcp); /* This procedure is used by other debug subroutines to obtain a pointer to the latest set of machine conditions relative to the frame pointed to by a_sp. If co_flag is "1"b, then the caller desires machine conditions associated with the latest crawlout. */ /* Coded by Robert S. Coren 07/23/73 */ dcl a_sp ptr; dcl co_flag bit(1) aligned; dcl ret_mcp ptr; dcl sp ptr; dcl pp ptr; dcl code fixed bin(35); dcl (addr, null) builtin; dcl find_condition_frame_ entry (ptr) returns (ptr); dcl find_condition_info_ entry (ptr, ptr, fixed bin(35)); dcl 1 cond_info aligned, %include cond_info; sp = a_sp; ret_mcp = null; /* all set in case we don't find it */ find_it: pp = find_condition_frame_ (sp); if pp = null then return; /* okay, there aren't any */ sp = pp; call find_condition_info_ (pp, addr(cond_info), code); if cond_info.mcptr = null then go to find_it; /* software condition, no mc */ if co_flag then if ^cond_info.crawlout then go to find_it; /* not crawlout, keep looking */ ret_mcp = cond_info.mcptr; /* if we got here we have the stuff we want */ return; end;  db_get_count.pl1 11/04/82 1959.8rew 11/04/82 1609.4 40257 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_get_count: proc(line,start_index,next_index,number); /* db_get_count Parses the string "line" beginning at "start_index" and returns a fixed binary number. using an octal default. db_get_count$double Returns a double word and uses an octal default. db_get_count$dec Returns a fixed binary number, but assumes a decimal default. Escape strings must immediately preceed the number. &o Change the default to octal. &d Change the default to decimal. */ dcl line char(132); /* character string to convert to a number */ dcl (start_index, /* index of start of string */ next_index) fixed; /* index of character following the number */ dcl number fixed bin(35); /* number returned */ dcl no fixed bin(71) init(0); dcl data_type fixed bin; dcl data_len fixed bin; dcl (i,j,st,end) fixed bin; dcl data bit(1) init("0"b); dcl dec_default bit(1) init("0"b); /* 1 = assume decimal init("0"); 0 = assume octal init("0"); */ dcl assign_ ext entry (ptr,fixed bin,fixed bin,ptr,fixed bin,fixed bin); dcl signal_ ext entry (char(*)); dcl (addr, fixed, index, length, substr, verify, unspec) builtin; dcl data_ptr ptr; /* ptr to number */ number = 0; call initial; if ^dec_default then number = no; else call decimal; return; ERROR: next_index = start_index; RETURN: return; db_get_count$double: entry (line,start_index,next_index,double_no); dcl double_no fixed bin(71); data = "1"b; call initial; if ^dec_default then double_no = no; else do; data_ptr = addr(double_no); data_type = 4; data_len = 71; call decimal; end; return; db_get_count$dec: entry (line,start_index,next_index,number); dec_default = "1"b; call initial; if dec_default then call decimal; else number = no; return; db_get_count$data: entry(line,start_index,next_index,arg_ptr,arg_type,arg_len); dcl (arg_type, /* 2*arg type */ arg_len) fixed bin; /* precesion */ dcl arg_ptr ptr; /* pointer to location of number */ data = "1"b; dec_default = "1"b; call initial; if ^dec_default then call assign_(arg_ptr,arg_type,arg_len,addr(no),4,71); else do; /* decimal default */ i = verify (substr(line,st),"+-0123456789.e"); if i = 1 then go to ERROR; else if i = 0 then i = end; else i = st + i -2; call assign_(arg_ptr, arg_type, arg_len,addr(substr(line,st)),43,i-st+1); next_index = i + 1; end; return; initial: proc; st = start_index; end =length(line); if ^data then do; data_ptr = addr(number); data_type = 2; data_len = 35; end; if substr(line,st,2) = "&o" then do; st = st +2; dec_default = "0"b; end; else if substr(line,st,2) = "&d" then do; st = st + 2; dec_default = "1"b; end; if ^dec_default then call octal; return; end initial; octal: proc; dcl minus bit(1); minus = "0"b; if substr(line,st,1) = "-" then do; st = st + 1; minus = "1"b; end; else if substr (line,st,1) = "+" then st = st + 1; i = verify(substr(line,st,end-st+1),"01234567"); if i = 1 then do; if substr(line,st,1) = "8" | substr(line,st,1) = "9" then call signal_("db_conversion"); else go to ERROR; end; else if i = 0 then j = end; else do; j = st + i - 2; if substr(line,j+1,1) = "8" | substr(line,j+1,1) = "9" then call signal_ ("db_conversion"); end; no = 0; do i = st to j; no = no*8 + fixed (unspec(substr(line,i,1)),35) - 48; end; next_index = j + 1; if minus then no = -no; return; end octal; decimal: proc; if ^data then do; /* default is fixed bin(35) */ data_ptr = addr(number); data_type = 2; data_len = 35; number = 0; end; i = verify (substr(line,st,end-st+1),"+-0123456789"); if i = 1 then go to ERROR; if i = 0 then j = end; else j = st + i - 2; call assign_(data_ptr, data_type, data_len, addr(substr(line,st)), 43, j-st+1); next_index = j + 1; return; end decimal; end db_get_count;  db_get_sym.pl1 11/02/83 1337.3rew 11/02/83 1242.8 42876 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ db_get_sym: proc (a_sntp); /* This procedure is called to get a pointer to a symbol table block. * The pointer passed as an argument points to the segment name table * of the procedure whose symbol table block we are to find. * * Rewritten on Nov. 7, 1972 for the 6180 by Bill Silver. * Modified Nov. 1, 1983 by Melanie Weaver to remove call to stu_$get_runtime_block */ dcl a_sntp ptr; /* Pointer to the procedure's segment name table. */ dcl hdr_ptr ptr, /* Pointer to the header of the symbol table. */ bp ptr, work_ptr ptr; /* Temporary pointer. */ dcl offset fixed bin(18), /* Offset of procedure within its segment. */ len fixed bin, /* Length of the entry name. */ root bit(18); /* Offset of root. */ dcl stu_$find_containing_block ext entry (ptr, fixed bin(18)) returns (ptr), stu_$find_header ext entry (ptr, char (32) aligned, fixed bin) returns (ptr), stu_$find_block ext entry(ptr,char(*)) returns (ptr); %include db_ext_stat_; dcl ioa_$ioa_stream ext entry options(variable); dcl (binary,addrel,index,substr, rel, null) builtin; /* */ % include db_snt; /* */ %include std_symbol_header; %include stu_frame; /* */ %include pl1_symbol_block; /* */ % include symbol_header; /* */ % include symbol_node; /* */ sntp = a_sntp; /* Copy argument. Set pointer to segment name * table overlay. */ /* If the symbol table pointer in the segment name table is not null then it * is allready pointing to a symbol table block. */ if snt.symp ^= null() then return; /* We have to look for the symbol table block. Set the flag in the segment * name table so that we won't look again unless someone else resets the * flag. */ snt.symflag = "0"b; /* Now get the header of the symbol table. */ snt.std = "0"b; hdr_ptr = stu_$find_header( snt.pp, snt.ent_pt_name, 0); /* If we can't get the header to the symbol table then we will return. */ snt.headp = hdr_ptr; if hdr_ptr = null() then return; /* If there is a pointer to the stack then we can extract the pointer to the * symbol table block from the stack information if necessary. */ if snt.sp ^= null() then do; if snt.pp = null() then offset = binary (rel (snt.sp -> frame.entry), 18, 0); /* Use entry ptr if there is no procedure ptr. */ else offset = binary( rel(snt.pp), 18, 0); snt.symp = stu_$find_containing_block (hdr_ptr, offset); end; /* Now get the offset of the root. */ if hdr_ptr -> std_symbol_header.identifier ^= "symbtree" then root = hdr_ptr ->symbol_header.root; else do; snt.std = "1"b; if hdr_ptr -> std_symbol_header.area_pointer = (18)"0"b then return; bp = addrel( hdr_ptr, hdr_ptr -> std_symbol_header.area_pointer ); if bp -> pl1_symbol_block.identifier ^= "pl1info" then return; root = bp -> pl1_symbol_block.root; end; /* If we already got the symbol pointer from the stack frame we're done */ if snt.sp ^= null() then return; /* If the root block of the symbol table is not present then we will have to return. */ if root = (18)"0"b then return; /* We have a valid symbol table. We will search for the correct block as * identified by the entry name. If no block is found for this entry name then * we will use the first block off of the root block. */ len = index(snt.ent_pt_name," ") -1 ; /* Get length of entry name. */ if len = -1 then len = 32; work_ptr = stu_$find_block( hdr_ptr, substr(snt.ent_pt_name,1,len)); if work_ptr = null() /* If no block found for this entry use * the first son off of the root. */ then do; work_ptr = addrel(hdr_ptr, root); work_ptr = addrel(work_ptr, work_ptr->symbol_block.son); call ioa_$ioa_stream (debug_output, "Using symbol table of ^A for ^a", addrel(work_ptr,work_ptr->symbol_block.name), snt.ent_pt_name); end; snt.symp = work_ptr; /* send back result */ end db_get_sym;  db_line_no.pl1 11/04/82 1959.8rew 11/04/82 1628.5 17388 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_line_no: proc(a_sntp, offset, first, number, line_no); /* Procedure to get the line number of the source statement associated * with a given offset in an object segment. Decides whether to call * get_line_no or get_runtime_line_no in stu_, according to whther * the symbol header is standard. * * Coded March 1973 by Robert S> Coren. */ dcl a_sntp ptr; /* pointer to snt structure(input) */ dcl offset fixed bin(18); /* offset in object segment(input) */ dcl first fixed bin(18); /* first location in line(output) */ dcl number fixed bin(18); /* number of locations in line(output) */ dcl line_no fixed bin; /* line number associated with offset(output) */ dcl db_get_sym entry(ptr); dcl stu_$get_line_no entry(ptr, fixed bin(18), fixed bin(18), fixed bin(18), fixed bin); dcl stu_$get_runtime_line_no entry(ptr, fixed bin(18), fixed bin(18), fixed bin(18), fixed bin); %include db_snt; sntp = a_sntp; first, line_no = -1; if snt.symflag then call db_get_sym(sntp); /* with standard header, we can use the top-level symbol block */ if snt.std then do; if snt.headp ^= null() then call stu_$get_runtime_line_no(snt.headp, offset, first, number, line_no); return; end; /* Not standard, we'll have to make do with symbol table for current procedure */ if snt.symp ^= null() then call stu_$get_line_no(snt.symp, offset, first, number, line_no); return; end db_line_no;  db_parse.pl1 11/05/86 1217.3r w 11/04/86 1034.0 428832 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_parse: procedure (input_buffer_ptr, input_line_len, arg_auto_ptr, arg_stat_ptr); /* Modified 10/ by S. Barr to recognize COBOL data types and the size field with the print request. */ /* Modified 771116 by PG to add el & fl output modes */ /* Changed "Version 1 symbol table" msg to say "this language not supported" 10/14/83 S. Herbst */ /* Parameters */ dcl input_buffer_ptr ptr, input_line_len fixed bin, arg_auto_ptr ptr, arg_stat_ptr ptr; /* Default variables. */ dcl (data_ptr ptr, offset fixed bin (18), stack_depth fixed bin, data_id char (1) aligned, /* segment id corresponds to data_ptr (t, s, i, l) */ input_type char (1) aligned, /* type of input. Used to decide what * default to use for db_assign. * v = variable * a = address * * = indirect * % = temporary */ data_format char (6) aligned) internal static; dcl continue bit (1) unal; dcl break_action_code fixed bin, break_data_len fixed bin, break_data_line char (236), break_return fixed bin, reg_val bit (72); dcl temp_reg_val fixed bin (71); dcl goto_label label; dcl 1 label_map based aligned, 2 pp ptr, 2 sp ptr; dcl err_no_linkage fixed init (1); dcl err_no_stack fixed init (2); dcl err_no_sym_tab fixed init (3); dcl err_no_static fixed init (4); dcl err_mess (4) char (40) int static init ( "no linkage section", /* err_no_linkage */ "no stack frame", /* err_no_stack */ "no symbol table", /* err_no_sym_tab */ "no internal static"); /* err_no_static */ dcl com_err_ ext entry options (variable), cu_$cp ext entry (ptr, fixed bin, fixed bin), cu_$gen_call ext entry (ptr, ptr), cv_oct_check_ ext entry (char (*), fixed bin) returns (fixed bin (35)), db_assign ext entry (char (132) aligned, fixed bin, fixed bin, ptr, ptr, ptr, fixed bin, fixed bin, fixed bin, fixed bin, bit (1)), db_break$global ext entry (fixed bin, fixed bin, char (236), fixed bin), db_break$print_bseg ext entry (fixed bin), db_break$print_default ext entry, db_break$set_break ext entry (ptr, fixed bin, ptr, fixed bin), db_break$set_default ext entry (ptr), db_break$set_skips ext entry (fixed bin, fixed bin), db_break$sub_global ext entry (fixed bin, fixed bin, char (236), fixed bin), db_break$single ext entry (fixed bin, fixed bin, fixed bin, char (236), fixed bin), db_parse_condition$set ext entry (char (132) aligned, fixed bin, fixed bin, fixed bin, char (236), fixed bin), db_get_count ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin), db_get_count$dec ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin), db_get_count$double entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin (71)), db_get_sym ext entry (ptr), db_print ext entry (ptr, char (*) aligned, ptr, char (*) aligned, fixed bin, fixed bin, ptr, fixed bin, fixed bin), db_regs$get ext entry (ptr, char (4) aligned, bit (72), fixed bin), db_regs$print ext entry (ptr, char (4) aligned, fixed bin), db_regs$assign ext entry (ptr, char (4) aligned, bit (72), fixed bin), db_fill_snt ext entry (ptr, ptr), db_fill_snt$proc_ptr entry (ptr, ptr), db_sym ext entry (char (72) var, ptr, ptr, fixed bin (18), fixed bin, char (1) aligned, char (*) aligned, fixed bin, fixed bin, fixed bin), decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin), expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin), hcs_$fs_get_path_name ext entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin), hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin), hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*), fixed bin (1), fixed bin (2), ptr, fixed bin), hcs_$make_ptr ext entry (ptr, char (*) aligned, char (*) aligned, ptr, fixed bin), ioa_$ioa_stream entry options (variable), ioa_$rsnnl ext entry options (variable), iox_$close ext entry (ptr, fixed bin (35)), iox_$detach_iocb ext entry (ptr, fixed bin (35)), iox_$attach_ioname ext entry (char (*), ptr, char (*), fixed bin (35)), iox_$find_iocb ext entry (char (*), ptr, fixed bin (35)), iox_$open ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)), list_arg_ ext entry (fixed bin, char (1) aligned, ptr), db_parse_arg ext entry (char (132) aligned, fixed bin, fixed bin, ptr, fixed bin, fixed bin), stu_$get_location ext entry (ptr, fixed bin, fixed bin (18)); dcl is_condition_frame_ entry (ptr) returns (bit (1) aligned); dcl db_find_mc entry (ptr, bit (1) aligned, ptr); dcl find_condition_info_ entry (ptr, ptr, fixed bin); dcl stu_$get_runtime_location entry (ptr, fixed bin) returns (fixed bin (18)); dcl db_parse_arg$ptr_offset entry (char (132) aligned, fixed bin, fixed bin, fixed bin, ptr, fixed bin, fixed bin); dcl error_table_$segknown ext fixed bin; dcl code35 fixed bin (35); dcl fboff fixed bin (9), code fixed bin, d_type fixed bin, itemp fixed bin, (max_stack, new_type, line_number) fixed bin, (pc, i, j) fixed bin, temp1 fixed bin (18), (ct, nv) fixed bin, (lin, ill) fixed bin, (size, scale, ndims) fixed bin, exec fixed bin; dcl offset_incr fixed bin; /* increment to be added to offset and working pointer */ dcl dol fixed bin; dcl max_size fixed bin; dcl based_bit72 bit (72) based; dcl based_fix fixed bin based aligned; dcl arglist (21) ptr, based_ptr ptr based (sp), ptr_array (1) based ptr, (pp, ilp, tp, tpp) ptr; dcl switch bit (1) aligned; dcl new_line char (1) aligned static init (" "), il char (132) aligned, reg_name char (4) aligned, str char (exec) based aligned, str1 char (ill) based aligned, sym_name char (72) var, (c1, c2) char (1) aligned, dir_name char (168) aligned, pathname char (168), (ent_name, ref_name) char (32) aligned, cmc char (1) aligned; dcl char char (1) aligned; /* character being used for parse */ dcl (attach, /* 1 = switch_name attached */ open) bit (1) unaligned; /* 1 = switch_name opened */ dcl dec_default bit (1); /* 1 = use dec_default for temporaries (%) */ dcl switch_name char (32); /* switch_name for ".si" request */ dcl entry_name char (32) aligned; dcl desc_area (11) bit (36) internal static init ((11) (1) "100000100000000000000000000000000001"b); dcl desc_ptr ptr init (addr (desc_area)); dcl 1 desc (11) aligned based (desc_ptr), (2 flag bit (1), 2 type bit (6), 2 packed bit (1), 2 n_dims bit (4), 2 size fixed bin (23)) unaligned; dcl dummy_desc bit (36) aligned static init ("101010100000000000000000000000100000"b); /* char(32) */ dcl return_desc bit (36) aligned static init ("100000100000000000000000000000000001"b); /* fixed bin, 1 word */ dcl (addr, addrel, baseno, baseptr, bit, max, null, ptr, rel, substr, index, search, verify) builtin; dcl (binary, divide, hbound, length, min, reverse) builtin; dcl 1 ff aligned based, 2 (w0, w1) fixed bin; dcl 1 bi aligned based, 2 ts (132) fixed bin (8) unaligned; /* character codes used as subscripts to type array */ dcl 1 lot (0: 1023) aligned based, 2 segno bit (18) unaligned, 2 offset bit (18) unaligned; /* constants */ dcl NUMBER char (11) int static init ("0123456789&"); dcl MODES (21) char (6) var int static init ( "a", "b", "p", "P", "i", "I", "l", "s", "o", "h", "d", "el", "fl", "f", "e", "g", "x", "comp-5", "comp-6", "comp-7", "comp-8"); dcl 1 cond_info aligned, %include cond_info; %include db_ext_stat_; %include iocb; /* */ %include db_common_auto; /* */ %include db_common_static; /* */ %include db_snt; /* */ %include db_arg_list; /* */ %include its; /* */ %include stack_header; %include stack_frame; /* use of big label arrays label_1 label_2 label_3 0 syntax_error syntax_error syntax_error 1 (:) colon0 colon colon 2 (%) per_cent syntax_error syntax_error 3 (/) namel syntax_error syntax_error 4 ($) reg relative_offset syntax_error 5 (n) offset1 relative_offset syntax_error 6 (+ -) relative_offset relative_offset syntax_error 7 (,) set_mode set_mode set_mode 8 (=) assign assign assign 9 (<) set set set 10 (>) go go go 11 ( ) ---- ---- ---- 12 (;) rskip print print 13 (&) amper amper syntax_error l4 (letter) offsetl offsetl syntax_error 15 (nl) print print print 16 (*) star star syntax_error 17 (.) com syntax_error syntax_error */ /* */ /* Initialize data needed to parse the command line. */ com_auto_ptr = arg_auto_ptr; com_stat_ptr = arg_stat_ptr; lin = 1; ill = input_line_len; ilp = addr (il); ilp -> str1 = input_buffer_ptr -> str1; if first_call_flag = 0 then do; data_ptr = stack_ptr_array (max_sp_x); offset = 0; stack_depth = max_sp_x; data_id = "s"; data_format = "h"; input_type = ""; first_call_flag = 1; end; sntp = snt_ptr; max_stack = max_sp_x; sb = ptr (stack_ptr_array (max_stack), 0); depth_1: if get_char (lin, lin, char) then do; d_type = 0; pc = 1; /* default is print one item */ go to label_1 (type (ilp -> bi.ts (lin))); end; else goto print; /* come here (depth 2) when the procedure name has been established and associated defaults set up */ depth_2: if get_char (lin, lin, char) then do; /* PL1 bug 1497 */ goto label_2 (type (ilp -> bi.ts (lin))); end; else goto print; /* come here after the following have been set up data_ptr offset output mode must either print out a value (or values), set a break, restart execution, or assign a value (or values) */ depth_4: if get_char (lin, lin, char) then do; /* PL1 bug 1497 */ goto label_3 (type (ilp -> bi.ts (lin))); end; else goto print; /* */ /* come here if we are at start of a symbolic name */ label_1 (14): label_2 (14): offsetl: nv = 0; /* initialize depth count */ do i = lin to ill; /* scan over variable name */ cmc = substr (il, i, 1); /* pick up current character */ j = type (ilp -> bi.ts (i)); /* get type of current character */ if j = 4 | j = 5 | j = 14 | j = 11 | cmc = "." then go to endl; if cmc = "(" then nv = nv + 1; else if cmc = ")" then do; if nv > 0 then nv = nv - 1; end; else if cmc = "-" then do; if substr (il, i+1, 1) = ">" then i = i+1; /* scan over arrow */ else if nv = 0 then go to donel; /* done if not in parens */ end; else if nv = 0 then go to donel; endl: end; donel: sym_name = substr (il, lin, i-lin); lin = i; new_type = 0; call db_sym (sym_name, sntp, data_ptr, offset, d_type, data_id, data_format, pc, max_size, code); if data_format ^= "a" & data_format ^= "b" then pc = 1; if code = 0 then do; /* continue if no error */ input_type = "v"; goto relative_offset; end; if code > 100 then do; i = code - 100; /* a parameter */ cmc = "?"; go to list_arg; end; call sym_err; /* print message and goto rskip */ /* */ /* come here when a colon is encountered in the scan */ label_1 (1): ct = 0; /* no return value */ go to colon_join; label_2 (1): label_3 (1): ct = 1; /* return value requested */ colon_join: if substr (il, lin+1, 1) ^= "=" then go to syntax_error; /* check for following = */ if ^get_char (lin + 2, lin, "") then goto syntax_error; do i = lin to ill while (is_name (ilp -> bi.ts (i))); /* skip to end of procedure name */ end; ent_name = substr (il, lin, i-lin); /* pick up segment procedure name */ if substr (il, i, 1) = "$" then do; /* secondary entry point given */ do lin = i+1 to ill while (is_name (ilp -> bi.ts (lin))); /* skip to end of entry name */ end; ref_name = substr (il, i+1, lin-1-i); /* copy entry point name */ end; else do; /* if no entry point name, use same */ ref_name = ent_name; lin = i; end; call hcs_$make_ptr (null, ent_name, ref_name, tp, code); /* get pointer to the entry */ if code ^= 0 | tp = null then do; call ioa_$rsnnl ("^a$^a", ent_name, i, ent_name, ref_name); call com_err_ (code, "debug", ent_name); go to rskip; end; if ^get_char (lin, lin, "") then goto make_call; i = 0; if substr (il, lin, 1) ^= "(" then go to make_call; /* check for no args */ lin = lin + 1; argl: i = i + 1; /* go to next arg */ if ct + i > 11 then do; /* watch for too many args */ call ioa_$ioa_stream (debug_output, "Too many arguments."); go to rskip; end; call db_parse_arg (il, lin, ill, addr (dummy_arg (i)), j, exec); /* pick up the next arg */ if substr (il, lin, 1) = "," then lin = lin + 1; /* skip over "," */ arglist (i+1) = addr (dummy_arg (i)); /* set up default arglist pointer */ if j = 0 then do; /* a variable as the argument */ sym_name = addr (dummy_arg (i)) -> str; /* get returned symbol name */ call db_sym (sym_name, sntp, pp, temp1, j, c1, c2, pc, max_size, code); if code = 0 then do; /* no error, variable */ arglist (i+1) = pp ; /* stuff pointer to var in arglist */ exec = pc; go to make_desc; end; if code > 100 then arglist (i+1) = snt.sp -> stack_frame.arg_ptr -> ptr_array (code - 99); else call sym_err; end; if j > 0 then do; make_desc: desc (i).type = bit (binary (j, 6), 6); desc (i).size = binary (exec, 23); arglist (i + 11) = addr (desc (i)); end; else if j = -1 then do; /* no arg, all done */ do j = 1 to i-1; /* loop through all arguments */ arglist (j+i+ct) = arglist (11+j); /* move descriptor pointers down */ end; make_call: addr (arglist) -> arg_list.num_args = binary (i+ct-1, 17); addr (arglist) -> arg_list.num_desc = binary (i+ct-1, 17); if ct ^= 0 then do; arglist (i + 1) = data_ptr; arglist (2*i + 1) = addr (return_desc); end; addr (arglist) -> arg_list.code = (16) "0"b || "100"b; addr (arglist) -> arg_list.fill = "0"b; in_debug = "0"b; /* pass all conditions on */ call cu_$gen_call (tp, addr (arglist)); /* call the specified procedure */ in_debug = "1"b; /* turn handler on */ go to skip; end; else if j = -2 then do; /* syntax error */ call ioa_$ioa_stream (debug_output, "Syntax error in argument ^d.", i); go to rskip; end; else if j = -3 then arglist (i+11) = addr (dummy_desc); /* "%" in arg position */ else call ioa_$ioa_stream (debug_output, "??"); go to argl; /* */ /* come here to print out dummy args */ label_1 (2): input_type = "%"; nv = db_get_count$dec (il, lin+1, lin); /* get correct dummy arg */ if nv < 1 | nv > 10 then go to syntax_error; /* make sure it's valid */ data_ptr = addr (dummy_arg (nv)); /* set data ptr to point to the dummy arg */ data_format = "h"; /* set print default to octal */ go to star1; /* merge with indirect code */ /* */ /* come here if we are at start of a stack procedure name */ label_1 (3): namel: do i = lin+1 to ill while (substr (il, i, 1) ^= "/"); end; if i = ill+1 then go to syntax_error; nv = cv_oct_check_ (substr (il, lin+1, i-lin-1), code); if code = 0 then do; if nv < hcs_count then do; /* check for hardcore segment number */ call ioa_$ioa_stream (debug_output, "Hardcore segment number."); go to rskip; end; pp = baseptr (nv); call hcs_$fs_get_path_name (pp, dir_name, itemp, ent_name, code); if code ^= 0 then do; /* signaller if trouble */ ent_name = "signaller"; dir_name = "signaller_directory"; end; pathname, entry_name = ent_name; /* if given number use primary name */ end; else do; pathname = substr (il, lin+1, i-lin-1); /* find out if it's of form seg$entry */ dol = index (pathname, "$"); if dol > 0 then do; /* it is */ entry_name = substr (pathname, dol + 1); pathname = substr (pathname, 1, dol - 1); end; else entry_name = pathname; j = index (reverse (entry_name), ">"); if j > 0 then entry_name = substr (entry_name, 32 -j); if substr (pathname, 1, 2) = "&n" then do; pathname = substr (pathname, 3); lin = lin + 2; end; call expand_path_ (addr (pathname), i-lin-1, addr (dir_name), addr (ent_name), code); if code ^= 0 then do; com1: call com_err_ (code, "debug", pathname); go to rskip; end; call hcs_$fs_get_seg_ptr (pathname, pp, code); /* is segment already known ? */ if pp ^= null then do; /* yes, get real names for the segment */ call hcs_$fs_get_path_name (pp, dir_name, itemp, ent_name, code); go to check1; end; call hcs_$initiate (dir_name, ent_name, "", 0, 0, pp, code); /* no, initiate it */ if code ^= 0 then if code ^= error_table_$segknown then go to com1; end; check1: lin = i+1; do i = max_stack to 0 by -1; /* search the stack for the procedure pointer */ sp = stack_ptr_array (i); /* get current stack pointer */ call db_fill_snt$proc_ptr (sp, tpp); if tpp ^= null () then if baseno (pp) = baseno (tpp) then do; /* we've found a good segment */ stack_depth = i; /* set index into stack */ call db_fill_snt (sp, sntp); /* Get data about working segment. */ if snt.ent_pt_name = entry_name then do; /* make sure it's really right frame */ data_ptr = sp; /* set defaults */ data_id = "s"; found3: offset = 0; data_format = "h"; input_type = "a"; go to depth_2; end; end; end; snt.symp = null; snt.symflag = "1"b; /* set flag saying we haven't got symp yet */ snt.pp = pp; snt.sp = null; snt.lp = ptr (baseptr (stack_header.lot_ptr -> lot (binary (baseno (pp))).segno), stack_header.lot_ptr -> lot (binary (baseno (pp))).offset); snt.ent_name = ent_name; snt.dir_name = dir_name; snt.ent_pt_name = entry_name; /* use reference name for symbol table */ data_ptr = pp; stack_depth = -1; /* stack depth is undefined */ data_id = "t"; go to found3; /* */ /* come here when a star is encountered */ label_1 (16): label_2 (16): lin = lin+1; if data_ptr -> its.its_mod ^= "100011"b then do; call ioa_$ioa_stream (debug_output, "Cannot indirect through ^w ^w.", data_ptr -> ff.w0, data_ptr -> ff.w1); go to rskip; end; data_ptr = data_ptr -> based_ptr; /* indirect once through ptr */ input_type = "*"; star1: offset = binary (rel (data_ptr), 17); /* set up offset variable */ snt.symp = null; /* fill in snt structure */ snt.symflag = "1"b; snt.pp = ptr (data_ptr, 0); snt.sp = null; snt.lp = ptr (baseptr (stack_header.lot_ptr -> lot (binary (baseno (data_ptr))).segno), stack_header.lot_ptr -> lot (binary (baseno (data_ptr))).offset); call hcs_$fs_get_path_name (data_ptr, snt.dir_name, itemp, snt.ent_name, code); snt.ent_pt_name = snt.ent_name; stack_depth = -1; data_id = "t"; go to relative_offset; /* come here if a syntax error is encountered while scanning the command line */ label_1 (0): label_2 (0): label_3 (0): go to syntax_error; label_2 (2): label_3 (2): go to syntax_error; label_2 (3): label_3 (3): go to syntax_error; label_3 (16): label_2 (17): label_3 (17): label_3 (4): label_3 (14): label_3 (5): label_3 (6): label_3 (13): syntax_error: call ioa_$ioa_stream (debug_output, "Syntax error"); label_1 (12): rskip: db_action_code = 1; return; skip: i = index (substr (il, lin, ill-lin+1), ";"); if i > 0 then do; lin = lin + i; if lin < ill then go to depth_1; end; lin = ill; return; /* */ /* come here on "." */ label_1 (17): if lin + 1 >= ill then go to no_comm; cmc = substr (il, lin+1, 1); if verify (cmc, "0123456789") = 0 then do; /* no command name, set stack frame */ stack_depth = db_get_count$dec (il, lin+1, lin); /* pick up desired stack depth */ i = stack_depth; /* in case error, set frame to 0 */ go to set_stack; end; nv = type (ilp -> bi.ts (lin+2)); /* get type of character after command */ if cmc = "t" then call stack_trace; else if cmc = "+" | cmc = "-" then do; /* pop or push stack */ i = db_get_count$dec (il, lin+1, lin); stack_depth = stack_depth + i; set_stack: if stack_depth < 0 | stack_depth > max_stack then do; call ioa_$ioa_stream (debug_output, "^d not in stack range.", stack_depth); stack_depth = stack_depth - i; go to rskip; end; call db_fill_snt (stack_ptr_array (stack_depth), sntp); /* get data for this new frame */ if snt.pp = null () then call ioa_$ioa_stream (debug_output, "Cannot get text section for stack frame."); data_ptr = snt.sp; data_id = "s"; data_format = "h"; offset = 0; end; else if cmc = "|" | cmc = "." then do; substr (il, 1, lin+1) = " "; in_debug = "0"b; /* pass all conditions on */ call cu_$cp (ilp, ill, i); in_debug = "1"b; return; end; else if cmc = "d" then do; fboff = binary (addr (data_ptr) -> its.bit_offset, 9); call ioa_$ioa_stream (debug_output, "^d /^a/^o(^d)&^a,^a ^o", stack_depth, snt.ent_name, offset, fboff, data_id, data_format, binary (baseno (snt.pp), 18)); end; else if cmc = "D" then do; fboff = binary (addr (data_ptr) -> its.bit_offset, 9); call ioa_$ioa_stream (debug_output, "^d /^a>^a/^o(^d)&^a,^a ^o", stack_depth, snt.dir_name, snt.ent_name, offset, fboff, data_id, data_format, binary (baseno (snt.pp), 18)); end; else if cmc = "m" then do; /* output mode */ if substr (il, lin+2, 1) = "b" then print_mode = 0; else if substr (il, lin+2, 1) = "l" then print_mode = 1; else go to syntax_error; end; else if cmc = "c" then do; cmc = substr (il, lin+2, 1); /* get next character */ if cmc = "t" then do; /* into temporary break mode */ lin = lin + 1; temp_break_mode = 1; end; else if cmc = "r" then do; /* regular break mode */ lin = lin + 1; temp_break_mode = 0; end; if substr (il, lin+2, 1) = "," then num_skips = db_get_count$dec (il, lin+3, lin) + 1; else num_skips = 1; /* num_skips is times to skip the break */ db_action_code = 3; return; end; else if cmc = "q" then do; db_action_code = 2; return; end; else if cmc = "b" then do; /* some type of break command */ i = lin + 2; cmc = substr (il, i, 1); /* get the particular break command name */ if cmc = "g" then do; /* global break request */ cmc = substr (il, i+1, 1); /* get the command char */ if cmc = "t" then do; /* .bge set up global exec line */ i = i + 2; /* get index of first character of exec line */ temp_comd_len = ill-i+1; if temp_comd_len = 1 then temp_comd_len = 0; else temp_comd_line = substr (il, i, temp_comd_len); /* copy string to execute into static */ return; /* read next request line */ end; lin = i + 2; /* point past request type */ call get_break_action_code; if break_action_code = 0 then goto skip; else call db_break$global (break_action_code, break_data_len, break_data_line, print_mode); if break_return = 1 then lin = ill; goto skip; end; if cmc = "d" then do; /* change default break segment */ if ^get_char (i+1, lin, char) then do; call db_break$print_default; go to skip; end; pathname = substr (il, lin, ill-lin); /* get name of segment */ nv = cv_oct_check_ (pathname, code); /* see if number was given */ if code = 0 then do; tp = baseptr (nv); /* get pointer to break seg */ end; else do; if substr (pathname, 1, 2) = "&n" then do; pathname = substr (pathname, 3); lin = lin + 2; end; call expand_path_ (addr (pathname), ill-lin, addr (dir_name), addr (ent_name), code); call hcs_$fs_get_seg_ptr (pathname, tp, code); if tp ^= null then go to got_seg; /* if refence name is known */ call hcs_$initiate (dir_name, ent_name, "", 0, 0, tp, code); if tp = null then go to com1; end; got_seg: call db_break$set_default (tp); /* set up default seg */ return; end; if cmc = "p" then do; /* print break segs */ call db_break$print_bseg (print_mode); go to skip; end; if ^get_char (i + 1, i, "") then do; lin = i; call get_break_action_code; if break_action_code > 0 then do; call db_break$sub_global (break_action_code, break_data_len, break_data_line, print_mode); if break_return > 0 then lin = ill; end; goto skip; end; nv = db_get_count$dec (il, i, lin); /* Get break number. */ if nv <= 0 then do; /* and make sure it's okay */ call ioa_$ioa_stream (debug_output, "Invalid break number."); go to rskip; end; if cmc = "s" then do; i = db_get_count$dec (il, lin+1, lin); call db_break$set_skips (nv, i); go to skip; end; call get_break_action_code; if break_action_code = 0 then goto skip; else call db_break$single (nv, break_action_code, break_data_len, break_data_line, print_mode); if break_return = 1 then lin = ill; goto skip; end; /* */ else if cmc = "a" then do; if snt.sp = null then do; /* must have stack frame for arglist print out */ nost: call ioa_$ioa_stream (debug_output, "No argument list available."); go to rskip; end; if snt.sp -> stack_frame.prev_sp -> stack_frame_flags.signaller then go to nost; if snt.sp -> stack_frame.arg_ptr = null () then go to nost; if nv = 7 then do; /* if comma, use mode specified and do all args */ cmc = substr (il, lin+3, 1); i = -1; end; else if nv = 5 | nv = 13 then do; i = db_get_count$dec (il, lin+2, lin); if substr (il, lin, 1) = "," then cmc = substr (il, lin+1, 1); else cmc = "?"; end; else if nv = 12 | nv = 15 then do; i = -1; cmc = "?"; end; list_arg: call list_arg_ (i, cmc, snt.sp -> stack_frame.arg_ptr); end; else if cmc = "f" /* get pointer to fault conditions */ then call db_find_mc (snt.sp, "0"b, db_mc_ptr); else if cmc = "C" /* get pointer to crawlout conditions */ then call db_find_mc (snt.sp, "1"b, db_mc_ptr); else if cmc = "s" then do; attach, open = "0"b; if substr (il, lin+2, 1) = "i" then j = 1; else if substr (il, lin+2, 1) = "o" then j = 2; else go to skip; lin = lin + 3; i = verify (substr (il, lin, ill-lin+1), " "); if i > 1 then do; lin = lin + i - 1; i = search (substr (il, lin, ill-lin+1), " ; "); if i = 0 then i = ill; else i = lin + i -2; switch_name = substr (il, lin, i-lin+1); call check_switch; call iox_$find_iocb (switch_name, pp, code35); if code35 ^= 0 then goto switch_err; if pp -> iocb.attach_descrip_ptr = null then do; call ioa_$ioa_stream (debug_output, "^a switch not attached", switch_name); goto skip; end; if pp -> iocb.open_descrip_ptr = null then do; call ioa_$ioa_stream (debug_output, "^a switch not open", switch_name); goto skip; end; end; else do; if j = 1 then switch_name = "debug_input"; else switch_name = "debug_output"; call check_switch; /* Is this the same switch? */ call iox_$find_iocb (switch_name, pp, code35); if code35 ^= 0 then go to switch_err; if pp -> iocb.attach_descrip_ptr = null then do; call iox_$attach_ioname (switch_name, pp, "syn_ user_i/o", code35); if code35 ^= 0 then go to switch_err; attach = "1"b; end; if pp -> iocb.open_descrip_ptr = null then do; call iox_$open (pp, j, "0"b, code35); if code35 ^= 0 then go to switch_err; open = "1"b; end; end; if debug_io_open (j) then call iox_$close (debug_io_ptr (j), code35); if debug_io_attach (j) then call iox_$detach_iocb (debug_io_ptr (j), code35); debug_io_ptr (j) = pp; debug_io_attach (j) = attach; debug_io_open (j) = open; if j = 1 then debug_input = switch_name; else debug_output = switch_name; go to skip; switch_err: call com_err_ (code35, "debug"); go to skip; end; else no_comm: call ioa_$ioa_stream (debug_output, "db"); go to skip; /* */ /* come here if we are looking at a register command */ label_1 (4): do i = lin+1 to lin+4 while (is_name (ilp -> bi.ts (i))); end; reg_name = substr (il, lin+1, i-lin-1); do i = lin+1 to ill while (substr (il, i, 1) ^= ";" & substr (il, i, 1) ^= "="); end; if i >= ill | substr (il, i, 1) ^= "=" then do; if ill = lin + 1 then if substr (il, ill, 1) = new_line then goto syntax_error; /* avoid "$(nl)" */ call db_regs$print (db_mc_ptr, reg_name, print_mode); go to skip; end; if ^get_char (i + 1, i, "") then goto syntax_error; temp_reg_val = db_get_count$double (il, i, lin); /* is an assignment */ if i = lin then goto syntax_error; if substr (il, lin, 1) = "|" then do; /* pointer value, parse it */ call db_parse_arg$ptr_offset (il, lin, ill, binary (temp_reg_val, 17), addr (temp_reg_val), d_type, nv); if d_type ^= 13 then go to syntax_error; end; reg_val = addr (temp_reg_val) -> based_bit72; call db_regs$assign (db_mc_ptr, reg_name, reg_val, print_mode); /* assign a value to the register */ go to skip; /* */ /* . handlers */ label_1 (13): label_2 (13): cmc = substr (il, lin+1, 1); if lin >= ill then go to syntax_error; if cmc = "d" | cmc = "o" then go to offset1; if cmc = "n" then do; /* next char escaped */ lin = lin+2; go to offsetl; end; if cmc ^= data_id then new_type = 1; else new_type = 0; goto relative_offset; /* */ /* come here to set a break point */ label_1 (9): label_2 (9): label_3 (9): if data_id = "s" then tp = ptr (snt.pp, binary (rel (data_ptr))-binary (rel (snt.sp))); else tp = data_ptr; /* force pointer to text if in stack */ call db_break$set_break (tp, 0, sntp, print_mode); /* set the break */ go to skip; /* */ /* come here when restarting a program */ label_1 (10): label_2 (10): label_3 (10): if stack_depth > max_stack | stack_depth < 0 then call ioa_$ioa_stream (debug_output, "No stack frame for given segment."); else do; addr (goto_label) -> label_map.pp = data_ptr; addr (goto_label) -> label_map.sp = snt.sp; goto goto_label; end; go to rskip; /* come here if scanning a number in a type 1 command */ label_1 (5): input_type = "a"; /* user typed an offset */ offset1: offset = 0; goto relative_offset; /* */ /* come here when 'offset' has been established. Search for an optional relative offset */ label_2 (4): label_2 (5): label_1 (6): label_2 (6): relative_offset: code = 0; continue = "1"b; do while (code = 0 & continue); if ^get_char (lin, lin, char) then continue = "0"b; else do; if char = "&" then do; char = substr (il, lin+1, 1); if char = "d" | char = "o" then do; offset = offset + db_get_count (il, lin, lin); call set_data_ptr (data_id); end; else do; if char ^= data_id then new_type = 1; else new_type = 0; if new_type = 1 then data_format = "h"; if char = "p" then call parse_parameter (lin, code); else if char = "a" then call parse_source (lin, code); else if char = "n" then do; lin = lin +2; if lin >= ill then goto syntax_error; goto namel; end; else do; call set_data_ptr (char); if code = 0 then data_id = char; lin = lin +2; end; end; end; else do; if char = "+" then offset_incr = db_get_count (il, lin + 1, lin); else if char = "-" then offset_incr = - db_get_count (il, lin + 1, lin); else if verify (char, NUMBER) = 0 then offset_incr = db_get_count (il, lin, lin); else if char = "$" then do; do i = lin+1 to lin+4 while (is_name (ilp -> bi.ts (i))); end; reg_name = substr (il, lin+1, i-lin-1); lin = i; call db_regs$get (db_mc_ptr, reg_name, reg_val, print_mode); offset_incr = binary (reg_val); end; else continue = "0"b; /* must not be a relative offset */ if continue then do; offset = offset + offset_incr; call set_data_ptr (data_id); end; end; end; end; if code ^= 0 then do; if code > 0 then call ioa_$ioa_stream (debug_output, "^a for ^a", err_mess (code), snt.ent_name); goto rskip; end; go to depth_4; /* come here if changing output mode : , [print mode] [amount to print] */ label_1 (7): label_2 (7): label_3 (7): call parse_print; goto print; label_2 (12): label_3 (12): label_1 (15): label_2 (15): label_3 (15): print: if data_format = "n" then go to skip; pp = data_ptr; if data_id = "s" then nv = binary (rel (pp)) - binary (rel (snt.sp)); else if data_id = "l" then nv = binary (rel (pp)) - binary (rel (snt.lp)); else if data_id = "i" then nv = binary (rel (pp)) - binary (rel (snt.static_ptr)); else nv = binary (rel (pp)); call db_print (debug_io_ptr (2), debug_output, pp, data_format, nv, pc, sntp, d_type, max_size); go to skip; /* come here when an equal sign is encountered */ label_1 (8): label_2 (8): label_3 (8): lin = lin + 1; pp = data_ptr; /* If the assignment is not to a program variable the default is octal. */ if input_type = "v" then dec_default = "1"b; else dec_default = "0"b; call db_assign (il, lin, ill, pp, sntp, db_mc_ptr, d_type, pc, max_size, print_mode, dec_default); go to skip; /* INTERNAL PROCEDURES */ is_name: proc (b9) returns (bit (1) aligned); dcl b9 fixed bin (8) unal, t fixed bin; t = type (b9); if t ^= 14 then if t ^= 5 then return ("0"b); return ("1"b); end; /* */ get_break_action_code: proc; break_data_len, break_action_code, break_return = 0; break_data_line = " "; if cmc = "l" then break_action_code = 1; else if cmc = "r" then break_action_code = 2; else if cmc = "o" then break_action_code = 3; else if cmc = "n" then break_action_code = 4; else if cmc = "e" then do; break_action_code = 5; break_data_len = ill-lin+1; if break_data_len = 1 then break_data_len = 0; else break_data_line = substr (il, lin, break_data_len); break_return = 1; end; else if cmc = "c" then do; break_action_code = 6; call db_parse_condition$set (il, lin, ill, break_data_len, break_data_line, code); if code = 100 then goto syntax_error; if code ^= 0 then call ioa_$ioa_stream (debug_output, "Symbol error in conditional break."); end; else call ioa_$ioa_stream (debug_output, "Unknown break request"); end get_break_action_code; type: proc (n) returns (fixed bin); dcl n fixed bin (8) unal; dcl table (0: 127) fixed bin static init ((10)0, 15, (21)0, 11, 0, 14, 0, 4, 2, 13, (3)0, 16, 6, 7, 6, 17, 3, (10)5, 1, 12, 9, 8, 10, (2)0, (26)14, (4)0, 14, 0, (26)14, 0, 17, (3)0); /* The table array has the following meaning: 0 = illegal 1 = : 2 = % 3 = / 4 = $ 5 = number 6 = + or - 7 = , 8 = = 9 = < 10 = > 11 = blank 12 = ; 13 = & 14 = letter 15 = new-line 16 = * 17 = | or . */ if n > -1 then if n < 128 then return (table (n)); /* legal ascii value */ call ioa_$ioa_stream (debug_output, "invalid character ""^a""", substr (il, n, 1)); go to rskip; /* error return */ end type; check_switch: proc; /* This procedure compares the old switch name and the new switch name. If they are the same * a message is printed and the procedure exits to skip which looks for the next request. */ if j = 1 then if switch_name ^= debug_input then return; else; else if switch_name ^= debug_output then return; call ioa_$ioa_stream (debug_output, "Switch already set to ^a", switch_name); goto skip; end check_switch; /* This procedure prints the error message for db_sym and exits to rskip to * find the next db request. */ sym_err: proc; dcl mess char (80) var; mess = ""; if code = 1 then mess = "Symbol " || sym_name || " not found for " || snt.ent_name; else if code = 2 then mess = "No symbol table for " || snt.ent_name; else if code = 3 then mess = "No linkage section for " || snt.ent_name; else if code = 4 then mess = "No stack frame for " || snt.ent_name; else if code = 5 then mess = "Cannot get address of " || sym_name; else if code = 6 then mess = "Cannot get size of " || sym_name; else if code = 7 then go to syntax_error; else if code = 8 then mess = "Subscripting error in " || sym_name; else if code = 9 then mess = "Invalid subscript in " || sym_name; else if code = 10 then mess = "Based variable error in " || sym_name; else if code = 11 then mess = "Too many structure levels in " || sym_name; else if code = 12 then mess = "Symbol is too long " || sym_name; else if code = 13 then mess = "Reference is ambiguous " || sym_name; else if code = 14 then mess = sym_name || " is entry constant; not supported"; else if code = 15 then mess = "Symbol table for this language is not supported by debug."; if mess ^= "" then call ioa_$ioa_stream (debug_output, mess); go to rskip; end sym_err; /* This procedure searches for the next non-blank character in the line beginning with index. It returns "0"b if the rest of the line is blank. Otherwise it returns "1"b, the index and the character found. */ get_char: proc (index_in, index_out, char_out) returns (bit (1)); dcl index_in fixed bin; dcl index_out fixed bin; dcl char_out char (1) aligned; dcl i fixed bin; index_out = index_in; if index_out < ill then do; i = verify (substr (il, index_out, ill - index_out +1), " "); if i > 0 then do; index_out = index_out + i -1; char_out = substr (il, index_out, 1); if char_out ^= ";" & char_out ^= new_line then return ("1"b); end; else index_out = ill; end; return ("0"b); end get_char; /* */ parse_print: proc; dcl i fixed bin; dcl size fixed bin; dcl (have_mode, have_size, have_count) bit (1); have_mode, have_size, have_count = "0"b; do while (get_char (lin+1, lin, char)); /* () */ if char = "(" then do; if ^have_size then do; have_size = "1"b; i = db_get_count$dec (il, lin+1, lin); if i > 0 then do; if get_char (lin, lin, char) then do; if char = ")" then do; size = i; goto next; end; end; end; end; goto syntax_error; end; /* */ else if index (NUMBER, char) > 0 then do; if have_count then goto syntax_error; pc = db_get_count$dec (il, lin, lin); pc = max (pc, 1); have_count = "1"b; lin = lin -1; end; /* Set mode and default size. A change in mode causes the amount to print to be set to 1 */ else do; if substr (il, lin, 1) = "n" then goto skip; do i = 1 to hbound (MODES, 1) while (substr (il, lin, length (MODES (i))) ^= MODES (i)); end; if i > hbound (MODES, 1) then do; call ioa_$ioa_stream (debug_output, "Undefined output mode ""^a""", substr (il, lin, 1)); goto rskip; end; data_format = MODES (i); lin = lin + length (MODES (i)) -1; if data_format = "p" then max_size = 72; else if data_format = "comp-7" then max_size = 18; else if data_format = "el" | data_format = "fl" then max_size = 72; else max_size = 36; if ^have_count then pc = 1; end; next: end; /* data_format and pc have been set. Only set size if it is valid. */ if have_size then do; if data_format = "p" & ^(size = 36 | size = 72) then do; call ioa_$ioa_stream (debug_output, "Invalid size for pointer. Use 36 or 72"); goto rskip; end; else if data_format = "comp-8" | data_format = "comp-5" then max_size = divide (size*9, 2, 17, 0); else max_size = size; end; end parse_print; /* */ /* This procedure parses &p requests and sets the data_ptr and offset and pc (data size). code = 0 Pointer was found to the argument. code = err_no_stack No stack frame, so no parameter list. code = -1 Illegal number for argument poaition. index (input) Set to start of string "&p" (output) Set to first character not used in parse */ parse_parameter: proc (index, code); dcl index fixed bin; dcl code fixed bin; i = db_get_count$dec (il, index+2, index); if snt.sp = null then code = err_no_stack; else do; if snt.sp -> stack_frame.arg_ptr = null then code = err_no_stack; else do; if i <= 0 | i > binary (snt.sp -> stack_frame.arg_ptr -> arg_list.num_args, 17) then do; call ioa_$ioa_stream (debug_output, "No parameter ^d.", i); code = -1; /* no error message, but error return */ end; else do; call decode_descriptor_ (snt.sp -> stack_frame.arg_ptr, i, code, switch, ndims, size, scale); data_ptr = snt.sp -> stack_frame.arg_ptr -> arg_list.args (i); offset = binary (rel (data_ptr), 18); /* COBOL data codes */ if code = 38 | code = 39 | code = 41 then do; pc = 1; if code = 41 then data_format = "comp-8"; else data_format = "comp-5"; if code = 38 then size = divide (size*9, 2, 17, 0); else size = divide ((size+1)*9, 2, 17, 0); end; else if code > 0 then do; data_format = substr ("dhffdhfhhhhhphpphbbaah", code, 1); /* decode type into mode */ if code = 2 then pc = 2; /* if double precision fixed point */ else if code = 5 then pc = 2; /* complex fixed short */ else if code = 7 then pc = 2; /* complex float short */ else if code = 15 then pc = 2; /* label variable */ else if code = 16 then pc = 2; /* entry variable */ else if data_format = "a" then do; if code = 22 then pc = max (0, addrel (data_ptr, -1) -> based_fix); else pc = size; end; else if data_format = "b" then if code = 19 then pc = size; else pc = max (0, addrel (data_ptr, -1) -> based_fix); data_id = "p"; end; code = 0; end; end; end; return; end parse_parameter; /* */ /* This procedure sets offset and data_ptr to the text beginning at a given source line. code = 0 Was able to set the pointer to object code for line number. data_ptr = location of first instruction on the line. data_format = "s" (db_print mode for source code ) data_id = "t" (segment_ID is &t for text ) code = no_sym_tab The procedure was not compiled with the table option. code = -1 No code generated for 10 lines after the line number requested. */ parse_source: proc (index, code); dcl index fixed bin; dcl code fixed bin; line_number = db_get_count$dec (il, index+2, index); if snt.symflag then call db_get_sym (sntp); tp = snt.symp; /* get pointer to symbol table */ if (^snt.std & tp = null) | snt.headp = null then code = err_no_sym_tab; else do; switch = "0"b; do line_number = line_number to line_number + 10 while (code = 0); if snt.std then offset = stu_$get_runtime_location (snt.headp, line_number); else call stu_$get_location (snt.symp, line_number, offset); if offset = -2 then code = err_no_sym_tab; else do; if offset >= 0 then do; /* if positive offset, ok */ data_id = "t"; data_ptr = ptr (snt.pp, offset); data_format = "s"; if switch then call ioa_$ioa_stream (debug_output, "Using line number ^d.", line_number); return; end; else switch = "1"b; end; end; if code = 0 then do; code = -1; call ioa_$ioa_stream (debug_output, "debug: No code generated for 10 lines after ^d.", line_number - 11); end; end; return; end parse_source; /* */ set_data_ptr: proc (segment_id); dcl segment_id char (1) aligned; if segment_id = "t" then data_ptr = ptr (snt.pp, offset); else if segment_id = "s" then do; if snt.sp = null then code = err_no_stack; else do; data_ptr = addrel (snt.sp, offset); end; end; else if segment_id = "l" then do; if snt.pp = null () then code = err_no_linkage; else do; snt.lp = ptr (baseptr (stack_header.lot_ptr -> lot (binary (baseno (snt.pp))).segno), stack_header.lot_ptr -> lot (binary (baseno (snt.pp))).offset); if rel (snt.lp) = "0"b then code = err_no_linkage; else do; data_ptr = addrel (snt.lp, offset); end; end; end; else if segment_id = "i" then do; if snt.pp = null () then code = err_no_static; else do; snt.static_ptr = ptr (baseptr (stack_header.isot_ptr -> lot (binary (baseno (snt.pp))).segno), stack_header.isot_ptr -> lot (binary (baseno (snt.pp))).offset); if rel (snt.static_ptr) = "0"b then code = err_no_static; else do; data_ptr = addrel (snt.static_ptr, offset); end; end; end; else do; call ioa_$ioa_stream (debug_output, "bad segment ID ""^a""", segment_id); code = -1; end; end set_data_ptr; /* */ /* * This procedure parses the trace stack request. * .tN,M where N is the number of the first frame to print and M is the number of frames to be printed. * * It uses global variables: * lin input = index of "." on line * output = index of last character used for trace stack request */ stack_trace: proc (); dcl (i, start, last) fixed bin; dcl ent_name char (32) aligned; dcl 1 trace_snt aligned like snt; dcl trace_snt_ptr ptr; trace_snt_ptr = addr (trace_snt); start = 0; last = max_stack; lin = lin + 2; if verify (substr (il, lin, 1), NUMBER) = 0 then start = db_get_count$dec (il, lin, lin); if substr (il, lin, 1) = "," then last = start + db_get_count$dec (il, lin+1, lin) -1; start = max (0, start); start = min (start, max_stack); last = min (last, max_stack); if print_mode = 1 then call ioa_$ioa_stream (debug_output, "^/DEPTH SEGNO OFFSET ^5xNAME^20xCONDITION^/"); do i = start to last; call db_fill_snt (stack_ptr_array (i), trace_snt_ptr); /* get data for this stack frame */ if is_condition_frame_ (trace_snt.sp) then do; call find_condition_info_ (trace_snt.sp, addr (cond_info), code); ent_name = cond_info.condition_name; end; else ent_name = ""; call ioa_$ioa_stream (debug_output, " ^4d ^5o ^6o ^a|^o^2-^a", i, binary (baseno (trace_snt.pp), 15), binary (rel (trace_snt.sp), 18), trace_snt.ent_pt_name, binary (rel (trace_snt.pp), 18), ent_name); end; end stack_trace; end db_parse;  db_parse_arg.pl1 11/04/82 1959.8rew 11/04/82 1628.7 59238 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_parse_arg: proc (il, lin, ill, retp, type, size); dcl l fixed bin; dcl il char (132) aligned, /* input character string to be scanned */ conversion bit (1) aligned, lin fixed bin, /* starting index into il */ ill fixed bin, /* length of il */ retp ptr, /* pointer to location in which to return arg */ type fixed bin, /* type of returned arg */ size fixed bin; /* size in chars or bits of returned arg */ /* types handled: 1 fixed bin (octal or decimal) 3 float bin 13 pointer 19 bit string 21 char string 0 variable -1 no arg error -2 syntax error -3 % in string */ dcl (bit, fixed, addrel, substr, mod, ptr) builtin; dcl db_conversion condition; dcl neg fixed bin; dcl work char (80); dcl bstr bit (size) based (retp) aligned, cstr char (size) based (retp) aligned, (i, j, cstrt, k, depth) fixed bin, nl char (1) aligned static init (" "), (temp, temp1) float bin, fword fixed bin based, flword float bin based, c1 char (1) aligned, bptr ptr based, db_get_count$data ext entry (char (132) aligned, fixed bin, fixed bin, ptr, fixed bin, fixed bin), db_get_count ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin), db_get_count$dec ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin); dcl assign_ ext entry (ptr, fixed bin, fixed bin, ptr, fixed bin, fixed bin); %include its; /* */ type = -1; /* initialize return args */ size = 0; neg = 0; do i = lin to ill while (substr (il, i, 1) = " "); /* skip leading blanks */ end; if i >= ill then go to ERROR; /* syntax error if off end of string */ c1 = substr (il, i, 1); /* get first character of argument */ if c1 = ")" | c1 = ";" then return; /* must signal no arg error */ if c1 = "&" then do; /* decimal fixed bin */ if substr (il, i+1, 1) = "n" then do; i = i + 2; go to is_var; end; if substr (il, i+1, 1) = "d" | substr (il, i+1, 1) = "o" then go to get_fixed; else go to ERROR; end; if c1 = "." then do; /* decimal # or floating # */ call get_float; end; if c1 = """" then do; /* bit or char string */ cstrt = 0; scan_end_chars: do j = i+1 to ill while (substr (il, j, 1) ^= """"); /* look for end of string */ end; if j >= ill then go to ERROR; /* syntax error */ size = j - i - 1; /* get size of string */ if substr (il, j+1, 1) = "b" then do; /* bit string */ if cstrt ^= 0 then go to ERROR; /* have found doubled quotes in it */ bstr = "0"b; /* set to zeros to start */ do k = 1 to size; /* set each one bit ON */ if substr (il, i+k, 1) = "1" then substr (bstr, k, 1) = "1"b; end; type = 19; lin = j+2; return; end; /* check here for "" in char string */ if substr (il, j+1, 1) = """" then do; substr (cstr, cstrt+1, size+1) = substr (il, i+1, size+1); /* copy string ending with " */ i = j + 1; /* remember where in scan we are */ cstrt = cstrt+size+1; /* update filled in offset in output string */ go to scan_end_chars; /* and scan for closing " */ end; substr (cstr, cstrt+1, size) = substr (il, i+1, size); /* copy string */ size = cstrt+size; /* and remember final size for caller */ type = 21; lin = j + 1; return; end; if verify (c1, "-+0123456789") = 0 then do; get_fixed: j = db_get_count$dec (il, i, lin); /* assume afixed binary no. */ if i = lin then go to ERROR; if substr (il, lin, 1) = "." | substr (il, lin, 1) = "e" then call get_float; else if substr (il, lin, 1) = "|" then do; j = db_get_count (il, i, lin); /* rescan in octal for segment no. */ call get_offset; end; type = 1; retp -> fword = j; go to RETURN; end; if c1 = "%" then do; /* dummy argument */ type = -3; lin = i+1; /* set up return arg */ c1 = substr (il, lin, 1); if verify (c1, ", );") ^= 0 then go to ERROR; return; end; is_var: depth = 0; /* argument must be a variable */ do lin = i+1 to ill; /* scan char by char */ c1 = substr (il, lin, 1); /* pick up current character */ if verify (c1, "0123456789 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ._") = 0 then go to endl; if c1 = "(" then depth = depth + 1; if c1 = ")" then do; if depth > 0 then depth = depth - 1; else go to done; end; else if c1 = "-" then do; if substr (il, lin+1, 1) = ">" then lin = lin + 1; else if depth = 0 then go to done; end; else if depth = 0 then go to done; endl: end; go to ERROR; done: size = lin - i; /* get length of variable name */ cstr = substr (il, i, size); /* copy name into return area */ type = 0; RETURN: return; ERROR: type = -2; return; ptr_offset: entry (il, lin, ill, base_val, retp, type, size); /* entry to parse the offset portion of a pointer whose seg. no. is known */ dcl base_val fixed bin; j = base_val; call get_offset; get_float: proc; call db_get_count$data (il, i, lin, retp, 6, 35); if i = lin then go to ERROR;; type = 3; go to RETURN; end get_float; get_offset: proc; k = db_get_count (il, lin+1, lin); /* get offset */ retp -> bptr = ptr (baseptr (j), k); /* create and return pointer */ type = 13; if substr (il, lin, 1) = "(" then do; /* bit offset given */ j = db_get_count$dec (il, lin+1, lin); retp -> bptr = addrel (retp -> bptr, divide (j, 36, 18, 0)); /* maybe bit offset > 36 */ retp -> its.bit_offset = bit (fixed (mod (j, 36), 6)); /* stuff in bit offset */ if substr (il, lin, 1) ^= ")" then go to ERROR; lin = lin + 1; /* skip over last ")" */ end; if substr (il, lin, 1) = "[" then do; l = db_get_count$dec (il, lin+1, lin); if l > 7 then go to ERROR; retp -> its.ringno = bit (fixed (l, 3), 3); if substr (il, lin, 1) ^= "]" then go to ERROR; lin = lin + 1; end; go to RETURN; end get_offset; end;  db_parse_condition.pl1 11/04/82 1959.8rew 11/04/82 1628.7 79047 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_parse_condition: procedure; /* This procedure is called to parse condition data involved with a conditional break. * This procedure was created so that semantic considerations would not be present * in db_break. * * Written in Dec 72 for the 6180 by Bill Silver. */ dcl arg_cond_ptr ptr, /* Pointer to condition data passed as an * argument. */ break_map_ptr ptr, /* Pointer to the segments break map. */ cond_data char(236), /* Return area where condition data is * actually built. */ cond_len fixed bin, /* Actual size of the condition data. * 0 => no condition. */ sntp ptr; /* Pointer to debug's snt data. */ dcl il char(132) aligned, (lin, ill, acode) fixed bin; dcl cond_flag fixed bin; /* Return flag indicating whether condition * was met or not. 0 => YES, 1 => NO. */ dcl return_string char(72) var; /* Used to return compare line. /* This constant indicates the size of the whole condition data area. */ dcl cond_size fixed bin init(224) internal static; dcl cond_ptr ptr; /* Pointer to the condition data. */ dcl 1 cond_map based ( cond_ptr ) aligned, (2 relation, /* Relation between two variables. * 1 => "=", 2 => "^=". */ 2 p1, /* offset of first comparand */ 2 p2, /* ditto for 2nd (both are -1 if variable) */ 2 lname1, /* length of name1 */ 2 lname2) fixed bin, /* length of name2 */ 2 (name1,name2) char(40), /* names of variables used in comparison */ 2 compare char(64) aligned, /* contents of compare line for cond. break */ 2 (constant1,constant2) bit(288) aligned; /* constants used in comparison */ dcl (tp1,tp2,tp) ptr; dcl db_sym ext entry (char (72) var,ptr,ptr,fixed bin, fixed bin, char(1) aligned, char(*) aligned, fixed bin, fixed bin, fixed bin(35)), ioa_$ioa_stream ext entry options(variable), db_parse_arg ext entry (char (132) aligned,fixed bin,fixed bin,ptr,fixed bin,fixed bin); %include db_ext_stat_; dcl (i,j) fixed bin, code fixed bin(35), exec fixed bin, l fixed bin, no fixed bin, old_value fixed bin, pc fixed bin, pflag fixed bin, t2 fixed bin, temp fixed bin, relation fixed bin; dcl pcm fixed bin; dcl cp ptr; dcl char1 (32) char(1) based, char32 char(32) based; dcl (c1,c2) char (1) aligned, bits bit(pc) based, n1 char(72) var, str char (exec) based; dcl addr builtin, fixed builtin, null builtin, ptr builtin, rel builtin, substr builtin, unspec builtin; /* */ check: entry ( break_map_ptr, arg_cond_ptr, sntp, cond_flag ); /* This entry is called by db_break to determine if the condition of the specified * break has been met. The answer will be returned in cond_flag where: * 0 => YES, and 1 => NO. Note, in the case of an error the cond_flag will * be set to 0. */ cond_ptr = arg_cond_ptr; /* Copy argument pointer. */ pc = 36; /* Default size to compare is 1 word. */ cond_flag = 0; /* Initialize return arg. */ relation = cond_map.relation; i = cond_map.p1; /* get default pointer to data */ if i < 0 then do; n1 = substr(cond_map.name1,1,cond_map.lname1); if substr (n1,1,1) = "(" then do; /* got a numeric pointer (xxx|yyy) */ call db_parse_arg((n1),2,cond_map.lname1,addr(cond_map.constant1),j,exec); if substr(cond_map.constant1,31,6) ^= "100011"b then go to badcond; /* not "43" its pair */ unspec(tp1) = substr(cond_map.constant1,1,72); go to next_constant; end; call db_sym(n1,sntp,tp1,temp,t2,c1,c2,pc,pcm,code); /* get pointer to first data item */ if code ^= 0 then do; badcond: call ioa_$ioa_stream (debug_output, "Error in conditional break."); return; end; if c2 = "a" then pc = pc * 9; else if c2 = "p" then pc = 72; end; else tp1 = addr(cond_map.constant1); next_constant: i = cond_map.p2; if i < 0 then do; n1 = substr(cond_map.name2,1,cond_map.lname2); call db_sym(n1,sntp,tp2,temp,t2,c1,c2,pc,pcm,code); if code ^= 0 then go to badcond; if c2 = "a" then pc = pc * 9; else if c2 = "p" then pc = 72; end; else tp2 = addr(cond_map.constant2); if tp1 -> bits = tp2 -> bits then do; /* make compare */ if relation = 2 then cond_flag = 1; /* if looking for not equal we lose */ return; end; if relation = 1 then cond_flag = 1; /* lose if looking for equal */ return; /* */ print_line: entry ( arg_cond_ptr, return_string ); /* This entry is called by db_break in order to get a string of data which it * can print about a condition. */ return_string = arg_cond_ptr -> cond_map.compare; return; /* */ set: entry(il,lin,ill,cond_len,cond_data,acode); /* This entry is called to parse the condition line entered by the user and * to convert this input line into the appropriate condition data. The condition * data will then be returned to the caller ( db_parse ). */ acode = 0; /* zero out return error code */ pflag = 0; /* reset pointer relation flag */ cond_ptr = addr(cond_data); /* We will build the condition data * in our own area. */ pc = 36; /* default number of bits to compare */ if ill <= lin then do; /* resetting conditional break ? */ cond_len = 0; /* YES, reset condition. */ cond_data = " "; return; end; cond_map.compare = substr(il,lin,ill-lin); /* save compare line */ tp = addr(cond_map.constant1); /* default pointer to constant area */ call db_parse_arg(il,lin,ill,tp,j,exec); /* pick off first argument */ if j = 0 then do; /* a variable */ cond_map.name1 = tp -> str; /* copy name of variable into break */ if tp -> char1(1) = "/" then /* test for pointer */ if substr(il,lin,1) = "/" then do; /* handle form /xxx/yyyy */ pflag = 1; /* set flag for pointer case */ cp = addr(il); /* get pointer to original string */ tp -> char1(1) = "("; /* start change of form to (xxx|yyyy) */ tp -> char1(exec + 1) = "|"; do l = 1 to ill - lin while (cp->char1(lin + l) >= "0" & cp->char1(lin + l) <= "7"); tp -> char1(l + exec + 1) = cp -> char1(lin + l); end; exec = exec + l + 1; lin = lin + l; tp -> char1(exec) = ")"; cond_map.name1 = substr(tp->char32,1,exec); end; cond_map.lname1 = exec; cond_map.p1 = -1; /* indicate we've got a variable */ end; else if j < 0 then do; /* syntax error */ ser: acode = 100; /* special error code indicates syntax error */ return; end; else cond_map.p1 = 1; /* Filll in offset of constant area */ skip_blanks: do lin = lin to ill while(substr(il,lin,1) = " "); /* skip blanks */ end; if lin >= ill then go to ser; if pflag = 1 then /* are we handling pointer relation */ if substr(il,lin,2) ="&t" then /* is it valid */ do; pflag = 0; lin = lin + 2; /* start beyond the "&t" */ go to skip_blanks; /* scan for next symbol */ end; else go to ser; /* incorrect syntax for pointer relation */ if substr(il,lin,1) = "=" then relation = 1; /* get compare relation */ else if substr(il,lin,2) = "^=" then do; /* not-equal compare relation */ relation = 2; lin = lin + 1; /* one more character to skip */ end; else do; /* bad compare relation */ call ioa_$ioa_stream (debug_output, "Only ""="" and ""^^="" allowed."); code0: acode = 100; return; end; lin = lin + 1; /* scan over (rest of) compare relation */ tp = addr(cond_map.constant2); /* set default pointer */ call db_parse_arg(il,lin,ill,tp,j,exec); /* get second argument */ if j = 0 then do; /* a variable */ cond_map.name2 = tp -> str; /* copy name of variable into break */ cond_map.lname2 = exec; cond_map.p2 = -1; /* indicate we've got variable */ end; else if j < 0 then go to ser; else cond_map.p2 = 2; cond_map.relation = relation; /* Save relation for when condition * is tested. */ /* Now return condition line we have just made. Return the actual number of * characters used. The rest of the are will just be blank. */ cond_len = cond_size; end db_parse_condition;  db_print.pl1 11/04/82 1959.8rew 11/04/82 1628.8 155106 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_print: proc (arg_iocb_ptr, arg_output_switch, data_ptr, mode, rel_offset, arg_no_prt, sntp, data_type, data_size); /* Modified 10/76 by S. Barr to add COBOL data types and to use data_size with octal format */ /* Modified 1/77 by S. Barr to add number to print to "l" mode */ /* Modified 771116 by PG to add el & fl output modes */ /* parameters */ dcl arg_iocb_ptr ptr; /* arg_iocb pointer for iox_ ioa_ calls */ dcl arg_output_switch char (32); /* for print_text_ (to be removed eventually) */ dcl data_type fixed bin; dcl data_size fixed bin; dcl data_ptr ptr, mode char (*) aligned, (rel_offset, arg_no_prt) fixed bin; /* entries */ dcl print_text_ ext entry (ptr, fixed bin, char (*) aligned), db_get_sym ext entry (ptr), get_wdir_ ext entry returns (char (168) aligned), ioa_$ioa_switch entry options (variable), ioa_$ioa_switch_nnl entry options (variable), ioa_$rsnnl entry options (variable), db_line_no ext entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin); dcl comp_8_to_ascii_ entry (bit (*), char (*)); dcl gr_print_ entry (char (*)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)); dcl stu_$get_line entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin); dcl com_err_ entry options (variable); dcl condition_ entry (char (*), entry); dcl reversion_ entry (char (*)); /* automatic & based */ dcl string char (64), num fixed bin, iocb_ptr ptr, output_switch char (32) aligned; /* output_switch: default is user_output */ dcl i9 fixed bin (9), (no_prt, j, k, first, line_no, no, okp) fixed bin, code fixed bin (35), i fixed bin; dcl line_offset fixed bin; /* char. position of source line */ dcl line_length fixed bin; /* length of source line */ dcl file fixed bin; /* file containing source line */ dcl smap_ptr ptr; dcl packed_ptr ptr unal based (pp); dcl packed_bit_offset bit (6) based (pp); dcl hp ptr; dcl pp ptr, based_ptr ptr based; dcl bits bit (arg_no_prt) based (pp), cbit_offset char (8) aligned, str char (no_prt) based (pp); dcl 1 copy_its aligned like its ; dcl format char (20) var aligned init ("^6o ^6o ^v(^"); dcl per_line fixed bin init (4); /* no. of items per line */ dcl octal bit (1) init ("0"b); /* 1 = octal print out */ dcl packed_decimal bit (1) init ("0"b); /* 1 = packed_decimal format */ dcl float bit (1) init ("0"b); /* 1 = float binary data */ dcl (offset, loc) fixed bin; dcl 1 ff aligned based (pp), 2 (w0, w1, w2, w3, w4) fixed bin (35); dcl print_err bit (1) init ("1"b); /* 1 = print error message */ /* builtins */ declare (addr, addrel, baseno, binary, divide, fixed, max, min, null, ptr, rel, substr, mod, unspec, hbound) builtin; /* external static */ dcl iox_$user_output ptr ext; /* internal static */ dcl bit_loc (8) int static options (constant) init (0, 5, 9, 14, 18, 23, 27, 32); dcl last_source char (32) static init (" "); /* last source used for printing */ dcl MODES (21) char (6) static init ("a", "b", "p", "P", "i", "I", "l", "s", "o", "h", "d", "f", "e", "g", "x", "comp-6", "comp-7", "comp-8", "comp-5", "fl", "el"); /* include files */ %include component_info; %include db_snt; %include its; %include std_symbol_header; %include source_map; /* program */ if arg_iocb_ptr = null then do; iocb_ptr = iox_$user_output; output_switch = "user_output"; end; else do; output_switch = arg_output_switch; iocb_ptr = arg_iocb_ptr; end; no_prt = max (1, arg_no_prt); /* get number of units to print */ pp = data_ptr; /* get pointer to first word to be printed */ offset = rel_offset; /* get offset within stack or linkage */ loc = fixed (rel (pp), 17); call condition_ ("out_of_bounds", oob_handler); do j = 1 to hbound (MODES, 1) while (mode ^= MODES (j)); end; if j > hbound (MODES, 1) then do; call ioa_$ioa_switch (iocb_ptr, "Undefined output mode ""^a""", mode); return; end; goto label (j); /* a, x character string */ label (1): label (15): call ioa_$ioa_switch_nnl (iocb_ptr, "^6o ^6o """, loc, offset); if arg_no_prt > 0 then do; call iox_$put_chars (iocb_ptr, pp, arg_no_prt, code); if code ^= 0 then call com_err_ (code, "debug"); end; call ioa_$ioa_switch (iocb_ptr, """"); return; /* b bit string */ label (2): call ioa_$ioa_switch (iocb_ptr, "^6o ^6o ""^b""b", loc, offset, bits); return; /* p, P pointer */ label (3): label (4): if data_size = 36 then no = 1; else no = 2; do j = 1 to no_prt; if no = 2 then do; if pp -> its.its_mod ^= "100011"b | pp -> its.mod then call ioa_$ioa_switch (iocb_ptr, "^6o ^6o ^w ^w", loc, offset, w0, w1); else do; i9 = fixed (pp -> its.bit_offset, 9); /* get bit offset of pointer */ if i9 ^= 0 then call ioa_$rsnnl ("(^d)", cbit_offset, okp, i9); /* convert it to character */ else cbit_offset = ""; call ioa_$ioa_switch (iocb_ptr, "^6o ^6o ^o|^o^a", loc, offset, fixed (baseno (pp -> based_ptr), 18), fixed (rel (pp -> based_ptr), 18), cbit_offset); end; end; else do; if binary (packed_bit_offset) > 35 then call ioa_$ioa_switch (iocb_ptr, "^6o ^6o ^w", loc, offset, pp -> w0); else call ioa_$ioa_switch (iocb_ptr, "^6o ^6o ^p", loc, offset, packed_ptr); end; pp = addrel (pp, no); loc = loc + no; offset = offset + no; end; return; /* i, I instruction */ label (5): label (6): if sntp = null then okp = 0; /* ol_dump calls without snt table */ else okp = 1; /* Try to get line numbers */ j = 0; do while (j < no_prt); if okp = 1 then do; /* try to get source line */ call db_line_no (sntp, loc, first, no, line_no); if first < 0 then do; /* can't find source line no. */ okp = 0; no = no_prt - j; end; else do; call ioa_$ioa_switch (iocb_ptr, "LINE NUMBER ^d", line_no); no = no - loc + first; /* In case loc is in middle of line */ end; end; else no = no_prt; no = min (no, no_prt - j); call print_text_ (pp, no, output_switch); loc = loc + no; pp = addrel (pp, no); j = j + no; end; return; /* l instructions for a given line */ label (7): do j = 1 to no_prt; call db_line_no (sntp, loc, first, no, line_no); if first < 0 then goto ERROR_NO_LINE; call ioa_$ioa_switch (iocb_ptr, "LINE NUMBER ^d", line_no); call print_text_ (ptr (pp, first), no, output_switch); loc = loc + no; end; return; /* s source line */ label (8): call print_source; return; /* o, h octal */ label (9): label (10): octal = "1"b; format = format || ".3b ^)"; if mode = "o" then per_line = 8; call print_data; return; /* d, comp-6, comp-7 decimal */ label (11): label (16): label (17): format = format || "13d^)"; call print_data; return; /* f float binary */ label (12): float = "1"b; format = format || "8.4f^)"; call print_data; return; /* e */ label (13): float = "1"b; format = format || "8e^)"; call print_data; return; /* fl float-long */ label (20): float = "1"b; format = format || "19.6f^)"; call print_data; return; /* el exponential-long */ label (21): float = "1"b; format = format || "19e ^)"; call print_data; return; /* g graphic */ label (14): call gr_print_ (str); return; /* comp-5, comp-8 COBOL */ label (18): label (19): packed_decimal = "1"b; call print_data; return; out: /* for the out_of_bounds_handler */ return; ERROR_NO_LINE: call ioa_$ioa_switch (iocb_ptr, "Cannot get line."); return; /* */ /* print_data prints "per_line" data items on one line. It matches the data type with the format to prevent ioa_ from doing a data conversion before printing. The next line is checked with the current line. If it is the same, then "=====" will be printed on the line instead. This symbol will be printed only once for a series of repeated lines. */ print_data: proc; dcl same bit (1) init ("0"b); /* ON if current output line is a repeat */ dcl print_equal bit (1); /* ON if should print ===== */ dcl d_size fixed bin; dcl fl (4) float bin (63); dcl fx (4) fixed bin (71); dcl b bit (256); /* copy of number to print in octal */ dcl d fixed bin; /* number of octal digits to print */ dcl num_digits fixed bin; /* Number of digits for paced decimal comp-8 */ dcl check_ptr bit (1) aligned; /* ON, for comp-8 with odd number of digits */ dcl add_bit bit (1) aligned; /* ON, if must add bit to data ptr */ dcl next_p ptr; /* points to next item to print */ dcl fxb (8) fixed bin (35) based (pp); dcl bits (16) bit (d_size) based (pp); dcl based_comp bit (data_size+1) unal based (next_p); dcl data_line bit (data_line_len*2) unal based (pp); /* line data_line_lenust printed + next line */ dcl data_line_len fixed bin; /* number of bits in one line */ d_size = data_size; if d_size = 0 then d_size = 36; /* no size given for temporaries (%) */ if d_size >72 & ^packed_decimal then d_size = 36; data_line_len = d_size * per_line; /* COBOL - Packed decimal data with an odd number of digits as an alternating data size. (ie. 7 digits = 32 bits, 31...) db_print is given the smaller of these 2 sizes. The pointer is digit aligned the first time. Later a bit is added every other time to correct the pointer. */ check_ptr = "0"b; if packed_decimal then do; num_digits = divide (d_size *2+1, 9, 17, 0); check_ptr = (mod (num_digits, 2) ^= 0); unspec (copy_its) = unspec (pp); num = fixed (copy_its.bit_offset, 6); do i = 1 to 8 while (num > bit_loc (i)); end; /* If the pointer is not aligned on a digit boundary, then the pointer will be rounded up to the next boundary. */ if num ^= bit_loc (i) then do; i = min (i, 8); copy_its.bit_offset = substr (unspec (bit_loc (i)), 31, 6); unspec (pp) = unspec (copy_its); end; add_bit = "1"b; /* If there are an odd number of digits in a packed decimal number and we have the smaller of the two numbers then must add 2 bits for a line of 4 numbers. (i.e. 4*31+2 for 32, 31, 32, 31) */ if check_ptr then data_line_len = data_line_len +2; end; k = loc - offset; do while (no_prt > 0); per_line = min (no_prt, per_line); if same then if print_equal then do; call ioa_$ioa_switch (iocb_ptr, "======"); /* skip line */ print_equal = "0"b; end; else; else do; if octal then do; if d_size = 36 then call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, bits); /* Numbers to be printed in octal are copied into b so that they can be right justified. Procedure ioa_ left justifies. */ else do; call ioa_$ioa_switch_nnl (iocb_ptr, "^6o ^6o ", loc, offset); do j = 1 to per_line; b = "0"b; d = divide (d_size+2, 3, 17, 0); substr (b, d*3-d_size+1, d_size) = bits (j); call ioa_$ioa_switch_nnl (iocb_ptr, " ^v.3b", d, b); end; call ioa_$ioa_switch (iocb_ptr, ""); end; end; else if float then do; do j = 1 to per_line; fl (j) = 0; unspec (fl (j)) = unspec (bits (j)); end; call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, fl); end; /* COBOL data type */ else if packed_decimal then do; call ioa_$ioa_switch_nnl (iocb_ptr, "^6o ^6o ", loc, offset, per_line); next_p = pp; do j = 1 to per_line; call comp_8_to_ascii_ (based_comp, string); call ioa_$ioa_switch_nnl (iocb_ptr, " ^a", substr (string, 1, num_digits)); next_p = addr (next_p -> bits (2)); /* Add one bit to the pointer for odd digits per number. */ if check_ptr then do; if add_bit then do; unspec (copy_its) = unspec (next_p); num = fixed (copy_its.bit_offset, 6)+1; copy_its.bit_offset = substr (unspec (num), 31, 6); unspec (next_p) = unspec (copy_its); end; add_bit = ^add_bit; end; end; call ioa_$ioa_switch (iocb_ptr, ""); /* new_line */ end; else do; if d_size = 36 then call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, fxb); else do; do j = 1 to per_line; if substr (bits (j), 1, 1) = "1"b then fx (j) = -1; else fx (j) = 0; substr (unspec (fx (j)), 73-d_size, d_size) = bits (j); end; call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, fx); end; end; end; if ^same then print_equal = "1"b; /* Check for duplicate line. Last line of comp-8 with odd number of digits will be printed. */ no_prt = no_prt - per_line; if no_prt > 0 then do; if no_prt >= per_line then j = data_line_len; else j = no_prt * d_size; if check_ptr & (no_prt < 4) then same = "0"b; else if substr (data_line, 1, j) = substr (data_line, data_line_len + 1, j) then same = "1"b; else same = "0"b; end; pp = addr (substr (data_line, data_line_len+1, 1)); loc = fixed (rel (pp), 17); offset = loc - k; end; end print_data; /* */ /* This procedure prints one or more lines of source code beginning with the line associated with the object code pointed to by data_ptr. For an unbound segment, the directory in which the object segment was compiled is searched for the source segment. If the source segment is not found there, the working directory is searched. For bound segments only the working directory is searched for the source segment. */ print_source: proc; dcl source_based char (2) based (source_ptr); dcl source_dir char (168); dcl source_ent char (32); dcl source_len fixed bin; dcl source_name char (source_len) based (source_name_ptr); dcl source_name_ptr ptr; dcl source_ptr ptr; /* pointer to source segment */ if sntp -> snt.symflag then call db_get_sym (sntp); if snt.std then do; /* standard header, use source map */ hp = snt.headp; call stu_$get_line (hp, loc, no_prt, line_no, line_offset, line_length, file); if line_no = -1 | line_length = 0 then go to ERROR_NO_LINE; file = file + 1; /* because of dimensioning in include file */ if hp -> std_symbol_header.source_map = (18)"0"b then go to ERROR_NO_LINE; smap_ptr = addrel (hp, hp -> std_symbol_header.source_map); source_name_ptr = addrel (hp, smap_ptr -> source_map.map (file).pathname.offset); source_len = fixed (smap_ptr -> source_map.map (file).pathname.size, 18); /* got source name, separate it out for initiate */ call expand_pathname_ (source_name, source_dir, source_ent, code); call hcs_$initiate (source_dir, source_ent, "", 0, 1, source_ptr, code); /* If there is no pointer to the source segment, look in the working directory. */ if source_ptr = null () then do; if source_ent = last_source then print_err = "0"b; if print_err then call ioa_$ioa_switch (iocb_ptr, "Cannot initiate source. ^a>^a", source_dir, source_ent); source_dir = get_wdir_ (); call hcs_$initiate (source_dir, source_ent, "", 0, 1, source_ptr, code); if source_ptr = null () then do; if ^print_err then call ioa_$ioa_switch (iocb_ptr, "Cannot initiate source. ^a>^a", source_dir, source_ent); return; end; if print_err then call ioa_$ioa_switch (iocb_ptr, "Using source ^a>^a", source_dir, source_ent); end; last_source = source_ent; /* Now just write out the requisite stuff */ call iox_$put_chars (iocb_ptr, addr (substr (source_based, line_offset+1, 1)), line_length, code); call ioa_$ioa_switch (iocb_ptr, ""); /* add new-line */ return; end; else call ioa_$ioa_switch (iocb_ptr, "Version 1 object segments are not supported by debug."); return; end print_source; /* */ oob_handler: proc (mcp, name, x_p, y_p, cont_sw); /* Procedure to handle out_of_bounds. If it occurred in the data segment, * the user specified to high an address or too much data. Else it's a real * program error and we want to hear about it. */ dcl name char (*); dcl (x_p, y_p) ptr; dcl cont_sw bit (1) aligned; %include mc; scup = addr (mcp -> mc.scu); if scu.tpr.tsr = substr (baseno (pp), 4) then do; /* oob in data seg. */ call reversion_ ("out_of_bounds"); call ioa_$ioa_switch (iocb_ptr, "Request goes beyond end of segment."); go to out; end; /* Elsewhere, use previous handler */ cont_sw = "1"b; return; end oob_handler; end db_print;  db_regs.pl1 11/04/82 1959.8rew 11/04/82 1628.8 236556 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_regs: procedure; /* This procedure is used to print, get, or assign the values of the debug or user * defined data registers. There is an entry provided for each of these three * functions. The debug data registers are really data fields in the machine * conditions and are referenced via pre-defined names. * * Rewritten Nov 72 for the 6180 by Bill Silver. */ /* PARAMETER DATA */ dcl db_mc_ptr ptr, /* Pointer to the current machine conditions. All debug keeps * is a pointer to the machine conditions which are in the stack. * If this pointer is null then we don't have any machine * registers to play with. Note, the user defined registers * are always available. */ name char(4) aligned, /* The name of the data item that is to be processed. It is * either a predefined debug data name or the name of a * user defined register. */ print_mode fixed bin, /* 0 => BRIEF, 1 => LONG. */ value bit(72) aligned; /* Used to assign or get the value of one debug data item. * Its contents are always right justified. */ /* AUTOMATIC DATA */ /* These data items are used as work variables. */ dcl block_ptr ptr, /* Pointer to a block of 8 words to be printed. */ work_ptr ptr; /* Just a temporary pointer. */ dcl indp ptr; /* pointer to indicator reg. in scu */ dcl delim char(2); /* comma or blank for indicator list */ dcl namex fixed bin, /* The index of the db_data$names table. */ userx fixed bin, /* The index of both the user_reg_names and * user_reg_values table. */ i fixed bin; /* Just a work varaible. */ dcl len fixed bin; /* Another work variable. */ /* This variable is used to obtain a printable string of information about * an instruction from the print_text_$format procedure. */ dcl source_string char (72) varying; /* These words are used to print data items in octal via calls to "ioa_". They * are needed to correctly print, for example, a 3 octal digit number since the * number must be right justified in a 36 bit word and all but the 3 digits to be * printed must be zero. */ dcl ( print_word1, print_word2, print_word3, print_word4 ) bit(36) init( "0"b ); /* This word is used in printing out the value of the eaq in floating format */ dcl float_val float bin(63); dcl print_request bit (1) init ("0"b); /* ON if entry by db_regs$print */ /* BASED DECLARATIONS */ /* Used to overlay floating value for eaq output */ dcl 1 float_overlay aligned based(addr(float_val)), 2 exponent unal bit(8), 2 a_part unal bit(36), 2 q_part unal bit(27); /* Used to print out a block of 8 words. */ dcl block (0:7) bit(36) based; dcl eight_words bit(288) based aligned; /* Used to reference a pointer as a bit string. */ dcl ptr_bit_string bit(72) based; dcl based_ptr ptr based; dcl ind_bits bit(14) based(indp); /* indicators */ /* INTERNAL STATIC DATA */ /* The following two tables are used to convert an index of a debug data name into * an index of a label constant array. Except for the first and the last entries * all of the entries of these two tables correspond to a debug data name as defined * in the db_data$names array. The first entry (-1) is used when there is no room * left for another user register. The last entry is used for user defined registers. * The value of each entry is an index into the label array which corresponds to each. * of these tables. Note, the get_ass_label_table is used for both the * get_label array and the assign_label array. The entries in the label arrays * are used to transfer the routine which can process this type of data. */ dcl print_label_table ( -1:33 ) fixed bin internal static /* DATA NAME PRINT ROUTINE */ init ( 0, /* return */ (8) 6, /* pointer regs print_pr */ (8) 7, /* index regs print_xreg */ 9, /* aq print_aq */ 1, /* all print_all */ 2, /* prs print_prs */ 3, /* regs print_regs */ 4, /* scu print_scu */ 5, /* user print_user_regs */ 10, /* a print_a */ 11, /* q print_q */ 12, /* exp print_exp */ 13, /* tr print_tr */ 14, /* ralr print_ralr */ 15, /* ppr print_ppr */ 16, /* tpr print_tpr */ 17, /* even print_even */ 18, /* odd print_odd */ 19, /* ind print_indicators */ 20, /* eaq print_floating_eaq */ 8); /* print_user_reg */ dcl get_ass_label_table ( -1:33 ) fixed bin internal static /* DATA NAME GET/ASSIGN ROUTINE */ init ( 0, /* return */ (8) 2, /* pointer regs get/assign_pr */ (8) 3, /* index regs get/assign_xreg */ 5, /* aq get/assign_aq */ 1, /* all get/assign_illegal */ 1, /* prs get/assign_illegal */ 1, /* regs get/assign_illegal */ 1, /* scu get/assign_illegal */ 1, /* user get/assign_illegal */ 6, /* a get/assign_a */ 7, /* q get/assign_q */ 8, /* exp get/assign_exp */ 9, /* tr get/assign_tr */ 10, /* ralr get/assign_ralr */ 11, /* ppr get/assign_ppr */ 12, /* tpr get/assign_tpr */ 13, /* even get/assign_even */ 14, /* odd get/assign_odd */ 1, /* ind get/assign_illegal */ 1, /* eaq get/assign_illegal */ 4); /* get/assign_user_reg */ /* The following table contains the names to be associated with * each bit of the Indicators register. */ dcl ind_names (14) char(4) int static initial ("zero", "neg ", "cary", "ovfl", "eovf", "eufl", "oflm", "tro ", "par ", "parm", "^bar", "tru ", "mif ", "abs "); /* These tables contain the user defined registers. The maximum number that may * be defined is 16. The corresponding entries of the two tables define the * name and the value of each register. Note, these registers are defied as * INTERNAL STATIC and thus will remain unchanged for recursive calls to debug. * This is not true for the debug machine condition data. */ /* These variables contain the number of user defined registers which have actually * been defined and the maximum number which may be defined. */ dcl (num_user_regs fixed bin init(0), max_num_user_regs fixed bin init(16) ) internal static; dcl user_reg_names(16) char(4) internal static; dcl user_reg_values(16) bit(36) internal static; /* EXTERNAL and BUILTIN DATA */ /* These are the external procedures called by db_regs. */ %include db_ext_stat_; dcl print_text_$format ext entry ( ptr, char(*) var ), ioa_$ioa_stream ext entry options(variable); dcl ioa_$rsnnl ext entry options(variable); dcl ( addr, substr ) builtin; /* */ % include db_data_map; /* */ % include its; % include mc; /* */ print: entry ( db_mc_ptr, name, print_mode ); print_request = "1"b; /* Set so we won't create if not found */ call get_namex; /* Get the index of this name. */ /* This index is used to reference the label table which then gives us the index * of the label constant that we want to goto. */ goto print_label( print_label_table(namex) ); get: entry ( db_mc_ptr, name, value, print_mode ); call get_namex; value = "0"b; /* Initially set the return value to zero. */ goto get_label( get_ass_label_table(namex) ); assign: entry ( db_mc_ptr, name, value, print_mode ); call get_namex; print_word1 = substr( value, 1,36); /* Break up the input value into two words */ print_word2 = substr( value,37,36); /* so it can be more easily printed * via ioa_. */ goto assign_label( get_ass_label_table(namex) ); /* We come here if "namex" = -1 which implies that there was no room for another * user defined register. We will simply return. */ print_label(0): get_label(0): assign_label(0): return; /* This label is called from get_namex when the pointer to the machine conditions is * null. Since there is no register data to work with we will just return. */ no_mc_data: if print_mode = 0 /* BRIEF or LONG */ then call ioa_$ioa_stream (debug_output, "No mc data."); else do; /* LONG. */ call ioa_$ioa_stream (debug_output, "No fault frame found in stack trace."); end; return; /* */ get_namex: procedure; /* This procedure is called to set "namex" to the number which corresponds to the data * name passed to db_regs in "name". If it is a standard pre-defined debug data * name then "namex" will be simply the index of the db_data$names array entry * which contains this name. Otherwise it will be a user defined register name and "namex" * will be equal to a number one greater than the highest valid index to db_data$names. * The index of the user register is set in "userx". If there is no room to allocate * a new user register then "namex" will be set to -1. */ mcp = db_mc_ptr; /* Copy the parameter which points to the area where * debug's copy of the machine conditions are saved. */ /* See if this name is one of the standard debug data names. If it is then "namex" * is equal to the index of the db_data$names entry which contains this name. * If it is one of the standard register names then we will check the pointer to the * machine conditions that we were passed. If it is null then we can't do anything * with this register since as far as we are conserned it doesn't exist. */ do namex = 0 to db_data$n_regs; if name = db_data$names(namex) /* Is it one of the standard machine * condition type register names? */ then if db_mc_ptr = null() /* YES it is - do we have a pointer * to it? */ then goto no_mc_data; /* NO. */ else do; /* YES, return with namex. */ scup = addr( mcp -> mc.scu ); return; end; end; /* This name is not one of the standard names. It must be the name of a user defined * register. "namex" is set correctly. It came out of the do loop one greater * than the number of standard names. We will now see if this user name is allready * defined. If it is we will just return with "userx" set correctly. */ do userx = 1 to num_user_regs; if name = user_reg_names(userx) then return; end; /* This is a new user register name. Do we have another slot in the user register * tables for it? If not we will tell the user and "namex" will be set to -1. * The register will not be created for a print request. */ if print_request then do; call ioa_$ioa_stream (debug_output, "User register not defined. ^a", name); namex = -1; return; end; if userx > max_num_user_regs then do; call ioa_$ioa_stream (debug_output, "User register ^a not initialized - max number exceded",name); namex = -1; return; end; /* There is room for this new user register so lets initialize it. */ num_user_regs = userx; /* Reset the count of active user registers * to reflect this new register. */ user_reg_names(userx) = name; /* Remember its name. */ user_reg_values(userx) = "0"b; /* Initialize its value to zero. */ /* If we are in LONG mode then we will tell the user that he has just created * a new user register. */ if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "Creating new user register ^a", name ); end get_namex; /* */ /* These are the routines called via the print_label array. Each little piece * of code PRINTS some of the debug machine conditions data. */ /* Print all of the machine conditions data. Also print the user defined * registers. */ print_label(1): /* print_all */ if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "All ""machine conditions"" data."); call print_prs; call print_regs; call print_scu; if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "^/The 8 words after the SCU data"); block_ptr = addr( mcp -> mc.mask ); call print_block; block_ptr = addr( mcp -> mc.eis_info ); if block_ptr -> eight_words ^= "0"b then do; if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "^/EIS info"); call print_block; end; call print_user_regs; return; /* Print all of the pointer registers. */ print_label(2): call print_prs; return; print_prs: procedure; call ioa_$ioa_stream (debug_output, "^/Pointer Registers"); do i = 0 to 7; call ioa_$ioa_stream (debug_output, "^a^-^p",db_data$names(i), mcp->mc.prs(i)); end; end print_prs; /* Print all of the registers: index registers, A,Q,Exp,Timer Register and * Ring Alarm Register. */ print_label(3): call print_regs; return; print_regs: procedure; if print_mode ^= 0 then do; call ioa_$ioa_stream (debug_output, "^/Index and other Registers"); do i = 0 to 7; call ioa_$ioa_stream (debug_output, "^a^-^.3b", db_data$names(i+8), mcp->mc.regs.x(i)); end; end; else do; /* BRIEF mode. */ call ioa_$ioa_stream (debug_output, "^-^.3b ^.3b ^.3b ^.3b", mc.regs.x(0), mc.regs.x(1), mc.regs.x(2), mc.regs.x(3)); call ioa_$ioa_stream (debug_output, "^-^.3b ^.3b ^.3b ^.3b", mc.regs.x(4), mc.regs.x(5), mc.regs.x(6), mc.regs.x(7)); end; call ioa_$ioa_stream (debug_output, "a^-^w^/q^-^w", mcp->mc.regs.a, mcp->mc.regs.q); call print_exp; call print_tr; call print_ralr; end print_regs; /* Print the SCU data. We will print out the PPR, TPR and the EVEN and ODD * instructions. Then we will print out the SCU data as a block. */ print_label(4): call print_scu; return; print_scu: procedure; if print_mode ^= 0 then do; call ioa_$ioa_stream (debug_output, "^/SCU data"); call print_ppr; call print_tpr; call ioa_$ioa_stream (debug_output, "^/"); call print_even; call print_odd; call print_ind; call ioa_$ioa_stream (debug_output, "The SCU data as a block"); end; block_ptr = scup; call print_block; end print_scu; /* Print out all of the user defined registers. */ print_label(5): call print_user_regs; return; print_user_regs: procedure; if num_user_regs = 0 then do; if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "^/No user defined registers"); return; end; if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "^/User defined registers"); do i = 1 to num_user_regs; call ioa_$ioa_stream (debug_output, "^a^-^w", user_reg_names(i), user_reg_values(i)); end; end print_user_regs; /* Print out one pointer register. */ print_label(6): /* print_pr */ call ioa_$ioa_stream (debug_output, "^a^-^p",db_data$names(namex), mcp->mc.prs(namex)); return; /* Print out one index register. */ print_label(7): /* print_xreg */ call ioa_$ioa_stream (debug_output, "^a^-^.3b", db_data$names(namex), mcp->mc.regs.x(namex-8) ); return; /* Print out one user defined register. */ print_label(8): /* print_user_reg */ call ioa_$ioa_stream (debug_output, "^a^-^w", user_reg_names(userx), user_reg_values(userx)); return; /* Print the AQ as a combined register or print the A or the Q. */ print_label(9): /* print_aq */ call ioa_$ioa_stream (debug_output, "aq^-^w ^w", mcp -> mc.regs.a, mcp -> mc.regs.q); return; print_label(10): /* print_a */ call ioa_$ioa_stream (debug_output, "a^-^w", mcp->mc.regs.a); return; print_label(11): /* print_q */ call ioa_$ioa_stream (debug_output, "q^-^w", mcp->mc.regs.q); return; /* Print the Exponent register. */ print_label(12): call print_exp; return; print_exp: procedure; call ioa_$ioa_stream (debug_output, "exp^-^.3b", "0"b || mc.regs.e); end print_exp; /* Print the Timer Register. */ print_label(13): call print_tr; return; print_tr: procedure; call ioa_$ioa_stream (debug_output, "tr^-^.3b", mcp->mc.regs.t); end print_tr; /* Print the Ring Alarm Register. */ print_label(14): call print_ralr; return; print_ralr: procedure; call ioa_$ioa_stream (debug_output, "ralr^-^.3b", mc.regs.ralr); end print_ralr; /* Print the PPR. */ print_label(15): call print_ppr; return; print_ppr: procedure; if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "^/ppr:^-prr psr p ic"); call ioa_$ioa_stream (debug_output, "^- ^.3b ^.3b ^.1b ^.3b", scu.ppr.prr, scu.ppr.psr, scu.ppr.p, scu.ilc); end print_ppr; /* Print the TPR. */ print_label(16): call print_tpr; return; print_tpr: procedure; if print_mode ^= 0 then call ioa_$ioa_stream (debug_output, "^/tpr:^-trr tsr tbr ca"); call ioa_$ioa_stream (debug_output, "^- ^.3b ^.3b ^.3b ^.3b", scu.tpr.trr, scu.tpr.tsr, scu.tpr_tbr, scu.ca); end print_tpr; /* Print out the EVEN or the ODD instruction. */ print_label(17): call print_even; return; print_even: procedure; call print_text_$format( addr( scup -> scu.even_inst), source_string); call ioa_$ioa_stream (debug_output, "even^-^a", source_string ); end print_even; print_label(18): call print_odd; return; print_odd: procedure; call print_text_$format( addr( scup -> scu.odd_inst), source_string); call ioa_$ioa_stream (debug_output, "odd^-^a", source_string); end print_odd; print_label(19): call print_ind; return; /* Print out eaq in exponential format */ print_label(20): float_overlay.exponent = mc.e; float_overlay.a_part = mc.a; float_overlay.q_part = mc.q; call ioa_$ioa_stream (debug_output, "eaq^-^e",float_val); return; print_ind: procedure; indp = addr(scup -> scu.ir); /* point to indicator bits */ delim = ""; /* initialize */ source_string = ""; if indp -> ind_bits = (14)"0"b then source_string = "none"; /* no point if they're all off */ else do i = 1 to 14; if substr (indp -> ind_bits, i, 1) then do; call ioa_$rsnnl ("^a^a^a", source_string, len, source_string, delim, ind_names(i) ); delim = ", "; /* in case it was first one */ end; end; call ioa_$ioa_stream (debug_output, "indicators: ^a", source_string); end print_ind; /* This procedure prints out a block of 8 octal words. It must be passed * a pointer to the block of wors to be printed. */ print_block: procedure; call ioa_$ioa_stream (debug_output, "^/^-^w ^w ^w ^w", block_ptr->block(0), block_ptr->block(1), block_ptr->block(2), block_ptr->block(3)); call ioa_$ioa_stream (debug_output, "^-^w ^w ^w ^w", block_ptr->block(4), block_ptr->block(5), block_ptr->block(6), block_ptr->block(7)); end print_block; /* */ /* These are the routines called via the get_label array. note, the value returned * will always be RIGHT justified with leading zeros. */ /* The names used to print multiple data items cannot be used to retrieve data. * A zero will be returned. */ get_label(1): /* get_illegal */ return; /* value is allready zero. */ get_label(2): /* get_pr */ value = addr( mcp -> mc.prs(namex)) -> ptr_bit_string; return; get_label(3): /* get_xreg */ substr( value, 55, 18 ) = mcp -> mc.regs.x(namex-8); return; get_label(4): /* get_user_reg */ substr( value, 37, 36 ) = user_reg_values(userx); return; get_label(5): /* get_aq */ substr( value, 1, 36 ) = mcp -> mc.regs.a; substr( value, 37, 36 ) = mcp -> mc.regs.q; return; get_label(6): /* get_a */ substr( value, 37, 36 ) = mcp -> mc.regs.a; return; get_label(7): /* get_q */ substr( value, 37, 36 ) = mcp -> regs.q; return; get_label(8): /* get_exp */ substr( value, 65, 8 ) = mcp -> mc.regs.e; return; get_label(9): /* get_tr */ substr( value, 46, 27 ) = mcp -> mc.regs.t; return; get_label(10): /* get_ralr */ substr( value, 70, 3 ) = mcp -> mc.regs.ralr; return; get_label(11): /* get_ppr */ work_ptr = addr( value ); work_ptr -> its.segno = scup -> scu.ppr.psr; work_ptr -> its.ringno = scup -> scu.ppr.prr; substr( value, 3, 1 ) = scup -> scu.ppr.p; /* Normal its pointers have no p bit. */ work_ptr -> its.offset = scup -> scu.ilc; return; get_label(12): /* get_tpr */ work_ptr = addr( value ); work_ptr -> its.segno = scup -> scu.tpr.tsr; work_ptr -> its.ringno = scup -> scu.tpr.trr; work_ptr -> its.bit_offset = scup -> scu.tpr_tbr; work_ptr -> its.offset = scup -> scu.ca; return; get_label(13): /* get_even */ substr( value, 37, 36 ) = scup -> scu.even_inst; return; get_label(14): /* get_odd */ substr( value, 37, 36 ) = scup -> scu.odd_inst; return; /* */ /* These routines are called via the assign_label array. note, the value to be * assigned is always assumed to be a RIGHT justified BIT string. * Note, if the print mode is LONG we will print out the value of the data item * before it is changed and after the assignment. If we are in BRIEF mode we will * just make the assignment without telling the user anything. */ /* The name used to print multiple data items cannot be used to assign values. * Each assignment must be made to a specific register. */ assign_label(1): /* assign_illegal */ call ioa_$ioa_stream (debug_output, "The debug name ^a cannot be used in an assignment command.", db_data$names(namex)); return; assign_label(2): /* assign_pr */ if print_mode = 1 then call ioa_$ioa_stream (debug_output, "^a changed from ^p to ^p", db_data$names(namex), mcp -> mc.prs(namex), addr(value) -> based_ptr); addr( mcp -> mc.prs(namex)) -> ptr_bit_string = value; return; assign_label(3): /* assign_xreg */ if print_mode = 1 then do; call ioa_$ioa_stream (debug_output, "^a changed from ^.3b to ^.3b", db_data$names(namex), mc.regs.x(namex-8), substr(print_word2, 19, 18)); end; mcp -> mc.regs.x(namex-8) = substr( print_word2, 19, 18 ); return; assign_label(4): /* assign_user_reg */ if print_mode = 1 then call ioa_$ioa_stream (debug_output, "^a changed from ^w to ^w", user_reg_names(userx), user_reg_values(userx), print_word2); user_reg_values(userx) = print_word2; return; assign_label(5): /* assign_aq */ if print_mode = 1 then call ioa_$ioa_stream (debug_output, "aq changed from ^w^w to ^w^w", mcp -> mc.regs.a, mcp -> mc.regs.q, print_word1, print_word2); mcp -> mc.regs.a = print_word1; mcp -> mc.regs.q = print_word2; return; assign_label(6): /* assign_a */ if print_mode = 1 then call ioa_$ioa_stream (debug_output, "a changed from ^w to ^w", mcp -> mc.regs.a, print_word2); mcp -> mc.regs.a = print_word2; return; assign_label(7): /* assign_q */ if print_mode = 1 then call ioa_$ioa_stream (debug_output, "q changed from ^w to ^w", mcp -> mc.regs.q, print_word2); mcp -> mc.regs.q = print_word2; return; assign_label(8): /* assign_exp */ if print_mode = 1 then do; call ioa_$ioa_stream (debug_output, "exp changed from ^.3b to ^.3b", "0"b || mc.regs.e, "0"b || substr(print_word2, 29, 8)); end; mcp -> mc.regs.e = substr( print_word2, 29, 8 ); return; assign_label(9): /* assign_tr */ if print_mode = 1 then do; call ioa_$ioa_stream (debug_output, "tr changed from ^.3b to ^.3b", mc.regs.t, substr(print_word2, 10, 27)); end; mcp -> mc.regs.t = substr( print_word2, 10, 27 ); return; assign_label(10): /* assign_ralr */ if print_mode = 1 then do; call ioa_$ioa_stream (debug_output, "ralr changed from ^.3b to ^.3b", mc.regs.ralr, substr(print_word2, 34, 3)); end; mcp -> mc.regs.ralr = substr( print_word2, 34, 3 ); return; assign_label(11): /* assign_ppr */ work_ptr = addr( value ); if print_mode = 1 then do; call ioa_$ioa_stream (debug_output, "Old ppr"); call print_ppr; end; scup -> scu.ppr.psr = work_ptr -> its.segno; scup -> scu.ppr.prr = work_ptr -> its.ringno; scup -> scu.ppr.p = substr( value, 3,1 ); scup -> scu.ilc = work_ptr -> its.offset; if print_mode = 1 then do; call ioa_$ioa_stream (debug_output, "New ppr"); call print_ppr; end; return; assign_label(12): /* assign_tpr */ work_ptr = addr( value ); if print_mode = 1 then do; call ioa_$ioa_stream (debug_output, "Old tpr"); call print_tpr; end; scup -> scu.tpr.tsr = work_ptr -> its.segno; scup -> scu.tpr.trr = work_ptr -> its.ringno; scup -> scu.tpr_tbr = work_ptr -> its.bit_offset; scup -> scu.ca = work_ptr -> its.offset; if print_mode = 1 then do; call ioa_$ioa_stream (debug_output, "New tpr"); call print_tpr; end; return; assign_label(13): /* assign_even */ if print_mode = 1 then do; call print_text_$format( addr( scup -> scu.even_inst), source_string); call ioa_$ioa_stream (debug_output, "Old even instruction: ^a", source_string); end; scup -> scu.even_inst = print_word2; if print_mode = 1 then do; call print_text_$format( addr( scup -> scu.even_inst), source_string); call ioa_$ioa_stream (debug_output, "New even instruction: ^a", source_string); end; return; assign_label(14): /* assign_odd */ if print_mode = 1 then do; call print_text_$format( addr( scup -> scu.odd_inst), source_string); call ioa_$ioa_stream (debug_output, "Old odd instruction: ^a", source_string); end; scup -> scu.odd_inst = print_word2; if print_mode = 1 then do; call print_text_$format( addr( scup -> scu.odd_inst), source_string); call ioa_$ioa_stream (debug_output, "New odd instruction: ^a", source_string); end; return; end db_regs;  db_sym.pl1 11/05/86 1217.3r w 11/04/86 1042.2 103068 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_sym: proc (line, a_sntp, data_ptr, offset, type, type_char, mode, a_size, m_size, code); /* Modified Nov 72 to convert to PL/I V2 by R Coren. * Modified Nov 72 for 6180 (remove check entry ) by Bill Silver. * Modified 10/76 to add COBOL data types by S. Barr. */ /* Changed to test for Version 1/pascal symbol table before testing data_ptr 10/14/83 S. Herbst */ dcl line char (72) varying, a_sntp ptr, data_ptr ptr, offset fixed bin, type_char char (1) aligned, mode char (*) aligned, size fixed bin, a_size fixed bin, m_size fixed bin, code fixed bin; dcl (addr, addrel, baseno, divide, fixed, length, min, null, ptr, rel, substr, unspec) builtin; dcl var_flag fixed bin; dcl (type, n, i, j, steps) fixed bin, f17 fixed bin based, (p, stack_pt, found_block, symbol_pt, ref_pt) ptr, current_block ptr, packed_ptr based unaligned ptr, based_ptr based ptr, bn bit (18) aligned, db_get_sym ext entry (ptr), stu_$find_runtime_symbol entry (ptr, char (*) aligned, ptr, fixed bin) returns (ptr), stu_$get_runtime_address entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr), stu_$offset_to_pointer entry (ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr), stu_$decode_runtime_value entry (fixed bin, ptr, ptr, ptr, ptr, ptr, fixed bin) returns (fixed bin); dcl decode_type char (32) int static aligned init ("oddfooooooooopoppoobvavoiiip"); /* */ %include db_snt; /* */ %include stack_frame; %include picture_image; /* */ %include symbol_node; /* */ %include runtime_symbol; %include stu_frame; /* */ sntp = a_sntp; /* copy arg. */ if sntp -> snt.symflag then call db_get_sym (sntp); /* attempt to get symbol pointer */ current_block = sntp -> snt.symp; if current_block = null then do; err2: code = 2; /* no symbol table */ return; end; if baseno (sntp -> snt.lp) = "0"b then sntp -> snt.lp = null; code = 0; symbol_pt = db_var (1, (1), data_ptr, ref_pt, stack_pt); if symbol_pt = null then do; err1: code = 1; /* symbol not found */ return; end; if data_ptr = null then do; err5: code = 5; /* couldn't get address */ return; end; /* have Version II symbol node */ type = fixed (symbol_pt -> runtime_symbol.type, 6); if type = 38 | type = 39 then mode = "comp-5"; else if type = 41 then mode = "comp-8"; else if type = 63 then do; /* PICTURE */ mode = "a"; p = ptr (snt.pp, symbol_pt -> runtime_symbol.size); size = p -> picture_image.varlength; type = 21; goto l2; end; else mode = substr (decode_type, type+1, 1); var_flag = 0; if mode = "p" then do; if symbol_pt -> runtime_symbol.packed then size = 36; else size = 72; go to l2; end; if mode = "v" then do; var_flag = 1; mode = substr (decode_type, type, 1); a_size = data_ptr -> f17; data_ptr = addrel (data_ptr, 1); type = type - 1; end; size = symbol_pt -> symbol_node.size; if size < 0 then do; size = stu_$decode_runtime_value (size, found_block, stack_pt, sntp -> snt.lp, sntp -> snt.pp, ref_pt, code); if code ^= 0 then do; code = 6; return; end; end; if type = 3|type = 4 then size = size + 8; /* floating-point, add in bits for exp */ else if type = 14 then size = 36; /* offset must be one fullword */ /* packed decimal */ else if type = 38 then size = divide (size*9, 2, 17, 0); /* unsigned */ else if type = 39 | type = 41 then size = divide ((size+1)*9, 2, 17, 0); /* sign uses one digit */ else if mode ^= "a" & mode ^= "b" then do; if ^symbol_pt -> symbol_node.packed then /* unpacked, round size up to word */ if size < 36 then size = 36; else size = 72; else size = size + 1; /* add sign bit to precision */ end; l2: bn = baseno (data_ptr); m_size = size; if var_flag = 0 then a_size = size; else a_size = min (a_size, size); if bn = baseno (sntp -> snt.sp) then do; type_char = "s"; offset = fixed (rel (data_ptr), 18) - fixed (rel (sntp -> snt.sp), 18); return; end; if bn = baseno (sntp -> snt.static_ptr) then do; type_char = "i"; offset = fixed (rel (data_ptr), 18) - fixed (rel (sntp -> snt.static_ptr), 18); return; end; if bn = baseno (sntp -> snt.lp) then do; type_char = "l"; offset = fixed (rel (data_ptr), 18) - fixed (rel (sntp -> snt.lp), 18); return; end; type_char = "i"; offset = 0; exit: return; text_ref: data_ptr = ptr (sntp -> snt.pp, 0); type_char = "t"; mode = "i"; goto l1; link_ref: if rel (sntp -> snt.lp) = (18)"0"b then do; err3: code = 3; /* no linkage */ return; end; data_ptr = sntp -> snt.lp; type_char = "l"; l1: data_ptr = addrel (data_ptr, offset); return; err4: code = 4; /* no stack frame */ return; err7: code = 7; /* syntax error */ return; err8: code = 8; /* array error */ return; err9: code = 9; /* value error */ return; err10: code = 10; /* based error */ return; err11: code = 11; /* more than 64 structure levels */ return; err12: code = 12; /* symbol too long */ return; err13: code = 13; /* ambiguous reference */ return; err14: code = 14; /* entry constant */ return; err15: code = 15; /* unsupported symbol table format (V1, Pascal) */ return; db_var: proc (start_pos, end_pos, data_pt_out, ref_pt_out, stack_pt_out) returns (ptr); dcl start_pos fixed bin, /* start index in line */ end_pos fixed bin, /* finish index in line (output) */ data_pt_out ptr, /* ptr to datum (output) */ ref_pt_out ptr, /* ref ptr for datum (output) */ stack_pt_out ptr; /* stack pointer for datum (output) */ dcl (p, q, s_pt, d_pt, r_pt, sp, dummy_pt, subs_pt) ptr, (pos, n, m, val, type, steps, subscript (32)) fixed bin, (thru, nosign) bit (1), ch char (1), db_get_count$dec entry (char (*) aligned, fixed bin, fixed bin) returns (fixed bin); dcl char_type (0: 127) fixed bin int static init ((33)0, 1, (2)0, 1, (9)0, 1, 0, (10)2, (7)0, (26)1, (4)0, 1, 0, (26)1, (5)0); /* char_type: 2 number 1 letter ! $ . _ 0 other */ dcl line_ char (72) aligned; dcl fix_single fixed bin (17) based, fix_double fixed bin (53) based, flt_single float bin (27) based, flt_double float bin (63) based; pos = start_pos; thru = "0"b; r_pt, d_pt, s_pt = null; again: call sob; if thru then goto err7; n = pos; loop: ch = substr (line, pos, 1); type = char_type (fixed (unspec (ch), 9)); if type > 0 then do; pos = pos + 1; if pos <= length (line) then goto loop; thru = "1"b; end; s_pt = stu_$find_runtime_symbol (current_block, substr (line, n, pos-n), found_block, steps); if s_pt = null then if steps = -2 then goto err11; else if steps = -3 then goto err12; else if steps = -5 then goto err13; else goto err1; if ^s_pt -> runtime_symbol.flag then go to err15; subs_pt = null; if thru then do; chk_tl: if n > 1 then goto ga; offset = fixed (s_pt -> symbol_node.offset, 18); if s_pt -> symbol_node.class = "1100"b /* check for label/entry constant */ then if s_pt -> runtime_symbol.flag then if s_pt -> runtime_symbol.type = "011000"b then goto text_ref; /* label constant is simple */ else if s_pt -> runtime_symbol.type = "011001"b then go to err14; else; else if s_pt -> symbol_node.type = "000000100101"b then goto text_ref; else if s_pt -> symbol_node.type = "000000100100"b then go to err14; if s_pt -> symbol_node.class = "1101"b then if s_pt -> runtime_symbol.flag then if s_pt -> runtime_symbol.type = "011010"b /* ext entry in */ then go to err14; else go to link_ref; else if s_pt -> symbol_node.type = "000000100100"b /* likewise */ then go to err14; else go to link_ref; goto ga; end; call sob; if thru then goto chk_tl; if ch ^= "(" then goto ga; n = 1; sub_loop: pos = pos + 1; call sob; if thru then goto err7; val = 0; nosign = "1"b; type = char_type (fixed (unspec (ch), 9)); if type ^= 1 then goto s1; p = db_var (pos, pos, q, dummy_pt, dummy_pt); if p = null then goto err1; if q = null then goto err1; if p -> runtime_symbol.flag then type = fixed (p -> runtime_symbol.type, 6); else do; type = fixed (p -> symbol_node.type, 12); if type > 16 then type = type - 16; end; if type = 1 then val = q -> fix_single; else if type = 2 then val = q -> fix_double; else if type = 3 then val = q -> flt_single; else if type = 4 then val = q -> flt_double; else goto err9; nosign = "0"b; call sob; if thru then goto err7; s1: if ch = "+" | ch = "-" | (type = 2 & nosign) then do; line_ = line; val = val + db_get_count$dec (line_, pos, pos); call sob; if thru then goto err7; end; subscript (n) = val; if ch = "," then do; n = n + 1; if n > 32 then goto err8; goto sub_loop; end; if ch ^= ")" then goto err7; if n ^= fixed (s_pt -> symbol_node.ndims, 6) then goto err8; if current_block -> runtime_block.flag then if current_block -> runtime_block.fortran then do i = 1 to divide (n, 2, 17, 0); m = subscript (i); subscript (i) = subscript (n-i+1); subscript (n-i+1) = m; end; subs_pt = addr (subscript (1)); pos = pos + 1; call sob; ga: sp = sntp -> snt.sp; do i = 1 to steps while (sp ^= null); sp = sp -> frame.display; end; d_pt = stu_$get_runtime_address (found_block, s_pt, sp, sntp -> snt.lp, sntp -> snt.pp, r_pt, subs_pt); if d_pt = null then goto err5; if thru then goto done; if substr (line, pos, 2) = "->" then do; pos = pos + 2; if s_pt -> runtime_symbol.type = "001110"b /* offset */ then do; r_pt = stu_$offset_to_pointer (found_block, s_pt, d_pt, sp, sntp -> snt.lp, sntp -> snt.pp); go to again; end; if s_pt -> runtime_symbol.type ^= "001101"b then if s_pt -> runtime_symbol.type ^= "011101"b then goto err10; if ^ s_pt -> runtime_symbol.flag then if substr (s_pt -> symbol_node.type, 1, 6) then goto err10; if s_pt -> runtime_symbol.packed then r_pt = d_pt -> packed_ptr; else r_pt = d_pt -> based_ptr; goto again; end; done: end_pos = pos; data_pt_out = d_pt; ref_pt_out = r_pt; stack_pt_out = sp; return (s_pt); sob: proc; sl: if pos > length (line) then do; fini: thru = "1"b; return; end; ch = substr (line, pos, 1); if ch ^= " " then return; pos = pos + 1; goto sl; end; end db_var; end;  debug.pl1 11/05/86 1217.3r w 11/04/86 1034.0 192051 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ debug: db: procedure; /* This is the main procedure of the debug package. It has two entries: * * 1. The CALLED entry "debug" or "db" is entered when debug is called by * a user. * * 2. "mme2_fault" is entered to handle a mme2 fault, i.e., a break. */ /* PARAMETER DATA */ dcl arg_mcp ptr; /* Pointer to the machine conditions that is * passed to the mme2 fault entry. This pointer * is generated by the "signaller" and is * handed down to "debug". */ /* AUTOMATIC DATA */ /* Below is the automatic area reserved for common data. Also declared is the area * where the SNT table is built. */ dcl common_auto_area (88) fixed bin aligned, snt_area (70) fixed bin aligned; dcl 1 save aligned like db_ext_stat_$db_ext_stat_; dcl break_num fixed bin, /* Number of the break that caused the * mme2 fault. */ break_ptr ptr, /* Pointer to where the break occurred. */ temp_break_ptr ptr; /* Pointer to where a temporary break will * be set. */ dcl comd_len fixed bin, /* The length of the command line in a break. * 0 => no command line. */ comd_ptr ptr, /* Pointer to the command line IN THE BREAK. */ cond_flag fixed bin; /* A flag indicating whether a given break * should be skipped due to an unsatisfied * condition. Its values are: * 0 => NO - No condition or condition met. * 1 => YES - Skip break, condition not met. */ dcl i fixed bin; /* Work variable. */ dcl input_buffer char (132) aligned, /* Area where the user commands are read. */ input_buffer_ptr ptr, /* Pointer to the beginning of this area. */ input_line_len21 fixed bin (21), /* For use with iox_ */ input_line_len fixed bin; /* Actual length of user's input command. */ dcl printer_on char (1) init (""); /* Turn printer on "006" */ dcl line_num fixed bin, /* Source line number associated with an * offset in an object segment. */ line_1st_inst_off fixed bin, /* The offset of the FIRST instruction of * a given source line. */ line_num_inst fixed bin; /* Number of instructions used to implement * a given source line. */ dcl line_info char (14) aligned; /* Line number for printing. */ dcl last_sp ptr; /* Pointer to the last stack frame in the * stack history which we will use as * part of our trace. */ dcl cleanup condition; dcl command_abort_ condition; dcl code fixed bin (35); dcl new_line char (1) init (" "); /* new line character */ /* The label used by the condition handling procedures. */ dcl read_line_label label; /* INTERNAL STATIC DATA */ /* Below is the static area reserved for common data. */ dcl common_static_area (1063) fixed bin internal static aligned; dcl static_init_count fixed bin internal static init (0); dcl initial_flag bit (1) int static init ("0"b); /* EXTERNAL DATA */ %include db_ext_stat_; dcl 1 d like db_ext_stat_$db_ext_stat_ based (addr (db_ext_stat_$db_ext_stat_)); dcl condition_ ext entry (char (*), entry), cu_$stack_frame_ptr ext entry returns (ptr), db_break$check_break ext entry (ptr, fixed bin, ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin), db_break$restart ext entry (ptr, fixed bin, fixed bin, ptr, fixed bin), db_break$set_break ext entry (ptr, fixed bin, ptr, fixed bin), db_fill_snt ext entry (ptr, ptr), db_find_mc ext entry (ptr, bit (1) aligned, ptr), db_parse ext entry (ptr, fixed bin, ptr, ptr), debug$mme2_fault ext entry (ptr), hcs_$high_low_seg_count ext entry (fixed bin, fixed bin), ioa_$ioa_stream ext entry options (variable), ioa_$rsnnl ext entry options (variable), legal_f_ ext entry (ptr) returns (fixed bin), db_line_no ext entry (ptr, fixed bin (18), fixed bin, fixed bin, fixed bin); dcl iox_$control ext entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$user_output ptr ext; dcl iox_$user_input ptr ext; dcl iox_$get_line ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$close ext entry (ptr, fixed bin (35)); dcl iox_$detach_iocb ext entry (ptr, fixed bin (35)); dcl com_err_ ext entry options (variable); dcl error_table_$long_record ext fixed bin (35); dcl error_table_$not_attached ext fixed bin (35); dcl error_table_$not_open ext fixed bin (35); dcl (addr, addrel, baseptr, fixed, null, ptr) builtin; /* */ %include db_common_auto; %include db_common_static; /* */ %include db_inst; /* */ %include db_snt; /* */ %include stack_header; %include stack_frame; %include mc; /* */ /* CALLED ENTRY - This is where "debug" is entered when the user calls "debug". */ if static_init_count = 0 then call set_internal_stat; call set_ext_stat; d.static_handler_call = "0"b; com_stat_ptr = addr (common_static_area); com_auto_ptr = addr (common_auto_area); sntp = addr (snt_area); call condition_ ("mme2", debug$mme2_fault); break_num = 0; /* debug was called so there is no break number */ temp_break_mode = 0; /* Not in temporary break mode */ num_skips = 0; /* No skip count since no break. */ /* Now get a pointer to the last sp we will use in the stack history trace. It must be the frame before the "debug" frame. */ last_sp = cu_$stack_frame_ptr () -> /* Pointer to our frame. */ stack_frame.prev_sp; /* ptr to the frame of the procedure that called debug */ /* Now get a pointer to the machine conditions of the last fault that was taken before "debug" was called. The stack frame of the procedure that took the fault must still be in the stack history if we are to get a pointer to the machine conditions. If there is no fault frame in the stack history it is OK. The user just won't have any registers to play with. If he tries to reference a machine register "db_regs" will tell him. */ call db_find_mc (last_sp, "0"b, db_mc_ptr); /* Now call an internal procedure that will perform the rest of the initialization. Once this is done we can start reading in user commands. */ call common_init; goto read_line; /* Go get user commands. */ /* */ /* This entry is entered via a mme2 fault that occurred at a break point. The input argument points to the machine conditions associated with this fault. There are two cases in which the break will be skipped. In both cases debug will not print any message a) The break has a non zero skip count. b) The break contains a condition but the condition has not been met. */ mme2_fault: entry (arg_mcp); if static_init_count = 0 then do; /* in case debug is entered via static handler */ call set_internal_stat; call set_ext_stat; d.static_handler_call = "1"b; end; com_stat_ptr = addr (common_static_area); com_auto_ptr = addr (common_auto_area); sntp = addr (snt_area); db_mc_ptr = arg_mcp; /* The machine conditions associated with * this fault serve as our registers. */ /* From the SCU data we get the address of where the mme2 fault occurred - in effect the PPR. The The address field of the mme2 instruction contains the break number. */ scup = addr (db_mc_ptr -> mc.scu); break_ptr = ptr (baseptr (fixed (scup -> scu.ppr.psr)), scup -> scu.ilc); break_num = fixed (break_ptr -> instr.offset); last_sp = db_mc_ptr -> mc.prs (spx); /* stack frame of the procedure that took the fault. */ call db_fill_snt (last_sp, sntp); call db_break$check_break (break_ptr, break_num, sntp, cond_flag, num_skips, comd_len, comd_ptr, line_num); /* If the break could not be handled (it was not enabled, it was a version 1 break), the user will enter command mode for debug. */ if break_ptr = null then do; call common_init; goto read_line_label; end; if (cond_flag = 1) | (num_skips > 0) then goto restart_break; call common_init; if line_num > 0 then call ioa_$rsnnl ("at line ^d", line_info, i, line_num); else line_info = ""; if print_mode = 0 then call ioa_$ioa_stream (d.debug_output, "Break ^d ^a of ^a", break_num, line_info, snt.ent_name); else call ioa_$ioa_stream (d.debug_output, "^RBreak ^d ^a of ^a - at ^p^B", break_num, line_info, snt.ent_name, break_ptr); if temp_comd_len ^= 0 /* temporary global command */ then call db_parse (addr (temp_comd_line), temp_comd_len, com_auto_ptr, com_stat_ptr); if comd_len ^= 0 /* conditional break */ then call db_parse (comd_ptr, comd_len, com_auto_ptr, com_stat_ptr); goto db_action_label (db_action_code); /* */ /* These condition handlers return to "read_line". The stack frame that * "debug" will be running on will be the last "debug" stack frame regardless of * how "debug" was entered. */ conversion_handler: procedure; call ioa_$ioa_stream (d.debug_output, "Conversion error"); goto read_line_label; end conversion_handler; prog_interrupt_handler: procedure; goto read_line_label; end prog_interrupt_handler; /* The any_other_handler prints the name of the condition and goes to read the next request from the user. The condition will be passed on if the user was not in debug when the condition occurred or the condition is not in the conditions table. The user is not in debug in the following cases: * db_parse (..) when a procedure is executed * (:=) when a subroutine call is made * debug (.c) when the user continues execution after a break */ any_other_handler: proc (mcptr, name, wcptr, info_ptr, cont); dcl mcptr ptr, name char (*), wcptr ptr, info_ptr ptr, cont bit (1); dcl conditions char (106) init ("conversion,fixedoverflow,out_of_bounds,overflow,underflow,zerodivide,stringrange,stringsize,subscriptrange"); if d.in_debug then do; /* only handle debug conditions */ if name = "db_conversion" then name = "conversion"; if index (conditions, name) > 0 then do; call ioa_$ioa_stream (d.debug_output, "db: ^a", name); go to read_line_label; end; end; cont = "1"b; return; end any_other_handler; /* */ /* This routine will read a user command and then call the parsing procedure to * process the command line. What we do when the parsing procedure returns depends * upon the action code which the parsing procedure sets. Thus the contents of the * command line determines what we do next. */ read_line: db_action_label (0): call iox_$get_line (d.debug_io_ptr (1), input_buffer_ptr, 132, input_line_len21, code); input_line_len = input_line_len21; if code ^= 0 then do; call com_err_ (code, "debug"); if code = error_table_$long_record then go to read_line; else go to quit; end; if input_line_len = 1 then goto read_line; /* Is it a blank line? */ db_action_code = 0; /* in case different value was returned before */ call db_parse (input_buffer_ptr, input_line_len, com_auto_ptr, com_stat_ptr); goto db_action_label (db_action_code); /* resetread: Flush read ahead because last request was incorrect */ db_action_label (1): call iox_$control (d.debug_io_ptr (1), "resetread", null, code); if code ^= 0 then call com_err_ (code, "debug"); goto read_line; /* Quit debug */ db_action_label (2): quit: if break_num = 0 then do; /* debug was CALLED */ call restore; return; end; /* If this invocation was through a mme2 fault, return is made to the stack frame that had the call to debug. If debug was originally invoked via a static handler and return is not possible. */ if ^d.flags.static_handler_call then goto d.return_label; signal command_abort_; goto read_line; return_from_debug: /* This is where the previous goto will transfer to. However, we will now be in a different stack frame. */ call restore; /* Restore i/o attachments & external data */ return; /* Return to CALLER. */ /* This routine is called when the user wants to restart a break. Note that all of * the data needed to restart the break has been set up by "debug". Only the num_skips * field could have been modified by a user if the parse procedure was called to * process a command line. If there is no break number then "debug" was entered * via a CALL. Thus there is no break to restart. We will just go and read in * another command line. */ restart_break: db_action_label (3): if break_num = 0 | break_ptr = null then do; call ioa_$ioa_stream (d.debug_output, "No break fault, cannot restart break."); goto read_line; end; /* There was a break fault so we can restart this break. First we will check to * see if we are in temporary break mode. If we are we will set a temporary break. * The location of the temporary break will be at the beginning of the next line if * there are line numbers available. Otherwise it will be at the next instruction. */ if temp_break_mode ^= 0 /* Are we in temporary break mode? */ then do; /* YES */ call db_fill_snt (last_sp, sntp); call get_line_num; /* Get temporary break pointer. */ call db_break$set_break (temp_break_ptr, 1, sntp, print_mode); end; /* Now we will call db_break to restart the break. It will fiddle with our SCU * data so that when we say "return" the instruction that was replaced by the * mme2 will eventually be executed. We return to the procedure that called "debug" * at the mme2 fault entry. Eventually a return is made to the signaller who does * an "RCU" instruction from our SCU data. This will restart the procedure which * will execute as if the break never happened. */ d.in_debug = "0"b; /* restart break means leaving debug */ call db_break$restart (break_ptr, break_num, num_skips, scup, print_mode); return; /* This will begin the process which will * restart the procedure. */ /* */ common_init: procedure; /* This procedure is called to perform initialization that is common the both the * CALLED and the mme2_fault entries. It will not be called at all if the mme2 fault * entry immediately restarts the break. */ /* First initialize the rest of the common automatic variables. Also set up * the pointer to the input buffer. */ first_call_flag, db_action_code = 0; input_buffer_ptr = addr (input_buffer); /* Establish condition handlers for illegal debug conversions and for program * interrupts. Both of these condition handlers will go to "read_line" to get * another input line. At that time "debug" will be executing out of the last * "debug" stack frame regardless of how it was entered. */ read_line_label = read_line; call condition_ ("db_conversion", conversion_handler); call condition_ ("program_interrupt", prog_interrupt_handler); call condition_ ("any_other", any_other_handler); d.in_debug = "1"b; /* Now trace the stack history. We will start at the beginning of the stack and * trace until we reach the frame we have designated as the last frame. The pointer * to this frame is in "last_sp". The index of the stack_ptr_array entry for * this last frame will be saved in the common variable "max_sp_x". */ sp = ptr (last_sp, 0) -> stack_header.stack_begin_ptr; /* Get a pointer to the first * frame in the stack. Note, * it is a dummy and will * be skipped. */ do i = 0 to 511; if legal_f_ (sp) ^= 0 /* Is it a legal frame? */ then do; /* NO. */ max_sp_x = i - 1; /* Previous frame is the last one * we can use in the stack history. */ call ioa_$ioa_stream (d.debug_output, "Cannot trace stack past depth ^d", i-1); goto get_snt_data; /* End stack trace. */ end; stack_ptr_array (i) = sp; /* Stack is legal. Save its pointer * in the stack array. */ if sp = last_sp /* Is this the last stack frame we * want to trace? */ then do; /* YES. This is the end of the trace. */ max_sp_x = i; /* Save number of valid stack frames * in the trace. */ goto get_snt_data; end; sp = sp -> stack_frame.next_sp; /* Get a pointer to the next frame. */ end; /* If we get here we have overflowed the stack array area. Tell the user. */ call ioa_$ioa_stream (d.debug_output, "Stack array overflow has occurred."); max_sp_x = i - 1; /* Now that the stack trace has finished we will fill in the SNT table from the data * in the last stack frame in the trace. */ get_snt_data: call db_fill_snt (stack_ptr_array (max_sp_x), sntp); snt_ptr = sntp; end common_init; /* */ get_line_num: procedure; /* This internal procedure is called to get the line number of the instruction at * the current break point. It will also return a pointer to where the next temporary * break point should be set. If we can't get the line number then a line number * value of (-1) will be returned. This procedure assumes that "break_ptr" points to * the break point and that "sntp" points to valid SNT data of the fault frame. */ /* Get the line number. */ call db_line_no (sntp, fixed (rel (break_ptr), 18), line_1st_inst_off, line_num_inst, line_num); if line_num > -1 /* Did we get a line number. */ then do; /* YES, temporary pointer is beginning of * next line. */ temp_break_ptr = ptr (break_ptr, line_1st_inst_off + line_num_inst); return; end; /* Either we couldn't get a symbol pointer or we couldn't get a line number. In * any case we will return a line number of (-1) and the temporary break pointer * will be equal to the instruction after the break point. */ line_num = -1; temp_break_ptr = addrel (break_ptr, 1); end get_line_num; restore: proc; /* This procedure is called when the user quits debug or when the cleanup condition * is signaled. * 1. Any i/o attachments that were made by debug are detached. * 2. The external data is restore to its initial value when debug was called. */ do i = 1 to 2; if d.debug_io_open (i) then do; call iox_$close (d.debug_io_ptr (i), code); if code ^= 0 then if code ^= error_table_$not_open then call com_err_ (code, "debug"); end; if d.debug_io_attach (i) then do; call iox_$detach_iocb (d.debug_io_ptr (i), code); if code ^= 0 then if code ^= error_table_$not_attached then call com_err_ (code, "debug"); end; end; d = save; /* restore external static data */ static_init_count = static_init_count - 1; return; end restore; /* */ /* The external static is setup to work like controlled storage. When debug is called, the external static is copied into automatic storage. Before the user returns from debug, the external static is restored using the values saved in automatic storage. This is required for the return_label and is also convienent for cleanup for users who change the io switches. */ set_ext_stat: proc; save = d; /* save ext static data */ d.debug_input = "user_input"; d.debug_output = "user_output"; d.debug_io_open (1), d.debug_io_open (2), d.debug_io_attach (1), d.debug_io_attach (2) = "0"b; d.debug_io_ptr (1) = iox_$user_input; d.debug_io_ptr (2) = iox_$user_output; static_init_count = static_init_count + 1; /* When the user issues a debug quit command we want to return to the procedure which called "debug". Thus we must be using the stack frame of "debug" when it was entered via a call. In order to quit out of debug when it was entered via a fault we must do a non local goto back to the stack frame of "debug" when it was entered via a call. */ d.return_label = return_from_debug; on cleanup call restore; end set_ext_stat; set_internal_stat: proc; com_stat_ptr = addr (common_static_area); /* common static data */ if initial_flag then return; call hcs_$high_low_seg_count (i, hcs_count); sb = ptr (cu_$stack_frame_ptr (), 0); /* ptr to base of stack */ lotp = sb -> stack_header.lot_ptr; /* ptr to base of the linkage */ print_mode = 1; /* long message mode */ temp_comd_len = 0; /* no temporary global break command line */ initial_flag = "1"b; end set_internal_stat; end debug;  fix_bit.alm 11/04/82 1959.8rew 11/04/82 1609.4 11106 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name fix_bit entry fix_bit entry double " This little function takes a left-adjusted bit string and " right-adjusts it in a word, propagating the sign. It can " be called from pl1 thus: " fixed_bin_word = fixed_bit(aligned_bit, length); " where length is the number of bits in the string (if it " exceeds 36 use entry point double below). fix_bit: lda ap|2,* ldq 36,dl sbq ap|4,* ars 0,ql sta ap|6,* short_return " This entry point is used when the string is longer " than 36 bits (but not more than 72). It returns its " result in a fixed bin(71) number, thus: " " fixed_bin_71 = fix_bit$double(aligned_bit, length); " " double: ldq 72,dl sbq ap|4,* eax0 0,ql ldaq ap|2,* lrs 0,0 staq ap|6,* short_return end  legal_f_.pl1 11/05/86 1217.3r w 11/04/86 1042.2 19116 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ legal_f_: proc (arg_stack_frame_ptr, code); /* This procedure makes some validity checks on the stack frame pointer. It makes sure the current stack frame and the previous and next frames are at location modulo 16. If the current and next frame are in the same segment, the procedure checks that they are in order. */ dcl arg_stack_frame_ptr ptr; /* ptr to stack frame to be checked */ dcl code fixed bin (35); dcl (null, baseno, fixed, rel) builtin; %include stack_frame; /* */ code = 0; sp = arg_stack_frame_ptr; if sp = null then code = 1; else do; call check_ptr (sp); call check_ptr (sp -> stack_frame.prev_sp); call check_ptr (sp -> stack_frame.next_sp); call check_frame (sp, sp -> stack_frame.next_sp); call check_frame (sp -> stack_frame.prev_sp, sp); end; return; /* */ /* If a stack frame pointer is not null, it must be modulo 16. */ check_ptr: proc (p); dcl p ptr; dcl zero_mod_16_test bit (18) aligned static options (constant) init ("000000000000001111"b); if p ^= null then if rel (p) & zero_mod_16_test then code = 1; end check_ptr; /* If two stack frame pointers are in the same segment, a check is made that the second frame follows the first and that the first stack frame is of the minimum length. */ check_frame: proc (s1, s2); dcl s1 ptr; /* ptr to lower stack frame */ dcl s2 ptr; /* ptr to higher stack frame */ if baseno (s1) = baseno (s2) then if fixed (rel (s2), 18) - fixed (rel (s1), 18) < stack_frame_min_length then code = 1; return; end check_frame; end legal_f_;  list_arg_.pl1 11/04/82 1959.8rew 11/04/82 1609.4 51615 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ list_arg_: proc(argno,atype,ap); dcl argno fixed bin (18), atype char (1) aligned; dcl argp ptr, decode_descriptor_ entry(ptr,fixed bin(18),fixed bin(18),bit(1) aligned, fixed bin(18),fixed bin(18),fixed bin(18)), ioa_$ioa_stream ext entry options(variable), (i,min_arg,max_arg,type) fixed bin (18), c72 char (72) aligned, bit17 bit (17) unaligned based (argp), fword fixed bin (18) based (argp), flword float bin based (argp), dblword float bin(63) based (argp), (no_args,no_desc,j,strl,ndims,scale) fixed bin (18), packed bit(1) aligned, bit_string bit (strl) based (argp), char_string char(strl) based (argp); %include db_ext_stat_; dcl based_p ptr based; dcl 1 lv based, 2 ptr ptr, 2 stack ptr; %include its; %include db_arg_list; no_args = arg_list.num_args; /* get the number of arguments */ if no_args = 0 then do; /* check for no arguments */ call ioa_$ioa_stream (debug_output, "No arguments."); return; end; no_desc = arg_list.num_desc; /* and the number of descriptors */ if argno <= 0 then do; min_arg = 1; /* print out all arguments */ max_arg = no_args; end; else min_arg, max_arg = argno; /* just print out the one argument */ if argno > no_args then do; /* check for argument number too large */ call ioa_$ioa_stream (debug_output, "Arg no. ^d too large. Only ^d arguments.",argno,no_args); return; end; do j = min_arg to max_arg; /* loop through the desired number of args */ argp = ap -> arg_list.args(j); /* get pointer to the argument */ if atype = "?" then do; /* must find out argument type */ if no_desc ^= 0 then do; /* if we have descitpros, look at them */ call decode_descriptor_(ap,j,type,packed,ndims,strl,scale); end; else do; /* try to find out what type by heuristics */ if argp -> its.its_mod = "100011"b then type = 13; /* assume pointer */ else do; do strl = 0 to 31 while(substr(char_string,strl+1,1) >= "" /* bell */ & substr(char_string,strl+1,1) <= "~"); end; if strl >= 2 then type = 21; else type = -1; /* full word octal */ end; end; end; /* of checking for type */ else if atype = "l" then type = -2; /* location of arg */ else if atype = "o" then type = -1; /* full word octal */ else if atype = "p" then type = 13; else if atype = "d" then type = 1; /* real fixed */ else if atype = "a" then /* ascii */ do; call decode_descriptor_(ap,j,type,packed,ndims,strl,scale); /* see if ascii descriptor */ if type = 22 then strl = max(0,addrel(argp,-1)->fword); else if type = 21 then; else do; type = 21; strl = 32; /* he asked for characters, and cannot get length */ end; end; else if atype = "e" then type = 3; /* floating point */ else if atype = "f" then type = 1003; /* floating point (f-format) */ else if atype = "b" then do; /* bit string */ type = 19; strl = 72; /* only allow 72 bits or less */ end; else do; /* invalid type */ call ioa_$ioa_stream (debug_output, "Invalid output type specified."); type = -1; end; if type = 21 then goto cs; /* we have char string */ if type = 19 then goto bs; /* we have bit strinng */ if type = 14 then goto fw; /* we have offset */ if type = 13 then do; /* pointer */ if argp -> its.its_mod = "100011"b then call ioa_$ioa_stream (debug_output, "ARG ^2d: ^p",j,argp->based_p); else call ioa_$ioa_stream (debug_output, "ARG ^2d: ^w ^w",j,argp->fword,addrel(argp,1)->fword); end; else if type = 1 then /* real fixed bin single */ call ioa_$ioa_stream (debug_output, "ARG ^2d: ^d",j,argp -> fword); else if type = 3 then call ioa_$ioa_stream (debug_output, "ARG ^2d: ^e",j,argp -> flword); else if type = 1003 then call ioa_$ioa_stream (debug_output, "ARG ^2d: ^16.6f",j,argp -> flword); else if type = 4 then call ioa_$ioa_stream (debug_output, "ARG ^2d: ^e", j, argp->dblword); /* long precision */ else if type = 20 then do; /* var and non-var bit string */ strl = addrel(argp,-1) -> fword; bs: c72 = ""; /* set to blanks */ do i = 1 to min(strl,72); if substr(bit_string,i,1) = "1"b then substr(c72,i,1) = "1"; else substr(c72,i,1) = "0"; end; call ioa_$ioa_stream (debug_output, "ARG ^2d: ""^a""b",j,c72); end; else if type = 22 then /* var char string */ do; strl = min(32,addrel(argp,-1) -> fword); cs: call ioa_$ioa_stream (debug_output, "ARG ^2d: ""^va""",j,strl,char_string); end; else if type = -1 then /* */ fw: call ioa_$ioa_stream (debug_output, "ARG ^2d: ^w",j,argp -> fword); /* full word octal */ else if type = 15 | type = 16 then call ioa_$ioa_stream (debug_output, "ARG ^2d: ^p, ^p",j,argp -> lv.ptr,argp -> lv.stack); else if type = -2 then call ioa_$ioa_stream (debug_output, "ARG ^2d -> ^p",j,argp); /* location of arg */ else end_loop: call ioa_$ioa_stream (debug_output, "ARG ^2d: Type ^d not handled.",j,type); end; return; end;  pl1_frame_.pl1 11/20/86 1404.9r w 11/20/86 1145.0 35613 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ pl1_frame_: proc (spt, ans); /* sets ans = "1"b if stack frame pointed at by pt is a pl1 frame */ /* Modified: 2 Januaray, 1973 by S. Webber for 6180. */ dcl spt ptr, (bc, code) fixed bin, ans bit (1) aligned; dcl pl1_operators$call_out ptr ext; dcl p ptr int static, (defp, pt) ptr, v2 bit (1) int static, legal_f_ entry (ptr) returns (fixed bin), bit_word aligned bit (36) based (p), fix_word fixed bin based (p), (addr, addrel, baseptr, divide, fixed, null, ptr, rel, substr) builtin, pl1_frame_ entry (ptr) returns (aligned bit (1)); dcl lang fixed bin; dcl based_ptr ptr based; dcl 1 half aligned based, 2 (left, right) unaligned bit (18); dcl 1 acc aligned based, 2 length unal bit (9), 2 string unal char (1); /* */ %include definition; /* */ %include stack_frame; /* */ %include its; %include pl1_stack_frame; /* */ pt = spt; /* Clear out any flags (such as condition list present) which may have been set in stack frame pointer. This is necessary because the pointer we are passed may actually be the back point in a stack frame */ addr (pt) -> its.pad1 = "0"b; addr (pt) -> its.pad2 = "0"b; if pt = null /* pt can't possibly point to a stack frame */ then do; no: ans = "0"b; return; end; if legal_f_ (pt) ^= 0 then goto no; /* check to see if frame is at least threaded */ lang = fixed(pt -> stack_frame.translator_id, 18); /* find out which translator produced the segment */ if lang = 2 then v2 = "0"b; /*PL/I, version 1 */ else if lang = 0 then v2 = "1"b; /* pl/I version 2 */ else go to no; /* not PL/I at all */ /* get entry pointer for use by "name" entry */ p = pt -> stack_frame.entry_ptr; ans = "1"b; return; /* */ pl1_frame_$name: entry (spt, name_pt, name_size); /* sets name_pt & name_size to determine name of pl1 program corresponding to stack frame pointed at by pt. name_pt will be set to null if frame is not a pl1 frame */ dcl name_pt ptr, name_size fixed bin; if ^ pl1_frame_ (spt) /* first see if we have a good pl1 frame */ then do; /* if not, there's no name to return */ l2: name_pt = null; name_size = 0; return; end; /* p now contains the entry pointer */ if addrel(p, 1) -> bit_word = "000000000110001100010111010001000000"b then /* a tsbbp ap|614 marks the entry as a begin block */ go to l2; /* in which case we can't get the name */ if v2 /* for Version II */ then do; p = addrel (p, -1); /* length of name is 1 word before entry */ if p -> half.left then goto std_obj; /* left half ^= 0 means std object segment */ goto l1; end; /* for Version I */ /* name-size is 3 words before entry point */ p = addrel(p, -3); l1: name_size = p -> fix_word; /* get length of name in characters */ name_pt = addrel (p, -divide (name_size+3, 4, 18, 0)); /* name immediately precedes length; get length in */ /* words (rounding up) and subtract from pointer */ return; /* For a standard object segment we use the fact that the linkage ptr in the stack frame points to the linkage header in CLS and the first two words in linkage header point to definition section */ std_obj: defp = spt -> pl1_stack_frame.linkage_ptr -> based_ptr; p = addrel (defp, p -> half.left); p = addrel (defp, p -> definition.symbol); name_size = fixed (p -> acc.length, 9); name_pt = addr (p -> acc.string); end;  print_text_.pl1 02/20/86 0912.8rew 02/19/86 1047.2 167049 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-05-13,Farley), approve(85-05-13,MCR7242), audit(85-05-13,Fawcett), install(86-02-19,MR12.0-1019): Added EIS Indirect Descriptors. END HISTORY COMMENTS */ /* Program to display output text produced by pl/1 and Fortran. A reduced version of display_text. Numbers in the disassembled instruction are decimal. The offset and the instruction as it apears in core are in octal. The numbers are really in octal, despite comment. Modified by JRDavis 19 Mar 80 to not call binoct (which was transfer vector to pl1 compiler lang_util_ MCR 4422 Modified April 1985 by Paul Farley to add EIS Indirect Descriptors. */ print_text_: proc (t_pt, arg_number, output_switch); dcl t_pt ptr, /* points at text base */ arg_number fixed bin, /* max. no. of words to print */ output_switch char (*) aligned, /* switch name for printing disassembled line */ arg_offset fixed bin (18), /* real offset to be printed instead of t_pt */ arg_string char (*) var; /* output. Contains formatted instruction */ dcl number fixed bin; /* no. of words to print */ dcl desc_type fixed bin; /* descriptor type: 0 = alpha, 1 = bit, 2 = numeric */ dcl comment char (50) var; dcl op_name char (32) aligned; dcl (p, pt) ptr, (no_to_print, j, k, m, op_index, irand, nrands, ndesc) fixed bin, (fract_offset, offset, scale) fixed bin (18), (double, eis, eis_desc, need_comma, ext_base, has_ic, decimal, ind_desc) bit (1), ht char (1) int static aligned init (" "), /* tab */ htht char (2) int static aligned init (" "), /* two tabs */ cstring char (12), op_code char (5), tag char (3), line char (256), buff char (12) varying, pl1_operators_$operator_table fixed bin ext; dcl repeat_inst bit (1); /* ON for rpd, rpt, rpl */ dcl print_instr bit (1); /* 1= print instr; 0= return formatted string */ dcl real_offset_entry bit (1) unal; /* ON if instruction ptr is different from text location */ dcl real_offset fixed bin (18); /* used with $format, $offset entries */ dcl ioa_$ioa_stream ext entry options (variable); dcl ioa_$rsnnl ext entry options (variable); dcl find_operator_name_ entry (char (*) aligned, ptr, char (32) aligned); dcl (addr, addrel, fixed, length, ptr, rel, string, substr) builtin; dcl 1 op_mnemonic_$op_mnemonic (0:1023) ext static aligned, 2 opcode char (6) unal, 2 dtype fixed bin (2) unal, /* 0 = alpha, 1 = bit, 2 = numeric */ 2 num_desc fixed bin (5) unal, 2 num_words fixed bin (8) unal; dcl digit (0:9) char (1) aligned int static init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9"); dcl base (0:7) char (4) aligned int static init ("pr0|", "pr1|", "pr2|", "pr3|", "pr4|", "pr5|", "pr6|", "pr7|"); dcl modifier (0:63) char (3) aligned int static init (" ", "au", "qu", "du", "ic", "al", "ql", "dl", "0", "1", "2", "3", "4", "5", "6", "7", "*", "au*", "qu*", "...", "ic*", "al*", "ql*", "...", "0*", "1*", "2*", "3*", "4*", "5*", "6*", "7*", "f", "itp", "...", "its", "sd", "scr", "f2", "f3", "ci", "i", "sc", "ad", "di", "dic", "id", "idc", "*n", "*au", "*qu", "*du", "*ic", "*al", "*ql", "*dl", "*0", "*1", "*2", "*3", "*4", "*5", "*6", "*7"); dcl word (0:1) bit (36) aligned based (p); dcl 1 instruction based (p) aligned, 2 base unaligned bit (3), 2 offset unaligned bit (15), 2 op_code unaligned bit (10), 2 inhibit unaligned bit (1), 2 ext_base unaligned bit (1), 2 tag unaligned bit (6); dcl 1 half based (p) aligned, 2 left unaligned bit (18), 2 right unaligned bit (18); dcl 1 mod_factor aligned, 2 ext_base bit (1) unal, 2 length_in_reg bit (1) unal, 2 indirect_descriptor bit (1) unal, 2 tag bit (4) unal; dcl mf (3) fixed bin (6) int static init (30, 12, 3); /* location of modification factor fields in EIS inst */ dcl (ebase, len_reg, idesc, ic) (3) bit (1) aligned; dcl desc_word char (8) varying; dcl desc_op (0:3) char (8) varying int static init ("desc9a", "descb", "desc9fl", "desc9ls"); dcl eis_modifier (0:15) char (3) aligned int static init ("n", "au", "qu", "du", "ic", "al", "ql", "...", "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7"); dcl bool_word (0:15) char (6) aligned int static varying init ("clear", "and", "andnot", "move", "", "", "xor", "or", "", "", "", "", "invert", "", "nand", "set"); dcl 1 descriptor based aligned, /* EIS descriptor */ 2 address bit (18) unal, 2 char bit (2) unal, 2 bit bit (4) unal, 2 length bit (12) unal; /* */ number = arg_number; print_instr = "1"b; real_offset_entry = "0"b; p = t_pt; begin: substr (line, 11, 3) = " "; eis = "0"b; irand = 0; do no_to_print = 1 to number; comment = ""; tag = " "; substr (line, 7, 2) = " "; cstring = binoct (p -> word (0)); if eis then op_index = 0; else do; op_index = fixed (p -> instruction.op_code, 10); op_code = opcode (op_index); end; if num_words (op_index) > 1 then call eis_instruction; else do; has_ic, double, repeat_inst = "0"b; eis_desc = eis & (ind_desc | desc_word ^= "arg"); if eis_desc then call eis_descriptor; else do; substr (line, 13, 2) = " "; substr (line, 15, 6) = substr (cstring, 2, 5); substr (line, 21, 5) = substr (cstring, 7, 4); substr (line, 26, 8) = substr (cstring, 11, 2) || ht || op_code; k = 34; ext_base = p -> instruction.ext_base; if op_code = "rpd " | op_code = "rpt " | op_code = "rpl " then do; repeat_inst = "1"b; call ioa_$rsnnl ("^d", tag, j, fixed (p -> instruction.tag, 6)); offset = fixed (substr (p -> half.left, 1, 8), 8); substr (line, 14, 1) = cstring; call ioa_$rsnnl (" ^d", buff, j, offset); substr (line, k, j) = buff; k = k + j; end; else do; if num_desc (op_index) ^= 0 then tag = substr (binoct ((p -> instruction.tag)), 1, 2); else do; if p -> instruction.tag then tag = modifier (fixed (p -> instruction.tag, 6)); double = substr (op_code, 1, 2) = "df" | substr (op_code, 3, 2) = "aq" | substr (op_code, 4, 2) = "aq"; has_ic = p -> instruction.tag = "000100"b; /* IC */ end; call address; end; call set_tag; end; /* Print data referred to by self relative address: (tab) (tab) data offset = contents */ if has_ic then do; if real_offset_entry then pt = ptr (p, real_offset + offset - irand); else pt = addrel (p, offset-irand); substr (line, k, 8) = htht || binoct (rel (pt)); k = k + 8; if substr (op_code, 1, 1) ^= "t" then do; comment = " = " || binoct (pt -> word (0)); if double then comment = comment || " " || binoct (pt -> word (1)); end; end; else if ext_base & (p -> instruction.base = "000"b) then do; /* info for pr0 only */ if op_code = "xec " then do; pt = addrel (addr (pl1_operators_$operator_table), offset); op_index = fixed (pt -> instruction.op_code, 10); if num_words (op_index) > 1 then do; /* we are executing an EIS instruction in pl1_operators_ */ call init_eis; do j = 1 to ndesc; ebase (j) = "1"b; len_reg (j) = ^ decimal; ic (j) = "0"b; end; end; end; if tag ^= " " then do; call find_operator_name_ ("pl1_operators_", p, op_name); if op_name ^= " " then do; substr (line, k, 34) = htht || op_name; k = k + 34; end; end; end; if ^eis_desc & ^repeat_inst & p -> instruction.inhibit then comment = comment || " interrupt inhibit"; end; if comment ^= "" then do; j = length (comment); substr (line, k, j) = comment; k = k + j; end; if print_instr then call ioa_$ioa_stream (output_switch, "^6o ^a", fixed (rel (p), 17), substr (line, 11, k-11)); else do; /* return string for one line only */ j = k - 11; /* save length of strjng */ k = 1; call bin_to_oct (real_offset); arg_string = substr (line, 1, k-1) || substr (line, 11, j); return; end; if eis then do; irand = irand + 1; if irand > nrands then do; eis = "0"b; irand = 0; end; else if irand > ndesc then op_code, desc_word = "arg"; end; p = addrel (p, 1); end; return; /* */ /* Entry point to return a formatted string with the disassembled instruction. The real offset is returned in the string. */ print_text_$real_offset: entry (t_pt, arg_string, arg_offset); p = t_pt; real_offset = arg_offset; number = 1; /* process one word only */ print_instr = "0"b; /* return string instead */ real_offset_entry = "1"b; go to begin; print_text_$format: entry (t_pt, arg_string); number = 1; p = t_pt; real_offset = fixed (rel (p), 18); print_instr = "0"b; real_offset_entry = "0"b; go to begin; bin_to_oct: proc (number); dcl (m, number) fixed bin (18); call ioa_$rsnnl ("^o", buff, m, number); substr (line, k, m) = buff; k = k + m; end bin_to_oct; init_eis: proc; eis = "1"b; nrands = num_words (op_index) - 1; ndesc = num_desc (op_index); decimal = dtype (op_index) = 2; desc_word = desc_op (dtype (op_index)); desc_type = dtype (op_index); irand = 0; end init_eis; /* */ eis_instruction: proc; call init_eis; substr (line, 13, 4) = substr (cstring, 1, 3); substr (line, 17, 4) = substr (cstring, 4, 3); substr (line, 21, 4) = substr (cstring, 7, 3); substr (line, 25, 3) = substr (cstring, 10, 3); substr (line, 28, 1) = ht; substr (line, 29, 5) = op_code; substr (line, 34, 1) = ht; k = 35; do j = 1 to ndesc; string (mod_factor) = substr (p -> word (0), mf (j), 7); ebase (j) = mod_factor.ext_base; len_reg (j) = mod_factor.length_in_reg; idesc (j) = mod_factor.indirect_descriptor; substr (line, k, 1) = "("; k = k + 1; need_comma = "0"b; if ebase (j) then do; substr (line, k, 2) = "pr"; k = k + 2; need_comma = "1"b; end; if len_reg (j) then do; if need_comma then do; substr (line, k, 1) = ","; k = k + 1; end; substr (line, k, 2) = "rl"; k = k + 2; need_comma = "1"b; end; if idesc (j) then do; if need_comma then do; substr (line, k, 1) = ","; k = k + 1; end; substr (line, k, 2) = "id"; k = k + 2; need_comma = "1"b; end; if mod_factor.tag then do; if need_comma then do; substr (line, k, 1) = ","; k = k + 1; end; ic (j) = mod_factor.tag = "0100"b; /* IC */ substr (line, k, 2) = eis_modifier (fixed (mod_factor.tag, 4)); k = k + 2; end; else ic (j) = "0"b; substr (line, k, 2) = "),"; k = k + 2; end; if substr (p -> word (0), 10, 1) then do; substr (line, k, 12) = "enablefault,"; k = k + 12; end; if desc_word = "desc9a" then if ndesc < 3 then do; if substr (op_code, 1, 2) ^= "sc" then substr (line, k, 5) = "fill("; else substr (line, k, 5) = "mask("; k = k + 5; substr (line, k, 3) = substr (cstring, 1, 3); k = k + 3; substr (line, k, 1) = ")"; k = k + 1; end; else k = k - 1; else if desc_word = "descb" then do; substr (line, k, 7) = "fill(" || digit (fixed (substr (p -> word (0), 1, 1), 1)) || ")"; /* fill(N) */ k = k + 7; if op_code ^= "cmpb " then do; substr (line, k, 6) = ",bool("; k = k + 6; j = fixed (substr (p -> word (0), 6, 4), 4); m = length (bool_word (j)); if m > 0 then do; substr (line, k, m) = bool_word (j); k = k + m; end; else do; substr (line, k, 1) = digit (fixed (substr (p -> word (0), 6, 1), 1)); substr (line, k+1, 1) = digit (fixed (substr (p -> word (0), 7, 3), 3)); k = k + 2; end; substr (line, k, 1) = ")"; k = k + 1; end; end; else if substr (p -> word (0), 11, 1) then do; substr (line, k, 5) = "round"; k = k + 5; end; else k = k - 1; return; end eis_instruction; /* */ eis_descriptor: proc; dcl len fixed bin (18); dcl type fixed bin; /* descriptor type */ dcl 1 n_desc aligned based (p), 2 y bit (18) unal, /* address field */ 2 CN bit (3) unal, /* character position */ 2 TN bit (1) unal, /* type 0 = 9bit; 1 = 4 bit */ 2 S bit (2) unal, /* sign type 0 = fl, 1 = ls, 2 = ts, 3 = ns */ 2 SF bit (6) unal, /* scale factor */ 2 N bit (6) unal; /* length */ dcl 1 b_desc aligned based (p), /* bit descriptor */ 2 y bit (18) unal, /* address field */ 2 c bit (2) unal, /* 9 bit offset */ 2 b bit (4) unal, /* bit offset */ 2 N bit (12) unal; /* length */ dcl 1 a_desc aligned based (p), /* alpha-numeric descriptor */ 2 y bit (18) unal, /* address field */ 2 CN bit (3) unal, /* character offset */ 2 TA bit (2) unal, 2 pad bit (1) unal, /* always zero */ 2 N bit (12) unal; /* length */ dcl table_n_S (0:3) char (2) int static init ("fl", "ls", "ts", "ns"); dcl table_a_TA (0:3) char (1) int static init ("9", "6", "4", "?"); ind_desc = idesc (irand); if ind_desc then do; call ind_descriptor; return; end; substr (line, 13, 2) = " "; substr (line, 15, 6) = substr (cstring, 2, 5); substr (line, 21, 3) = substr (cstring, 7, 2); substr (line, 24, 4) = substr (cstring, 9, 4); substr (line, 28, 1) = ht; ext_base = ebase (irand); has_ic = ic (irand); type = desc_type; if op_code = "btd" & irand = 1 then type = 0; else if op_code = "dtb" | op_code = "mvne" then if irand > 1 then type = 0; if type = 0 then do; /* alpha-nummeric descriptor */ desc_word = "desc" || table_a_TA (fixed (a_desc.TA, 2)) || "a"; if a_desc.TA = "00"b then fract_offset = fixed (substr (a_desc.CN, 1, 2), 2); else fract_offset = fixed (a_desc.CN, 3); len = fixed (a_desc.N, 12); end; else if type = 1 then do; /* bit descriptor */ desc_word = "descb"; len = fixed (b_desc.N, 12); fract_offset = fixed (b_desc.c, 2) * 9 + fixed (b_desc.b, 4); end; else do; /* numeric descriptor */ if n_desc.TN then do; desc_word = "desc4"; fract_offset = fixed (n_desc.CN,3); end; else do; desc_word = "desc9"; fract_offset = fixed (substr (n_desc.CN, 1, 2), 2); end; desc_word = desc_word || table_n_S (fixed (n_desc.S, 2)); len = fixed (n_desc.N, 6); if n_desc.S then do; /* for S = 00 there is no scale factor */ scale = fixed (n_desc.SF, 6); if scale > 32 then scale = scale - 64; end; end; /* desc_word address(fract_offset),tag,length,scale */ k = length (desc_word); substr (line, 29, k) = desc_word; k = k + 29; call address; if fract_offset ^= 0 then do; call ioa_$rsnnl ("(^d)", buff, j, fract_offset); substr (line, k, j) = buff; k = k + j; end; if len_reg (irand) then do; /* print register which contains length */ tag = eis_modifier (fixed (substr (p -> descriptor.length, 9, 4), 4)); call set_tag; end; else do; /* print length as given */ substr (line, k, 1) = ","; k = k + 1; call bin_to_oct (len); end; if type = 2 then if n_desc.S then do; /* scale factor for numeric only */ substr (line, k, 1) = ","; k = k+1; call bin_to_oct (scale); end; return; end eis_descriptor; /* */ ind_descriptor: proc; dcl 1 i_desc aligned based (p), /* indirect descriptor */ 2 y bit (18) unal, /* address field */ 2 pad bit (11) unal, /* always zero */ 2 extbase bit (1) unal, /* PR mod */ 2 pad1 bit (2) unal, /* always zero */ 2 tag bit (4) unal; /* reg mod */ substr (line, 13, 2) = " "; substr (line, 15, 6) = substr (cstring, 2, 5); substr (line, 21, 5) = substr (cstring, 7, 4); substr (line, 26, 2) = substr (cstring, 11, 2); substr (line, 28, 1) = ht; ext_base = i_desc.extbase; has_ic = (i_desc.tag = "0100"b); desc_word = "arg"; k = length (desc_word); substr (line, 29, k) = desc_word; k = k + 29; call address; if i_desc.tag then do; substr (line, k, 3) = "," || eis_modifier (fixed (i_desc.tag, 4)); k = k + 3; end; return; end ind_descriptor; /* */ /* This procedure disassembles the address portion. It adds: tab [prN|] offset It also sets the first octal digit so a blank will separate the register from the rest of the address field. cstring The octal representation of the word. ext_base ON if the address uses a register. */ address: proc; substr (line, k, 1) = ht; k = k + 1; if ext_base then do; substr (line, k, 4) = base (fixed (p -> instruction.base, 3)); offset = fixed (p -> instruction.offset, 15); if offset > 16384 then offset = offset - 32768; k = k+4; substr (line, 13, 1) = cstring; end; else do; offset = fixed (p -> half.left, 18); if offset > 131072 then if tag ^= "du " & tag ^= "dl " then offset = offset - 262144; /* 2's comp */ substr (line, 14, 1) = cstring; end; call bin_to_oct (offset); end address; /* This procedure sets the tag in the instruction line. */ set_tag: proc; if tag ^= " " then do; substr (line, k, 4) = "," || tag; k = k + 2; if substr (line, k, 1) ^= " " then k = k + 1; if substr (line, k, 1) ^= " " then k = k + 1; end; return; end set_tag; binoct: proc (bits) returns (char (12) aligned); dcl bits bit (*) aligned parameter; dcl c12 char (12) aligned; call ioa_$rsnnl ("^12.3b", c12, (0), bits); return (c12); end binoct; end; 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