db_fnp_break_.pl1 11/15/82 1816.2rew 11/15/82 1501.3 187326 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_BREAK_ - Implements the breakpoint options of debug_fnp */ /* Written September 1977 by Larry Johnson */ db_fnp_break_: proc; /* Parameters */ dcl arg_corep ptr; dcl arg_fnp fixed bin; dcl arg_cmd_infop ptr; dcl arg_expr_infop ptr; /* Automatic */ dcl corep ptr; dcl fnp fixed bin; dcl code fixed bin (35); dcl i fixed bin; dcl something_printed bit (1); dcl edited_addr char (32) var; dcl mem_buf (32) bit (18) unal; dcl ntibs fixed bin; dcl state fixed bin; dcl break_reset bit (1); dcl crbrk_val fixed bin; dcl break_address fixed bin; dcl line_given bit (1); dcl tty_name char (8); dcl stop_trace bit (1); dcl start_trace bit (1); dcl address_given bit (1); dcl reset_sw bit (1); dcl 1 temp_expr_info like expr_info aligned automatic; dcl 1 fnp_break_info aligned, /* Info structure for setting breaks */ 2 channel char (6), 2 address fixed bin, 2 action fixed bin, 2 flags, 3 trace bit (1) unal, 3 pad bit (35) unal; dcl SET fixed bin int static options (constant) init (1); /* Values for fnp_break_info.action */ dcl RESET fixed bin int static options (constant) init (2); dcl START fixed bin int static options (constant) init (3); dcl break_error (7) char (32) var int static options (constant) init ( /* Error codes read from fnp */ "Bad address.", "Bad line number.", "No entry in break table.", "Not stopped at breakpoint.", "No room in break table.", "No opblock at address.", "Invalid request."); /* Alocated copy of break table */ dcl brk_tab_start fixed bin; dcl brk_tab_size fixed bin; dcl brk_tabp ptr init (null); dcl 1 brk_tab aligned based (brk_tabp), 2 entry (brk_tab_size) unal, 3 address fixed bin (17) unal, 3 line fixed bin (17) unal, 3 opblock bit (18) unal, 3 flags bit (18) unal; dcl tib_tablep ptr init (null); /* Pointer to temp copy of tib table */ dcl 1 tib_table aligned based (tib_tablep), 2 entries (ntibs) unal, 3 address fixed bin (17) unal, /* Address ot tib */ 3 q fixed bin (17) unal; /* Address of q */ dcl brk_listp ptr init (null); /* Pointer to list of tibs at breaks */ dcl brk_list_cnt fixed bin; /* Number of such tibs */ dcl 1 brk_list aligned based (brk_listp), 2 entries (ntibs) unal, 3 line fixed bin (17) unal, 3 t_cur fixed bin (17) unal; /* Internal static */ dcl symbols_looked_up bit (1) int static init ("0"b); /* Set once all following symbols are set */ dcl crbrk fixed bin int static; dcl crttb fixed bin int static; dcl crtte fixed bin int static; dcl t_flg3 fixed bin int static; dcl t_cur fixed bin int static; dcl t_line fixed bin int static; dcl bkptop bit (18) int static; dcl tfbkpt bit (18) int static; dcl free_areap ptr int static; dcl call_type fixed bin int static init (0); /* Says which type of ring0 call to use */ dcl free_area area based (free_areap); dcl name char (13) int static options (constant) init ("db_fnp_break_"); /* External */ dcl db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin); dcl db_fnp_util_$edit_module_addr_force entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35)); dcl db_fnp_util_$edit_module_addr_paren entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35)); dcl db_fnp_util_$cv_chan_name entry (ptr, fixed bin, char (*), char (*), fixed bin, fixed bin (35)); dcl db_fnp_util_$cv_line_no entry (ptr, fixed bin, fixed bin, char (*), fixed bin (35)); dcl db_fnp_util_$get_chan_addrs entry (ptr, fixed bin, char (*), ptr, fixed bin (35)); dcl db_fnp_opblock_util_$get_name entry (bit (18), char (*)); dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl db_fnp_reader_$get_operand entry (ptr); dcl db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_opblock_util_$lookup entry (char (*), bit (18), fixed bin (35)); dcl hphcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35)); dcl hphcs_$tty_control entry (char (*), char (*), ptr, fixed bin (35)); dcl sub_err_ entry options (variable); dcl com_err_ entry options (variable); dcl get_system_free_area_ entry returns (ptr); dcl ioa_ entry options (variable); dcl ioa_$nnl entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl get_fnp_name_ entry (fixed bin) returns (char (32)); dcl iox_$user_output ext ptr; dcl (cleanup, linkage_error) condition; dcl (addr, bin, divide, length, max, null, string) builtin; /* Entry to set a breakpoint */ set: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; on cleanup call clean_up; if corep ^= null then do; call ioa_ ("Only valid on a running FNP."); go to error_return; end; call get_operand; /* Address */ if cmd_info.endline then do; call ioa_ ("No address"); go to error_return; end; call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", break_address, code); if code ^= 0 then go to error_return; line_given = "0"b; stop_trace = "0"b; call get_operand; /* Scan command line */ do while (^cmd_info.endline); if operand = "-stop_trace" then stop_trace = "1"b; else if ^line_given then do; call db_fnp_util_$cv_chan_name (corep, fnp, operand, tty_name, i, code); /* See if good line number */ if code ^= 0 then do; call com_err_ (code, name, "^a", operand); go to error_return; end; line_given = "1"b; end; else do; /* Bad arg */ call ioa_ ("Invalid operand: ^a", operand); go to error_return; end; call get_operand; end; fnp_break_info.address = break_address; fnp_break_info.action = SET; if line_given then fnp_break_info.channel = tty_name; else fnp_break_info.channel = ""; string (fnp_break_info.flags) = "0"b; fnp_break_info.trace = stop_trace; call make_order_call; call check_break_error; if code ^= 0 then do; call ioa_ ("Break not set: ^a", break_error (code)); go to error_return; end; call clean_up; return; /* Entry to reset breaks */ reset: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; on cleanup call clean_up; if corep ^= null then do; call ioa_ ("Only valid on a running FNP."); go to error_return; end; call get_operand; /* Read address */ if cmd_info.endline then do; call ioa_ ("No address specified"); go to error_return; end; if operand = "-all" | operand = "-a" then do; /* Reset all breaks */ call get_break_table; /* First need lines at breaks */ break_reset = "0"b; do i = 1 to brk_tab_size; /* Loop thru all breaks */ if brk_tab.address (i) ^= 0 then do; /* Found non-empty entry */ break_reset = "1"b; call reset_one_break ((brk_tab.address (i))); end; end; if ^break_reset then call ioa_ ("No breaks found."); end; else do; /* Reset one break */ call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", i, code); if code = 0 then call reset_one_break (i); end; call clean_up; return; /* Entry to restart a stopped channel */ start: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; on cleanup call clean_up; if corep ^= null then do; call ioa_ ("Only valid on a running FNP."); go to error_return; end; call get_operand; if cmd_info.endline then do; call ioa_ ("No line given."); go to error_return; end; if operand = "-all" | operand = "-a" then do; /* Start all lines */ call find_stopped_channels; if brk_list_cnt = 0 then do; /* None */ call ioa_ ("No lines stopped at breaks."); go to start_break_end; end; do i = 1 to brk_list_cnt; /* Start each line */ call db_fnp_util_$cv_line_no (corep, fnp, (brk_list.line (i)), tty_name, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to convert ^o to tty name.", brk_list.line (i)); cmd_info.flush = "1"b; /* Treat as error, but continue */ go to start_next; end; fnp_break_info.channel = tty_name; fnp_break_info.address = 0; fnp_break_info.action = START; string (fnp_break_info.flags) = "0"b; call make_order_call; call check_break_error; if code ^= 0 then do; call ioa_ ("^a not restarted. ^a", tty_name, break_error (code)); cmd_info.flush = "1"b; /* Treat as error */ end; else call ioa_ ("^a restarted.", tty_name); start_next: end; end; else do; /* Start one line */ call db_fnp_util_$cv_chan_name (corep, fnp, operand, tty_name, i, code); if code ^= 0 then do; call com_err_ (code, name, "^a", operand); go to error_return; end; address_given = "0"b; reset_sw = "0"b; start_trace = "0"b; call get_operand; do while (^cmd_info.endline); /* Scan command */ if operand = "-reset" then reset_sw = "1"b; else if operand = "-start_trace" then start_trace = "1"b; else if ^address_given then do; call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", break_address, code); if code ^= 0 then go to error_return; address_given = "1"b; end; else do; call ioa_ ("Invalid operand: ^a", operand); go to error_return; end; call get_operand; end; if reset_sw then do; temp_expr_info = expr_info; /* Setup dummy structure */ temp_expr_info.tib_known = "0"b; call db_fnp_util_$get_chan_addrs (corep, fnp, tty_name, addr (temp_expr_info), code); if code ^= 0 then do; no_reset_tib: call com_err_ (code, name, "Cant get tib address for ^a", tty_name); go to error_return; end; if ^temp_expr_info.tib_known then go to no_reset_tib; call fetch_words (temp_expr_info.tib_addr + t_cur, 1, addr (mem_buf)); call reset_one_break (bin (mem_buf (1))); end; fnp_break_info.channel = tty_name; fnp_break_info.action = START; if address_given then fnp_break_info.address = break_address; else fnp_break_info.address = 0; string (fnp_break_info.flags) = "0"b; fnp_break_info.trace = start_trace; call make_order_call; call check_break_error; if code ^= 0 then do; call ioa_ ("^a not restarted. ^a", tty_name, break_error (code)); go to error_return; end; else call ioa_ ("^a restarted", tty_name); end; start_break_end: call clean_up; return; /* Entry to list breakpoints */ list: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; on cleanup call clean_up; call get_break_table; /* Find break table in fnp */ call find_stopped_channels; something_printed = "0"b; do i = 1 to brk_tab_size; if brk_tab.address (i) ^= 0 then call print_one_break ((brk_tab.address (i)), brk_tab.opblock (i), (brk_tab.line (i))); end; do i = 1 to brk_list_cnt; /* Also print lines stopped at non-std breaks */ if brk_list.line (i) ^= -1 then call print_one_break ((brk_list.t_cur (i)), "0"b, -1); end; if ^something_printed then call ioa_ ("No breaks set"); call clean_up; return; /* Procedure to print one break point. */ print_one_break: proc (a, o, l); dcl a fixed bin; /* Address */ dcl o bit (18); /* Origional opblcok */ dcl l fixed bin; /* Line number */ dcl i fixed bin; dcl optemp char (6); dcl 1 b unal, /* The bbasic print line */ 2 address char (10), 2 opblock char (8), 2 line char (6); if ^something_printed then call ioa_ ("ADDRESS OPBLOCK LINE LINES STOPPED"); something_printed = "1"b; call db_fnp_util_$edit_module_addr_force (corep, fnp, a, edited_addr, code); if code ^= 0 then call ioa_$rsnnl ("^o", b.address, (0), a); else b.address = edited_addr; if o = "0"b then b.opblock = ""; else do; call db_fnp_opblock_util_$get_name (o, optemp); if optemp = "" then call ioa_$rsnnl ("^.3b", b.opblock, (0), o); else b.opblock = optemp; end; if l = -1 then b.line = ""; else do; call db_fnp_util_$cv_line_no (corep, fnp, l, tty_name, code); if code = 0 then b.line = tty_name; else call ioa_$rsnnl ("^o", b.line, (0), l); end; call iox_$put_chars (iox_$user_output, addr (b), length (string (b)), code); do i = 1 to brk_list_cnt; /* Print lines stopped at this break */ if (brk_list.t_cur (i) = a) & (brk_list.line (i) ^= -1) then do; call db_fnp_util_$cv_line_no (corep, fnp, (brk_list.line (i)), tty_name, code); if code ^= 0 then call ioa_$nnl (" ^o", brk_list.line (i)); else call ioa_$nnl (" ^a", tty_name); brk_list.line (i) = -1; /* Dont print again */ end; end; call ioa_ (""); /* Finish the line */ return; end print_one_break; /* Initialization procedure */ setup: proc; dcl fb fixed bin (17) unal; corep = arg_corep; fnp = arg_fnp; expr_infop = arg_expr_infop; cmd_infop = arg_cmd_infop; if ^symbols_looked_up then do; /* Once per process */ crbrk = db_fnp_sym_util_$get_value (".crbrk"); crttb = db_fnp_sym_util_$get_value (".crttb"); crtte = db_fnp_sym_util_$get_value (".crtte"); t_flg3 = db_fnp_sym_util_$get_value ("t.flg3"); t_cur = db_fnp_sym_util_$get_value ("t.cur"); t_line = db_fnp_sym_util_$get_value ("t.line"); fb = db_fnp_sym_util_$get_value ("tfbkpt"); tfbkpt = unspec (fb); call db_fnp_opblock_util_$lookup ("bkptop", bkptop, code); if code ^= 0 then call sub_err_ (code, name, "s", null, (0), "Unable to get code for ""bkptop"" opblock."); free_areap = get_system_free_area_ (); symbols_looked_up = "1"b; end; call get_crbrk_val; return; end setup; /* Procedure to fetch the break table */ get_break_table: proc; if brk_tabp = null then do; /* Havent inited yet */ call fetch_words (crbrk_val, 2, addr (mem_buf)); /* Get address and length */ brk_tab_start = bin (mem_buf (1)); brk_tab_size = bin (mem_buf (2)); allocate brk_tab in (free_area); end; call fetch_words (brk_tab_start, 4 * brk_tab_size, brk_tabp); return; end get_break_table; /* Get list of all channels stopped at break points */ find_stopped_channels: proc; dcl i fixed bin; dcl nw fixed bin; call fetch_words (crttb, 1, addr (mem_buf)); /* Get start of tib table */ i = bin (mem_buf (1)); call fetch_words (crtte, 1, addr (mem_buf)); /* And end */ ntibs = divide (bin (mem_buf (1), 17) - i, 2, 17, 0); allocate tib_table in (free_area); allocate brk_list in (free_area); call fetch_words (i, 2*ntibs, tib_tablep); /* Read the tib table */ nw = max (t_flg3, t_cur, t_line) + 1; /* Number of words to read to get all these fields */ brk_list_cnt = 0; /* Number of lines at breaks */ do i = 1 to ntibs; /* For each tib */ call fetch_words ((tib_table.address (i)), nw, addr (mem_buf)); /* Read stat of tib */ if mem_buf (t_flg3 + 1) & tfbkpt then do; /* If line at break */ brk_list_cnt = brk_list_cnt + 1; brk_list.line (brk_list_cnt) = bin (mem_buf (t_line+1)); brk_list.t_cur (brk_list_cnt) = bin (mem_buf (t_cur+1)); end; end; free tib_table; return; end find_stopped_channels; /* Reset a single breakpoint */ reset_one_break: proc (a); dcl a fixed bin; /* The address of the break */ dcl edited_addr char (16) var; call db_fnp_util_$edit_module_addr_paren (corep, fnp, a, edited_addr, code); /* Edit address for messages */ if code ^= 0 then edited_addr = "?"; call fetch_words (a, 1, addr (mem_buf)); /* Get opblock at location now */ if mem_buf (1) ^= bkptop then do; call ioa_ ("No break at ^a", edited_addr); cmd_info.flush = "1"b; /* Treat as error, but continue */ return; end; fnp_break_info.action = RESET; fnp_break_info.address = a; fnp_break_info.channel = ""; string (fnp_break_info.flags) = "0"b; call make_order_call; call check_break_error; /* Check for any error */ if code = 0 then call ioa_ ("Break at ^a reset.", edited_addr); else do; call ioa_ ("Break at ^a not reset. ^a", edited_addr, break_error (code)); cmd_info.flush = "1"b; end; return; end reset_one_break; /* Precedure to read memory */ fetch_words: proc (a, n, p); dcl a fixed bin; /* Address */ dcl n fixed bin; /* Word count */ dcl p ptr; /* Where to put them */ call db_fnp_memory_$fetch (corep, fnp, a, n, p, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to read location ^o.", a); go to error_return; end; return; end fetch_words; get_operand: proc; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; return; end get_operand; /* The hphcs interface_ */ make_order_call: proc; dcl fnp_name char (1); fnp_name = get_fnp_name_ (fnp); retry_order_call: if call_type = 0 then do; /* Haven't established which call to use */ on linkage_error go to call_1_failed; call hphcs_$tty_order (fnp, "fnp_break", addr (fnp_break_info), state, code); /* Try old call */ revert linkage_error; /* It worked */ call_type = 1; go to check_order_code; call_1_failed: on linkage_error go to call_2_failed; call hphcs_$tty_control (fnp_name, "fnp_break", addr (fnp_break_info), code); /* Try new call */ revert linkage_error; /* It worked */ call_type = 2; go to check_order_code; call_2_failed: revert linkage_error; /* Neither worked, must mean no access */ call sub_err_ (0, name, "h", null, (0), "No access to hphcs_ gate; unable to make fnp_break order call."); go to retry_order_call; end; else if call_type = 1 then call hphcs_$tty_order (fnp, "fnp_break", addr (fnp_break_info), state, code); else call hphcs_$tty_control (fnp_name, "fnp_break", addr (fnp_break_info), code); check_order_code: if code ^= 0 then do; call com_err_ (code, name); go to error_return; end; return; end make_order_call; /* Get value of .crbrk, which points to data in breakpoint_man */ get_crbrk_val: proc; call fetch_words (crbrk, 1, addr (mem_buf)); /* Get addr of brk tab ptr */ crbrk_val = bin (mem_buf (1)); if crbrk_val = 0 then do; call ioa_ ("No break table"); go to error_return; end; return; end get_crbrk_val; /* Get break error code, reason for failure of previous request */ check_break_error: proc; /* The following sleep call is a temporary kludge to avoid a potential problem which cannot be solved in MR6.0 because of lack of time. If the FNP should crash while a 'dump_fnp' order call is in progress, the Initializer will end up looping in ring 0 trying to lock the fnp_dump_segment in order to take a dump. The segment is, however, already locked to the process tperforming the 'fnp_dump' order and the Initializer will loop forever. Breakpoint operations are especially prone to this trap because each operation is immediatly followed by a 'dump_fnp' order to check the status of the operation. Therefore a start or set_break command which causes the FNP to crash will very likely cause this problem. The sleep call is an attempt to reduce the likely-hood of this happening by waiting after a breakpoint operation before checking the results. The theory is that if the FNP is going to crash as a result of the breakpoint operation, it will do so quickly, and the Initializer will be able to start the dump operation before we attemp the dump_fnp order. This is obviously a stopgap measure to be deleted as soon as posssible. */ call timer_manager_$sleep (250000, "10"b); call fetch_words (crbrk_val + 2, 1, addr (mem_buf)); code = bin (mem_buf (1)); return; end check_break_error; error_return: cmd_info.flush = "1"b; call clean_up; return; /* Cleanup handler */ clean_up: proc; if brk_tabp ^= null then free brk_tab; if tib_tablep ^= null then free tib_table; if brk_listp ^= null then free brk_list; return; end clean_up; %include debug_fnp_data; end db_fnp_break_;  db_fnp_buffer_status_.pl1 11/15/82 1816.2rew 11/15/82 1501.4 58311 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ db_fnp_buffer_status_: proc (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); /* Coded 7/25/78 by J. Stern */ /* Arguments */ dcl arg_corep ptr; dcl arg_fnp fixed bin; dcl arg_cmd_infop ptr; dcl arg_expr_infop ptr; /* Automatic */ dcl corep ptr; dcl fnp fixed bin; dcl (total_icpl, total_dcpl, total_ocnt) fixed bin; dcl (max_icpl, max_dcpl, max_ocnt) fixed bin; dcl (max_icpl_line, max_dcpl_line, max_ocnt_line) fixed bin; dcl (icpl, dcpl, ocnt, total) fixed bin; dcl code fixed bin (35); dcl (ttb_addr, tte_addr, tib_addr) fixed bin; dcl line fixed bin; dcl (n_free, n_small) fixed bin; dcl ttbx fixed bin; dcl brief_sw bit (1) aligned; dcl ttb_temp (0:599) fixed bin (17) unal; dcl temp (0:99) fixed bin (17) unal; /* Internal static */ dcl have_symbols bit (1) aligned int static init ("0"b); dcl (crnbf, crnbs, crttb, crtte) fixed bin int static; dcl (t_icpl, t_dcpl, t_ocnt, t_sfcm, t_line) fixed bin int static; dcl (sf_ib0, sf_ib1) fixed bin int static; dcl (tib_words_needed, sfcm_words_needed) fixed bin int static; /* Constants */ dcl whoami char (15) int static options (constant) init ("db_fnp_analyze_"); /* Builtins */ dcl (addr, null, divide, max, rtrim, substr) builtin; /* Entries */ dcl com_err_ entry options (variable); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin); dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl db_fnp_reader_$get_operand entry (ptr); dcl db_fnp_util_$cv_line_no entry (ptr, fixed bin, fixed bin, char (*), fixed bin (35)); %include debug_fnp_data; call setup; brief_sw = "0"b; call get_operand; if ^cmd_info.endline then do; if operand = "-bf" | operand = "-brief" then brief_sw = "1"b; else do; call com_err_ (0, "", "Invalid operand: ^a", operand); go to error_exit; end; end; total_icpl, total_dcpl, total_ocnt = 0; max_icpl, max_icpl_line, max_dcpl, max_dcpl_line, max_ocnt, max_ocnt_line = 0; call fetch_words (crttb, 1, addr (temp)); ttb_addr = temp (0); if ttb_addr = 0 then do; call com_err_ (0, whoami, "No tib table address."); go to error_exit; end; call fetch_words (crtte, 1, addr (temp)); tte_addr = temp (0); if tte_addr < ttb_addr then do; call com_err_ (0, whoami, "Invalid tib table end address. ^o", tte_addr); go to error_exit; end; call fetch_words (crnbf, 1, addr (temp)); n_free = temp (0); call fetch_words (crnbs, 1, addr (temp)); n_small = temp (0); call ioa_ ("^d free", n_free); call ioa_ ("^d small space", n_small); call fetch_words (ttb_addr, tte_addr-ttb_addr, addr (ttb_temp)); call ioa_ ("^/LINE^-INPUT^-DIA^-OUTPUT^-TOTAL^/"); do ttbx = 0 to tte_addr-ttb_addr-1 by 2; tib_addr = ttb_temp (ttbx); call fetch_words (tib_addr, tib_words_needed, addr (temp)); line = temp (t_line); icpl = max (0, temp (t_icpl)); dcpl = max (0, temp (t_dcpl)); ocnt = max (0, temp (t_ocnt)); if line > 512 then do; call fetch_words ((temp (t_sfcm)), sfcm_words_needed, addr (temp)); if temp (sf_ib0) ^= 0 then icpl = icpl + 1; if temp (sf_ib1) ^= 0 then icpl = icpl + 1; end; total_icpl = total_icpl + icpl; total_dcpl = total_dcpl + dcpl; total_ocnt = total_ocnt + ocnt; if brief_sw then do; if icpl > max_icpl then do; max_icpl = icpl; max_icpl_line = line; end; if dcpl > max_dcpl then do; max_dcpl = dcpl; max_dcpl_line = line; end; if ocnt > max_ocnt then do; max_ocnt = ocnt; max_ocnt_line = line; end; end; else do; total = icpl + dcpl + ocnt; if total ^= 0 then call ioa_ ("^a^-^3d^-^3d^-^3d^-^3d", chan_name (line), icpl, dcpl, ocnt, total); end; end; total = total_icpl + total_dcpl + total_ocnt; call ioa_ ("^/TOTAL^-^3d^-^3d^-^3d^-^3d", total_icpl, total_dcpl, total_ocnt, total); if brief_sw & max_icpl+max_dcpl+max_ocnt > 0 then do; call ioa_ ("^/Lines holding most buffers:"); if max_icpl > 0 then call ioa_ ("^d input for line ^a", max_icpl, chan_name (max_icpl_line)); if max_dcpl > 0 then call ioa_ ("^d dia for line ^a", max_dcpl, chan_name (max_dcpl_line)); if max_ocnt > 0 then call ioa_ ("^d output for line ^a", max_ocnt, chan_name (max_ocnt_line)); end; return; error_exit: cmd_info.flush = "1"b; setup: proc; corep = arg_corep; fnp = arg_fnp; cmd_infop = arg_cmd_infop; if ^have_symbols then do; crttb = db_fnp_sym_util_$get_value (".crttb"); crtte = db_fnp_sym_util_$get_value (".crtte"); crnbf = db_fnp_sym_util_$get_value (".crnbf"); crnbs = db_fnp_sym_util_$get_value (".crnbs"); t_icpl = db_fnp_sym_util_$get_value ("t.icpl"); t_dcpl = db_fnp_sym_util_$get_value ("t.dcpl"); t_ocnt = db_fnp_sym_util_$get_value ("t.ocnt"); t_sfcm = db_fnp_sym_util_$get_value ("t.sfcm"); t_line = db_fnp_sym_util_$get_value ("t.line"); sf_ib0 = db_fnp_sym_util_$get_value ("sf.ib0"); sf_ib1 = db_fnp_sym_util_$get_value ("sf.ib1"); tib_words_needed = max (t_icpl, t_dcpl, t_ocnt, t_sfcm, t_line) + 1; sfcm_words_needed = max (sf_ib0, sf_ib1) + 1; have_symbols = "1"b; end; end; /* setup */ fetch_words: proc (loc, len, p); dcl loc fixed bin; dcl len fixed bin; dcl p ptr; call db_fnp_memory_$fetch (corep, fnp, loc, len, p, code); if code ^= 0 then do; call com_err_ (code, whoami, "Unable to read location ^o.", loc); go to error_exit; end; end; /* fetch_words */ get_operand: proc; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_exit; end; /* get_operand */ chan_name: proc (line) returns (char (32) var); dcl line fixed bin; dcl line_name char (32); call db_fnp_util_$cv_line_no (corep, fnp, line, line_name, code); if code ^= 0 then call ioa_$rsnnl ("^o", line_name, (0), line); return (rtrim (line_name)); end chan_name; end; /* db_fnp_buffer_status_ */  db_fnp_call_trace_.pl1 11/15/82 1816.2rew 11/15/82 1501.4 121212 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_CALL_TRACE_ - A procedure to decode a subroutine calling chain in a FNP dump */ /* Written Spetember 1978 by Larry Johnson */ /* This module contains a great deal of imbedded knowledge about how the fnp procedure generate calls. It uses a set of heuristics to search backwards from a given starting point to find the object code generated by a 'subr' macro. */ /* The following is a detailed description of the subr sequence: . name ind 0 entry point, and return address word . * If 'inh' is used, the following is generated . sti namsi-* save current indicators . inh and mask interrupts . * Next, individual registers are saved. . * 0-6 register saves may follow here selected from (a,q,x1,x2,x3,i) . sta namsa-* . stx1 namsx1-* . stx3 namsx3-* . * Now branch to body of subroutine. . tra start-* . * For the conveniece of the return macro, the subroutine exit . * sequence is generated here. The return macro transfers . * to this point. . * First, reload all saved registers . lda namsa-* . ldx1 namsx1-* . ldx3 namsx3-* . ldi namsi-* . * And return. . tra name-*,* . * Someday, a subroutine name may be stored here, in bcd. This is not . * done now, but would appear as follows: . bci 6/name . * Next follows save area for all saved registers . namsi bss 1 . namsa bss 1 . namsx1 bss 1 . namsx3 bss 1 . * Next comes the body of the subroutine . start null */ db_fnp_call_trace_: proc (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); /* Parameters */ dcl arg_corep ptr; dcl arg_fnp fixed bin; dcl arg_cmd_infop ptr; dcl arg_expr_infop ptr; /* Automatic */ dcl i fixed bin; dcl code fixed bin (35); dcl corep ptr; dcl fnp fixed bin; dcl debug_sw bit (1); /* Set if -debug used */ dcl long_sw bit (1); /* Set if -long used */ dcl trace_addr fixed bin; dcl mem_buf (0:511) bit (18) unal; /* To hold memory data */ dcl buf_org fixed bin; /* Starting address of stuff in mem_buf */ dcl n_words_in_buf fixed bin; /* Count of good words */ /* Static */ dcl constants_setup bit (1) int static init ("0"b); /* Set when static initialized */ dcl ld_opcodes (6) bit (18) unal int static; /* Opcodes of load instruction */ dcl st_opcodes (6) bit (18) unal int static; /* Opcodes of store instructions */ dcl tra bit (18) int static; /* Opcode of tra instruction */ dcl inh bit (18) int static; /* Opcode of inhibit instruction */ /* Constants */ dcl name char (18) int static options (constant) init ("db_fnp_call_trace_"); dcl reg_names (6) char (2) int static options (constant) init ("i", "a", "q", "x1", "x2", "x3"); dcl opmask bit (18) int static options (constant) init ("077000"b3); /* External */ dcl ioa_ entry options (variable); dcl com_err_ entry options (variable); dcl db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_reader_$get_operand entry (ptr); dcl db_fnp_edit_inst_$assemble entry (ptr, fixed bin, char (*), ptr, bit (18), fixed bin (35)); dcl sub_err_ entry options (variable); dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl db_fnp_util_$edit_module_addr_paren entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35)); dcl (addr, bin, dim, hbound, max, min, null, string, unspec, substr) builtin; /* Copy arguments */ fnp = arg_fnp; corep = arg_corep; expr_infop = arg_expr_infop; cmd_infop = arg_cmd_infop; if ^constants_setup then call setup_constants; /* First argument is address to trace from */ call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; if cmd_info.endline then do; call ioa_ ("Address missing."); go to error_return; end; call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", trace_addr, code); if code ^= 0 then go to error_return; /* Remaining arguments are control arguments */ debug_sw, long_sw = "0"b; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; do while (^cmd_info.endline); if operand = "-long" | operand = "-lg" then long_sw = "1"b; else if operand = "-debug" | operand = "-db" then debug_sw = "1"b; else do; call ioa_ ("Unrecognized operand: ^a", operand); go to error_return; end; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; end; /* Now loop backwards decoding subroutine levels */ call trace_level; do while (trace_addr ^= 0); call trace_level; end; return; error_return: cmd_info.flush = "1"b; return; /* Procedure that does the real work of finding a subr */ trace_level: proc; dcl i fixed bin; dcl w bit (18); dcl tra_addr fixed bin; /* Address if the second tra instruction */ dcl ca fixed bin; /* Current address during scan */ dcl fb8 fixed bin (8) unal; /* For bit->fixed conversions */ dcl st_found (6) bit (1) unal; /* Mask saying which store instructions found */ dcl ld_found (6) bit (1) unal; /* Mask saying which load instructions found */ dcl ld_target (6) fixed bin; /* Targets of the ld instructuons */ dcl max_target fixed bin; dcl n_loads fixed bin; dcl target fixed bin; dcl msg char (64) var; dcl 1 mi unal, /* Machine instruction */ 2 i bit (1), /* Indirect bit */ 2 x bit (2), /* Index register */ 2 c bit (6), /* Opcode */ 2 d bit (9); /* Displacement */ /* Start with address given */ ca = trace_addr + 1; /* Look backwards for a tra instruction. It must have indirection, no index register, and a negative displacement. This the tra that returns from the subr. */ tra_scan: ca = ca - 1; w = get_word (ca); /* Read word */ if (w & opmask) ^= tra then go to tra_scan; string (mi) = w; if ^mi.i then go to tra_scan; /* No indirection */ if mi.x then go to tra_scan; /* Index present */ if ^substr (mi.d, 1, 1) then go to tra_scan; /* Displacement not negative */ tra_addr = ca; /* Save address of tra */ if debug_sw then call ioa_ ("Fould likely tra at ^a: ^.3b", ed (ca), w); /* The tra should be preceeded by 0-6 ldxx instructions. All should have no indirection, no index register, and an effective address greater than the tra */ string (st_found) = "0"b; string (ld_found) = "0"b; n_loads = 0; max_target = tra_addr; ldxx_scan: ca = ca - 1; w = get_word (ca); do i = 1 to hbound (ld_opcodes, 1); /* See if some kind of load */ if (w & opmask) = ld_opcodes (i) then do; /* Got it */ string (mi) = w; if mi.i | mi.x then do; /* These both should be zero */ ldxx_scan_fail: if debug_sw then call ioa_ ("ldxx scan failed at ^a: ^.3b", ed (ca), w); ca = tra_addr; /* Back to tra */ go to tra_scan; /* And go look for new likely tra */ end; if ld_found (i) then go to ldxx_scan_fail; /* Already had one of these */ unspec (fb8) = mi.d; /* Get signed displacement */ target = ca + fb8; /* Effective address */ if target <= tra_addr then go to ldxx_scan_fail; n_loads = n_loads + 1; /* This is good load */ ld_found (i) = "1"b; ld_target (i) = target; max_target = max (max_target, target); go to ldxx_scan; end; end; /* Found a non-ldx opcode. This should be the entry sequence tra to max_target */ if (w & opmask) ^= tra then go to ldxx_scan_fail; /* Not a tra */ string (mi) = w; /* To check other fields */ if mi.i | mi.x then go to ldxx_scan_fail; unspec (fb8) = mi.d; target = ca + fb8; /* Target of tra */ if n_loads > 0 then /* If there were loads, .. */ if target ^= (max_target + 1) then go to ldxx_scan_fail; /* Should point immiditely after save areas */ else; /* It does, ok */ else if target ^= max_target + 1 then /* No loads, target should be here */ if target ^= max_target + 3 then /* Or here, to allow for two word name someday */ go to ldxx_scan_fail; /* No good target */ /* The middle tra is good. Need to check preceeding stxx instructions */ stxx_scan: ca = ca - 1; w = get_word (ca); if string (st_found) = string (ld_found) then go to stxx_scan_done; /* All loads have been matched by stores */ do i = 1 to hbound (st_opcodes, 1); /* Look up in store list */ if (w & opmask) = st_opcodes (i) then do; /* A match */ string (mi) = w; /* For further analysis */ if mi.i | mi.x then do; /* Can't have these */ stxx_scan_fail: if debug_sw then call ioa_ ("stxx scan failed at ^a: ^.3b", ed (ca), w); ca = tra_addr; /* Back to tra scanning */ go to tra_scan; end; unspec (fb8) = mi.d; target = ca + fb8; /* Target of stxx */ if ^ld_found (i) then go to stxx_scan_fail; /* No corresponding ldxx instruction */ if ld_target (i) ^= target then go to stxx_scan_fail; /* Target must be same */ if st_found (i) then go to stxx_scan_fail; /* Duplicate */ st_found (i) = "1"b; go to stxx_scan; end; end; /* All stxx instructions have been scanned. The only possible discrepency left between loads and stores, is a missing sti, which will occur if 'inh' is used in subr */ if string (st_found) ^= string (ld_found) then do; /* There is discrepency */ if (string (st_found) | "100000"b) ^= string (ld_found) then go to stxx_scan_fail; /* Not just missing sti */ if w ^= inh then go to stxx_scan_fail; /* Expect inh instruction here */ ca = ca - 1; w = get_word (ca); if (w & opmask) ^= st_opcodes (1) then /* This better be missing sti */ go to stxx_scan_fail; /* No, too bad */ ca = ca - 1; w = get_word (ca); /* Read retrun address word */ end; stxx_scan_done: /* Scan is all done. current word is return address */ i = trace_addr; /* Hold starting addr */ trace_addr = 0; if w = "000000"b3 then msg = "never called"; else if w = "000001"b3 then do; msg = "called form master dispatcher"; ca = ca + 3; /* Space over dummy subr */ end; else if w = "000002"b3 then do; msg = "called from secondary dispatcher"; ca = ca + 3; end; else do; trace_addr = bin (w); /* For pervious level */ msg = "called from " || ed (trace_addr); end; call ioa_ ("^a in subr at ^a, ^a", ed (i), ed (ca), msg); if long_sw then do; do i = 1 to hbound (reg_names, 1); if ld_found (i) then call ioa_ ("^-^4a^.3b", reg_names (i), get_word (ld_target (i))); end; end; return; end trace_level; /* Procedure to manage internal memory buffer. If the word requested is in the buffer, it is returned. Otherwise, a new buffer is read with the current address near the end. This allows a small amount of forward scanning and a large amount of backeards scanning before more memory must be read */ get_word: proc (ad) returns (bit (18)); dcl ad fixed bin; if n_words_in_buf = 0 then do; /* Empty, must read */ read_new_buf: buf_org = (max (0, ad - (dim (mem_buf, 1) - 32))); if debug_sw then call ioa_ ("Reading memory locations ^o-^o", buf_org, buf_org + hbound (mem_buf, 1)); call db_fnp_memory_$fetch (corep, fnp, buf_org, dim (mem_buf, 1), addr (mem_buf), code); if code ^= 0 then do; call com_err_ (code, name, "Unable to read ^o-^o", buf_org, buf_org + hbound (mem_buf, 1)); go to error_return; end; n_words_in_buf = dim (mem_buf, 1); end; if ad < buf_org | ad > buf_org + n_words_in_buf - 1 then /* Not in current window */ go to read_new_buf; return (mem_buf (ad - buf_org)); end get_word; /* Prccodure to return edited module address */ ed: proc (ad) returns (char (32) var); dcl ad fixed bin; dcl temp char (32) var; call db_fnp_util_$edit_module_addr_paren (corep, fnp, ad, temp, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to edit ^o.", ad); go to error_return; end; return (temp); end ed; /* Compute some baseic needed for life of process */ setup_constants: proc; dcl i fixed bin; inh = opc ("inh"); /* Inhibit instruction */ tra = opc ("tra"); /* Tra instruction */ do i = 1 to hbound (reg_names, 1); st_opcodes (i) = opc ("st" || reg_names (i)); ld_opcodes (i) = opc ("ld" || reg_names (i)); end; constants_setup = "1"b; return; end setup_constants; opc: proc (opname) returns (bit (18)); dcl opname char (*); dcl inst bit (18); call db_fnp_edit_inst_$assemble (corep, fnp, opname, expr_infop, inst, code); /* "assemble" into instruction */ if code ^= 0 then call sub_err_ (code, name, "s", null, (0), "Unable to get opcode for ""^a"".", opname); return (inst); end opc; %include debug_fnp_data; end db_fnp_call_trace_;  db_fnp_convert_address_.pl1 11/15/82 1816.2rew 11/15/82 1501.5 51129 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_CONVERT_ADDRESS_ - Implements the convert_address (cva) command in debug_fnp */ /* This modules takes an expression and converts it to as many meaningful representations as possible */ /* Written August 1977 by Larry Johnson */ db_fnp_convert_address_: proc (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); /* Parameters */ dcl arg_corep ptr; dcl arg_fnp fixed bin; dcl arg_cmd_infop ptr; dcl arg_expr_infop ptr; /* Automatic */ dcl corep ptr; dcl fnp fixed bin; dcl val fixed bin; dcl code fixed bin (35); dcl bcode bit (36) aligned based (addr (code)); dcl work char (32) var; dcl printed_version (20) char (32) var; dcl n_printed fixed bin; dcl i fixed bin; dcl opname char (6); dcl orig_argp ptr; dcl orig_argl fixed bin; dcl orig_arg char (orig_argl) based (orig_argp); /* External */ dcl (ioa_, ioa_$nnl, ioa_$rsnnl) entry options (variable); dcl db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_util_$edit_module_addr entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35)); dcl db_fnp_edit_inst_$compressed entry (ptr, fixed bin, bit (18), char (*) var); dcl db_fnp_opblock_util_$get_name entry (bit (18), char (*)); dcl db_fnp_reader_$get_operand entry (ptr); dcl (addr, hbound, length, rtrim, substr) builtin; corep = arg_corep; /* Copy args */ fnp = arg_fnp; expr_infop = arg_expr_infop; cmd_infop = arg_cmd_infop; call db_fnp_reader_$get_operand (cmd_infop); /* Be sure one operand */ if cmd_info.error then go to error_return; if cmd_info.endline then do; call ioa_ ("Address missing"); go to error_return; end; /* Evaluate each operand in turn. */ do while (^cmd_info.endline); call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", val, code); /* Get value of arg */ if code ^= 0 then go to next_operand; orig_argp = addr (operand); orig_argl = length (operand); if substr (orig_arg, 1, 1) = "'" then do; /* Fudge apostrophed string */ orig_argl = orig_argl - 1; orig_argp = addr (substr (orig_arg, 2, 1)); if substr (orig_arg, orig_argl, 1) = "'" then orig_argl = orig_argl - 1; end; call ioa_$nnl ("""^a""", orig_arg); /* Print origional arg */ n_printed = 0; /* Try octal */ call ioa_$rsnnl ("^o", work, (0), val); call test_print; /* Special test for negative numbers */ code = val; if substr (bcode, 19, 1) then do; call ioa_$rsnnl ("^.3b", work, (0), substr (bcode, 19)); call test_print; end; /* Try module | offset */ call db_fnp_util_$edit_module_addr (corep, fnp, val, work, code); if code = 0 then if work ^= "" then call test_print; /* Try opblock name */ code = val; if substr (bcode, 19, 9) = "777"b3 then do; call db_fnp_opblock_util_$get_name (substr (bcode, 19, 18), opname); if opname ^= "" then do; work = rtrim (opname); call test_print; end; end; /* Try system defined symbols */ symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_); do i = 1 to symbol_table.cnt; symp = addr (symbol_table.entry (i)); if sym.reloc = reloc_abs then call check_sym (0); else if (sym.reloc = reloc_tib) & expr_info.tib_known then call check_sym (expr_info.tib_addr); else if (sym.reloc = reloc_hwcm) & expr_info.hwcm_known then call check_sym (expr_info.hwcm_addr); else if (sym.reloc = reloc_sfcm) & expr_info.sfcm_known then call check_sym (expr_info.sfcm_addr); end; if expr_info.star_known then if val = expr_info.star_addr then do; work = "*"; call test_print; end; /* Try decimal */ call ioa_$rsnnl ("^d.", work, (0), val); call test_print; /* Try machine instruction */ code = val; call db_fnp_edit_inst_$compressed (corep, fnp, substr (bcode, 19), work); if work ^= "" then call test_print; /* All done with operand */ call ioa_ (""); next_operand: call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; end; return; error_return: cmd_info.error = "1"b; return; /* Subroutine to decide whether expr is a valid symbol */ check_sym: proc (reloc); dcl reloc fixed bin; dcl (w1, w2) fixed bin; /* Range of words in symbol */ w1 = sym.value + reloc; w2 = w1 + sym.len -1; if val >= w1 & val <= w2 then do; /* Value within symbol */ if val = w1 then work = sym.name; else call ioa_$rsnnl ("^a+^o", work, (0), sym.name, val-w1); call test_print; end; return; end check_sym; /* Subrotuine that prints a converted value only if it is diffetent */ test_print: proc; dcl i fixed bin; if work = orig_arg then return; /* Same as origional */ do i = 1 to n_printed; /* Scan list already printed */ if work = printed_version (i) then return; end; call ioa_$nnl (" = ""^a""", work); /* Print new version */ if n_printed < hbound (printed_version, 1) then do; /* And save it */ n_printed = n_printed + 1; printed_version (n_printed) = work; end; return; end test_print; %include debug_fnp_data; end db_fnp_convert_address_;  db_fnp_disp_cmd_.pl1 11/15/82 1816.2rew 11/15/82 1501.7 157194 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_DISP_CMD_: Various entries to perform display type command for debug_fnp */ /* Extracted from main command, and added to, February 1978 by Larry Johnson */ /* Added set_flag and clear_flag commands October 1978 */ db_fnp_disp_cmd_: proc; /* Arguments */ dcl arg_corep ptr; dcl arg_fnp fixed bin; dcl arg_cmd_infop ptr; dcl arg_expr_infop ptr; /* Automatic */ dcl code fixed bin (35); dcl corep ptr; dcl fnp fixed bin; dcl unal_temp fixed bin (17) unal; dcl fnp_buf (0:2047) bit (18) unal; dcl flag_work bit (18); dcl flag_orig bit (18); dcl fnp_addr fixed bin; dcl fnp_len fixed bin; dcl expr_val fixed bin; dcl sw bit (1); dcl addr_sw bit (1); dcl first_sw bit (1); dcl found_sw bit (1); dcl (i, j) fixed bin; dcl mask bit (18); dcl temp_word bit (18); dcl flag_name char (6); dcl symno fixed bin; dcl nbits fixed bin; dcl disp_type fixed bin; dcl disp_len fixed bin; dcl type_sw bit (1); dcl length_sw bit (1); dcl brief_sw bit (1); dcl set_flag_sw bit (1); dcl based_char char (i) based; /* Internal static */ dcl next_buf_addr fixed bin int static init (0); /* Forward link from last buffer */ dcl next_block_addr fixed bin int static init (0); /* Forward link from last block */ dcl block_length fixed bin int static init (0); dcl block_offset fixed bin int static init (0); /* External */ dcl ioa_ entry options (variable); dcl ioa_$nnl entry options (variable); dcl db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_reader_$get_operand entry (ptr); dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl db_fnp_memory_$store entry (ptr, fixed bin, fixed bin, fixed bin, ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_display_ entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin, fixed bin (35)); dcl db_fnp_sym_util_$lookup entry (char (*), ptr); dcl com_err_ entry options (variable); dcl (addr, bin, copy, divide, hbound, index, lbound, length, mod, null, substr, unspec) builtin; /* Entry to display memory in various forms */ display: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call get_operand_req ("Address"); call cv_expr_op; fnp_addr = expr_val; disp_type = expr_info.type; disp_len = expr_info.len; length_sw = "0"b; /* Length not specified */ type_sw = "0"b; call get_operand; /* Look for more operands */ do while (^cmd_info.endline); if ^type_sw then do; call check_type; if type_sw then go to display_command2; end; if ^length_sw then do; call cv_length_op; disp_len = expr_val; length_sw = "1"b; end; else do; call ioa_ ("Invalid operand: ^a", operand); go to error_return; end; display_command2: call get_operand; end; if length_sw & ^type_sw then disp_type = type_oct; call fetch (fnp_addr, disp_len, addr (fnp_buf)); expr_info.star_addr = fnp_addr; /* Now safe to remember this address as "*" */ expr_info.star_known = "1"b; call db_fnp_display_ (corep, fnp, fnp_addr, disp_len, addr (fnp_buf), disp_type, code); if code ^= 0 then call com_err_ (code, "", "Unable to display memory."); return; /* Entry to patch memory */ patch: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call get_operand_req ("Address"); call cv_expr_op; fnp_addr = expr_val; patch_command2: fnp_len = 0; call get_operand_req ("Data word"); do while (^cmd_info.endline); if ^cmd_info.opstring then do; /* If not a quoted string */ if fnp_len >= 32 then do; long_patch: call ioa_ ("Too much data"); go to error_return; end; call cv_expr_op; code = expr_val; /* Move into full word area */ fnp_buf (fnp_len) = substr (unspec (code), 19, 18); fnp_len = fnp_len + 1; end; else do; /* Do a character patch */ i = length (operand); i = i + mod (i, 2); /* Round to full words */ if i = 0 then i = 2; if (fnp_len + divide (i, 2, 17, 0)) > 32 then go to long_patch; addr (fnp_buf (fnp_len)) -> based_char = operand; fnp_len = fnp_len + divide (i, 2, 17, 0); end; call get_operand; end; expr_info.star_addr = fnp_addr; /* Remember location as "*" */ expr_info.star_known = "1"b; call store (fnp_addr, fnp_len, addr (fnp_buf)); return; /* Entry to do the = command, equivalent to patch * */ equal: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; if ^expr_info.star_known then do; call ioa_ ("Value of ""*"" not known."); go to error_return; end; fnp_addr = expr_info.star_addr; go to patch_command2; /* Entries for dealing with buffers */ buffer: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call parse_buffer_command; call display_buffer; return; buffer_chain: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call parse_buffer_command; call display_buffer; do while (next_buf_addr ^= 0); call ioa_ (""); call display_buffer; end; return; /* Entries for dealing with blocks chained together */ block: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call parse_block_command; call display_block; return; block_chain: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call parse_block_command; call display_block; do while (next_block_addr ^= 0); call ioa_ (""); call display_block; end; return; forget: entry; next_buf_addr, next_block_addr, block_offset = 0; block_length = 8; return; /* Procudure to parse commands like buffer and buffer_chain */ parse_buffer_command: proc; dcl got_addr bit (1) init ("0"b); type_sw = "0"b; disp_type = type_char; brief_sw = "0"b; call get_operand; do while (^cmd_info.endline); if operand = "brief" | operand = "bf" | operand = "-brief" | operand = "-bf" then do; brief_sw = "1"b; go to next_buffer_operand; end; if ^type_sw then do; call check_type; if type_sw then go to next_buffer_operand; /* Valid type */ end; if ^got_addr then do; call cv_expr_op; next_buf_addr = expr_val; got_addr = "1"b; end; else do; call ioa_ ("Unrecognized operand: ^a", operand); go to error_return; end; next_buffer_operand: call get_operand; end; if ^got_addr then if next_buf_addr = 0 then do; call ioa_ ("No next buffer"); go to error_return; end; return; end parse_buffer_command; /* Procedure to fetch and display a buffer */ display_buffer: proc; dcl i fixed bin; dcl nwords fixed bin; if (next_buf_addr = 0) | (mod (next_buf_addr, 32) ^= 0) then do; /* Boundary is wrong */ call ioa_ ("Invalid buffer address: ^o", next_buf_addr); go to error_return; end; call fetch (next_buf_addr, 2, addr (fnp_buf)); /* Read header */ if brief_sw then nwords = 2; /* If brief, thats all */ else do; nwords = 32 * (bin (substr (fnp_buf (1), 1, 3)) + 1); /* Calc word count of buffer */ call fetch (next_buf_addr + 2, nwords - 2, addr (fnp_buf (2))); /* Read rest of buffer */ end; expr_info.star_addr = next_buf_addr; expr_info.star_known = "1"b; i = next_buf_addr; next_buf_addr = bin (fnp_buf (0)); call db_fnp_display_ (corep, fnp, i, nwords, addr (fnp_buf), disp_type, code); if code ^= 0 then do; call com_err_ (code, "", "Unable to display memory."); go to error_return; end; return; end display_buffer; /* Procedure to parse command lines for block and block_chain commands */ parse_block_command: proc; dcl new_block_addr fixed bin; dcl new_block_length fixed bin; dcl new_block_offset fixed bin; dcl got_addr bit (1); call get_operand; if cmd_info.endline then do; if next_block_addr = 0 then do; call ioa_ ("No block address."); go to error_return; end; else return; end; new_block_offset = 0; new_block_length = 8; new_block_addr = next_block_addr; got_addr = "0"b; do while (^cmd_info.endline); if operand = "-offset" | operand = "-o" then do; call get_operand_req ("Offset"); call cv_expr_op; if expr_val < 0 | expr_val > 2044 then do; call ioa_ ("Invalid offset: ^a", operand); go to error_return; end; new_block_offset = expr_val; end; else if operand = "-length" | operand = "-l" then do; call get_operand_req ("Length"); call cv_length_op; new_block_length = expr_val; end; else if ^got_addr then do; call cv_expr_op; new_block_addr = expr_val; got_addr = "1"b; end; else do; call ioa_ ("Unrecognized operand: ^a", operand); go to error_return; end; call get_operand; end; if new_block_offset >= new_block_length then do; call ioa_ ("Offset greater than block length"); go to error_return; end; if new_block_addr = 0 then do; call ioa_ ("No block address"); go to error_return; end; next_block_addr = new_block_addr; block_length = new_block_length; block_offset = new_block_offset; return; end parse_block_command; /* Procedure to display a block for block and block chain commands */ display_block: proc; dcl i fixed bin; if next_block_addr = 0 then do; call ioa_ ("No next block address"); go to error_return; end; call fetch (next_block_addr, block_length, addr (fnp_buf)); expr_info.star_addr = next_block_addr; expr_info.star_known = "1"b; i = next_block_addr; next_block_addr = bin (fnp_buf (block_offset)); call db_fnp_display_ (corep, fnp, i, block_length, addr (fnp_buf), type_oct, code); if code ^= 0 then do; call com_err_ (code, "", "Unable to display memory"); go to error_return; end; return; end display_block; /* Entry to display a word by interpreting its flags */ flags: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call get_operand_req ("address"); /* Need address to decode */ if substr (operand, 1, 1) = "=" then do; /* A literal, no memory reference needed */ call db_fnp_eval_ (corep, fnp, substr (operand, 2), expr_infop, "", expr_val, code); if code ^= 0 then go to error_return; unal_temp = expr_val; /* Need unaligned version for unspec */ flag_orig = unspec (unal_temp); flag_name = ""; addr_sw = "0"b; end; else do; /* Must read data from memory */ call cv_expr_op; call fetch (expr_val, 1, addr (fnp_buf)); /* Get word */ flag_orig = fnp_buf (0); flag_name = operand; /* Flag type defaults to first operand */ if flag_name ^= operand then flag_name = ""; /* Unless too long */ addr_sw = "1"b; /* Have address to print */ fnp_addr = expr_val; end; call get_operand; /* Type of flag decoding to do */ if ^cmd_info.endline then flag_name = operand; if flag_name = "" then do; call ioa_ ("No flag type specified"); go to error_return; end; symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_); found_sw, first_sw = "0"b; flag_work = flag_orig; /* Starting value of word */ do symno = 1 to symbol_table.cnt; /* Scan entire symbol table */ symp = addr (symbol_table.entry (symno)); if sym.flag_mem = flag_name then do; /* Symbol defines a flag in this kind of word */ found_sw = "1"b; if ^first_sw then do; /* Print start of line */ call ioa_$nnl ("^[^5o ^;^s^]^.3b", addr_sw, fnp_addr, flag_orig); first_sw = "1"b; end; temp_word = unspec (sym.value); /* Copy value of symbol */ i = index (temp_word, "1"b); /* Find first 1 bit */ if i = 0 then go to check_next_sym; /* All zero value useless here */ substr (temp_word, i, 1) = "0"b; /* Turn off first bit */ if temp_word then do; /* Symbol is a multiple bit symbol */ nbits = 1; do j = i+1 to 18 while (temp_word); /* First, count the bits */ substr (temp_word, j, 1) = "0"b; nbits = nbits + 1; end; mask = unspec (sym.value); temp_word = flag_orig & mask; /* Isolate origional value of symbol */ if sym.type = type_oct then call ioa_$nnl (" ^a=^.3b", sym.name, copy ("0"b, mod (3 - mod (nbits, 3), 3)) || substr (temp_word, i, nbits)); else call ioa_$nnl (" ^a=^b", sym.name, substr (temp_word, i, nbits)); flag_work = flag_work & ^mask; /* These bits have been explained */ end; else do; /* Simpler case, flag is a single bit */ temp_word = unspec (sym.value); if temp_word & flag_work then do; /* Bit is on */ call ioa_$nnl (" ^a", sym.name); sw = "0"b; do i = symno+1 to symbol_table.cnt; /* Scan rest of table for synonyms */ symp = addr (symbol_table.entry (i)); if (unspec (sym.value) = temp_word) & (sym.flag_mem = flag_name) then do; /* Got one */ call ioa_$nnl (" ^[^;(^]^a", sw, sym.name); sw = "1"b; end; end; if sw then call ioa_$nnl (")"); /* Close list of synonyms */ end; flag_work = flag_work & ^temp_word; /* Flag is identified */ end; end; check_next_sym: end; if ^found_sw then do; call ioa_ ("No flags found in symbol_table for ^a", flag_name); go to error_return; end; if addr_sw then do; expr_info.star_addr = fnp_addr; expr_info.star_known = "1"b; /* Remember flag addres as "*" */ end; if ^first_sw then call ioa_ ("^[^5o ^;^s^]^.3b", addr_sw, fnp_addr, flag_orig); else call ioa_ (""); if flag_work then call ioa_ ("No flags defined for ^.3b", flag_work); return; /* Commands for setting and clearing flags */ set_flag: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); set_flag_sw = "1"b; go to join_clear_flag; clear_flag: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); set_flag_sw = "0"b; join_clear_flag: call setup; call get_operand_req ("Flag"); call db_fnp_sym_util_$lookup (operand, symp); if symp = null () then do; call ioa_ ("Undefined symbol: ^a", operand); go to error_return; end; if sym.flag_mem = "" then do; call ioa_ ("Symbol is not a flag: ^a", operand); go to error_return; end; call db_fnp_eval_ (corep, fnp, sym.flag_mem, expr_infop, "", expr_val, code); if code ^= 0 then go to error_return; call fetch (expr_val, 1, addr (fnp_buf)); /* Read old word value */ expr_info.star_addr = expr_val; expr_info.star_known = "1"b; if set_flag_sw then fnp_buf (0) = fnp_buf (0) | unspec (sym.value); else fnp_buf (0) = fnp_buf (0) & ^unspec (sym.value); call store (expr_val, 1, addr (fnp_buf)); return; error_return: cmd_info.flush = "1"b; return; /* Procedure to extract 1 operand from the command line */ get_operand: proc; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; return; end get_operand; get_operand_req: proc (s); dcl s char (*); call get_operand; if cmd_info.endline then do; call ioa_ ("^a missing.", s); go to error_return; end; else return; end get_operand_req; /* Procedure to convert an operand intended to be a length */ cv_length_op: proc; call cv_expr_op; if (expr_val < 1) | (expr_val > 2044) then do; call ioa_ ("Invalid length: ^a", operand); go to error_return; end; return; end cv_length_op; /* Procedure called when operand is an expression */ cv_expr_op: proc; call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", expr_val, code); if code ^= 0 then go to error_return; else return; end cv_expr_op; /* Read some fnp words */ fetch: proc (a, l, p); dcl a fixed bin; /* Address to read */ dcl l fixed bin; /* Length to read */ dcl p ptr; /* Where to put it */ call db_fnp_memory_$fetch (corep, fnp, a, l, p, code); if code ^= 0 then do; call com_err_ (code, "", "Unable to read fnp memory."); go to error_return; end; else return; store: entry (a, l, p); call db_fnp_memory_$store (corep, fnp, a, l, p, "", 2, code); if code ^= 0 then do; call com_err_ (code, "", "Unable to patch memory"); go to error_return; end; end fetch; /* Setup arguments */ setup: proc; corep = arg_corep; fnp = arg_fnp; cmd_infop = arg_cmd_infop; expr_infop = arg_expr_infop; return; end setup; /* Procedure to check operand for valid display type */ check_type: proc; dcl i fixed bin; do i = lbound (long_type_names, 1) to hbound (long_type_names, 1); if operand = short_type_names (i) | operand = long_type_names (i) | operand = "-" || short_type_names (i) | operand = "-" || long_type_names (i) then do; type_sw = "1"b; disp_type = i; return; end; end; return; end check_type; %include debug_fnp_data; end db_fnp_disp_cmd_;  db_fnp_display_.pl1 11/15/82 1816.2rew 11/15/82 1501.7 63189 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Procedure for displaying contents of fnp memory in various formats */ /* Written February 1977 by Larry Johnson */ db_fnp_display_: proc (arg_corep, arg_fnp, arg_fnp_addr, arg_fnp_len, arg_data_ptr, arg_type, arg_code); /* Arguments */ dcl arg_corep ptr; /* Pointer to core image */ dcl arg_fnp fixed bin; /* Number of running fnp */ dcl arg_fnp_addr fixed bin; /* Fnp addr being displayed */ dcl arg_fnp_len fixed bin; /* The number of wrds */ dcl arg_data_ptr ptr; /* Multics pointer to the data */ dcl arg_type fixed bin; /* The editing mode to perform */ dcl arg_code fixed bin (35); /* Automatic */ dcl fnp_addr fixed bin; dcl fnp_len fixed bin; dcl data_ptr ptr; dcl type fixed bin; dcl code fixed bin (35); dcl bcode bit (36) aligned based (addr (code)); dcl part_len fixed bin; /* Length of memory being displayed on 1 line */ dcl part_ptr ptr; /* A pointer to it */ dcl words_per_line fixed bin; /* The number of words on a line */ dcl next_word fixed bin; dcl words_left fixed bin; dcl char_str char (64) var; dcl dt_val fixed bin (71); /* For date_time_ */ dcl dt_str char (24); dcl ebcdic_sw bit (1) init ("0"b); dcl last_part bit (144); /* Contents of last line, to supress dups */ dcl suppress bit (1); /* Last line was not printed */ dcl suppress_addr fixed bin; /* Addr of last line not printed */ dcl check_dup bit (1); /* Try duplicate line suppression */ dcl fnp_mem (fnp_len) bit (18) unal based (data_ptr); /* All of memory being displayed */ dcl part_mem (part_len) bit (18) unal based (part_ptr); /* What will fit on a line */ dcl ch_part_mem char (2*part_len) based (part_ptr); /* External */ dcl ioa_ entry options (variable); dcl ioa_$nnl entry options (variable); dcl db_fnp_util_$edit_module_addr entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl db_fnp_opblock_util_$display entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl db_fnp_edit_inst_ entry (ptr, fixed bin, fixed bin, bit (18), char (*) var); dcl ebcdic_to_ascii_ entry (char (*), char (*)); dcl (addr, bin, length, min, substr, unspec) builtin; /* Initialization */ fnp_addr = arg_fnp_addr; /* Cpy args */ fnp_len = arg_fnp_len; data_ptr = arg_data_ptr; type = arg_type; if type = type_op then do; /* Dont handle this one here */ call db_fnp_opblock_util_$display (arg_corep, arg_fnp, fnp_addr, fnp_len, data_ptr, arg_code); return; end; if type = type_clock then words_per_line = min (4, fnp_len); else if type = type_addr then words_per_line = 1; else if type = type_inst then words_per_line = 1; else if type = type_dec then words_per_line = 1; else if type = type_bit then words_per_line = 1; else words_per_line = min (8, fnp_len); check_dup = (words_per_line = 8); suppress = "0"b; next_word = 1; /* First word to display */ words_left = fnp_len; /* Words yet to do */ do while (words_left > 0); /* Loop until done */ part_len = min (words_per_line, words_left); /* Number of words on this line */ part_ptr = addr (fnp_mem (next_word)); if check_dup & (next_word > 1) then do; /* Check for duplicate lines */ if unspec (part_mem) = last_part then do; /* Same as previous */ suppress = "1"b; suppress_addr = fnp_addr; /* Last line not printed */ go to next_line; end; else if suppress then do; /* End of duplicate range */ call ioa_ ("^5w =", suppress_addr); suppress = "0"b; end; end; if type = type_inst then do; /* Special form for instruction */ call db_fnp_util_$edit_module_addr (arg_corep, arg_fnp, fnp_addr, char_str, code); if code ^= 0 then char_str = ""; call ioa_$nnl ("^5w ^13a ^( ^.3b^)", fnp_addr, char_str, part_mem); end; else call ioa_$nnl ("^5w ^( ^.3b^)", fnp_addr, part_mem); go to display_edit (type); /* Finish up, based on type */ display_edit (0): /* Octal */ call ioa_ (""); go to next_line; display_edit (1): /* Character */ call setup_chars; call ioa_ ("^v(^7x^) ^a", words_per_line - part_len, char_str); go to next_line; display_edit (2): /* Address */ call db_fnp_util_$edit_module_addr (arg_corep, arg_fnp, bin (part_mem (1)), char_str, code); call ioa_ ("^[ ^a^]", (code = 0), char_str); go to next_line; display_edit (3): /* Clock reading */ unspec (dt_val) = unspec (part_mem); call date_time_ (dt_val, dt_str); call ioa_ (" ^a", dt_str); go to next_line; display_edit (4): /* Machine instruction */ call db_fnp_edit_inst_ (arg_corep, arg_fnp, fnp_addr, part_mem (1), char_str); call ioa_ (" ^a", char_str); go to next_line; display_edit (6): /* Decimal */ bcode = "0"b; substr (bcode, 19, 18) = part_mem (1); if substr (part_mem (1), 1, 1) then substr (bcode, 1, 18) = "777777"b3; call ioa_ (" ^d.", code); go to next_line; display_edit (7): call ioa_ (" ^b", part_mem (1)); go to next_line; display_edit (8): /* Ebcdic */ ebcdic_sw = "1"b; go to display_edit (1); next_line: /* Advance indexes for next line */ if check_dup then last_part = unspec (part_mem); /* Save to compare to next line */ fnp_addr = fnp_addr + part_len; next_word = next_word + part_len; words_left = words_left - part_len; end; if suppress then call ioa_ ("^5w =", suppress_addr); /* Last line was not printed */ arg_code = 0; return; /* Procedure to stup for charactr fisplay. non-graphics are replaced with dots */ setup_chars: proc; dcl i fixed bin; dcl (ebc_in, ebc_out) char (16); if ebcdic_sw then do; /* Must convert to ascii */ unspec (ebc_in) = "0"b; substr (ebc_in, 1, length (ch_part_mem)) = ch_part_mem; do i = 1 to length (ch_part_mem); unspec (substr (ebc_in, i, 1)) = unspec (substr (ebc_in, i, 1)) & "377"b3; end; call ebcdic_to_ascii_ (ebc_in, ebc_out); char_str = substr (ebc_out, 1, length (ch_part_mem)); end; else char_str = ch_part_mem; do i = 1 to length (char_str); unspec (substr (char_str, i, 1)) = unspec (substr (char_str, i, 1)) & "177"b3; if unspec (substr (char_str, i, 1)) < "040"b3 | unspec (substr (char_str, i, 1)) > "176"b3 then substr (char_str, i, 1) = "."; end; return; end setup_chars; %include debug_fnp_data; end db_fnp_display_;  db_fnp_dumps_.pl1 11/15/82 1816.2rew 11/15/82 1501.8 60156 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_DUMPS_ - Contains entries used by debug_fnp for finding various things in FNP dumps */ /* Written February 1977 by Larry Johnson */ /* format: style4,delnl,insnl,^ifthendo */ db_fnp_dumps_: proc; /* Arguments */ dcl arg_corep ptr; /* Address of the dump */ dcl arg_fnp fixed bin; dcl arg_cmd_infop ptr; dcl arg_expr_infop ptr; /* Automatic */ dcl corep ptr; dcl fnp fixed bin; dcl code fixed bin (35); dcl edited_addr char (24) var; dcl mem_word (1) bit (18) unal; dcl modnum fixed bin; dcl modname char (12); dcl i fixed bin; dcl rp ptr; dcl edit_ind char (128) var; dcl 1 fault_data unal, /* Format of fault data in dump */ 2 ic bit (18), 2 ir, 3 indicators bit (8), 3 pad bit (10), 2 a bit (18), 2 q bit (18), 2 x1 bit (18), 2 x2 bit (18), 2 x3 bit (18), 2 er bit (18), 2 et bit (18), 2 type fixed bin (17), 2 name bit (18); dcl 1 die_word unal, 2 modnum bit (4), 2 opcode bit (5), 2 reason bit (9); dcl msg_offset (1) bit (18) aligned based; /* Table of offsets in od355_msgs$ */ /* Constants */ dcl fault_names (0:10) char (16) int static options (constant) init ("power off", "power on", "memory parity", "illegal opcode", "overflow", "store", "divide", "illegal int", "extra int", "iom", "console abort"); dcl indicator_names (8) char (20) var int static options (constant) init ("zero", "negative", "carry", "overflow", "interrupt inhibit", "parity inhibit", "overflow inhibit", "parity"); dcl die_op bit (5) int static options (constant) init ("01001"b); /* Opcode used to cause crashes */ /* Static */ dcl constants_setup bit (1) int static init ("0"b); dcl crreg fixed bin int static; /* Address of saved machine conditions */ /* External stuff */ dcl ioa_ entry options (variable); dcl db_fnp_util_$edit_module_addr entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35)); dcl db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin); dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl com_err_ entry options (variable); dcl od355_msgs$ ext; dcl 1 od355_msgs$die_list (8) ext aligned, 2 name char (12), 2 offset fixed bin; dcl (addr, bin, length, ptr, string, substr) builtin; /* Entry to print reason for crash */ why: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call read_fault_data; if fault_data.ic = "0"b then do; call ioa_ ("No fault occurred."); return; end; call edit (fault_data.ic); if fault_data.type >= lbound (fault_names, 1) & fault_data.type <= hbound (fault_names, 1) then call ioa_ ("^a fault at ^o ^a", fault_names (fault_data.type), bin (fault_data.ic), edited_addr); else call ioa_ ("Unknown fault (type ^o) at ^o ^a", fault_data.type, bin (fault_data.ic), edited_addr); if fault_data.type ^= 3 then return; /* Not illegal opcode */ call fetch (bin (fault_data.ic) - 1, 1, addr (mem_word)); /* Read opcode causing the fault */ string (die_word) = mem_word (1); if die_word.opcode ^= die_op then return; /* Not deliberate */ modnum = bin (die_word.modnum); modname = od355_msgs$die_list.name (modnum); /* Name of module causing fault */ rp = ptr (addr (od355_msgs$), od355_msgs$die_list.offset (modnum)); /* Address of list of offsets to reasons */ rp = ptr (addr (od355_msgs$), rp -> msg_offset (bin (die_word.reason))); call ioa_ ("^a: ^A", modname, rp); return; /* Entry to print registers */ regs: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call read_fault_data; call edit (fault_data.ic); call ioa_ ("ic ^.3b ^a", fault_data.ic, edited_addr); call ioa_ ("aq ^.3b ^.3b", fault_data.a, fault_data.q); edit_ind = ""; if fault_data.ir.indicators ^= "0"b then do; do i = 1 to 8; if substr (fault_data.ir.indicators, i, 1) then do; /* Found one one */ if length (edit_ind) = 0 then edit_ind = "("; else edit_ind = edit_ind || ","; edit_ind = edit_ind || indicator_names (i); end; end; edit_ind = edit_ind || ")"; end; call ioa_ ("ir ^.3b ^a", string (fault_data.ir), edit_ind); call edit (fault_data.x1); call ioa_ ("x1 ^.3b ^a", fault_data.x1, edited_addr); call edit (fault_data.x2); call ioa_ ("x2 ^.3b ^a", fault_data.x2, edited_addr); call edit (fault_data.x3); call ioa_ ("x3 ^.3b ^a", fault_data.x3, edited_addr); call ioa_ ("er ^.3b", fault_data.er); call ioa_ ("et ^.3b", fault_data.et); return; /* Procedure to edit an address */ edit: proc (b); dcl b bit (18); dcl i fixed bin; dcl s char (32) var; i = bin (substr (b, 4)); call db_fnp_util_$edit_module_addr (corep, fnp, i, s, code); if code ^= 0 then s = ""; if s = "" then edited_addr = ""; else edited_addr = "(" || s || ")"; return; end edit; /* Setup arguments */ setup: proc; corep = arg_corep; fnp = arg_fnp; cmd_infop = arg_cmd_infop; expr_infop = arg_expr_infop; envp = cmd_info.envp; if ^env.dump_sw /* this is pointless without a dump */ then do; call com_err_ (0, "debug_fnp", "not looking at a dump."); go to error_return; end; if constants_setup then return; crreg = db_fnp_sym_util_$get_value (".crreg"); constants_setup = "1"b; return; end setup; /* Procedure to fetch the fault data */ read_fault_data: proc; dcl i fixed bin; dcl mem_word (1) bit (18); call fetch (crreg, 1, addr (mem_word)); /* Get pointer to register save area */ i = divide (length (unspec (fault_data)), 18, 17, 0); /* Number of words to read */ call fetch (bin (mem_word (1)), i, addr (fault_data)); return; end read_fault_data; /* Read some FNP memory */ fetch: proc (a, n, p); dcl (a, n) fixed bin; dcl p ptr; call db_fnp_memory_$fetch (corep, fnp, a, n, p, code); if code = 0 then return; call com_err_ (code, "", "Unable to read location ^o.", a); go to error_return; end fetch; error_return: cmd_info.flush = "1"b; return; %include debug_fnp_data; end db_fnp_dumps_;  db_fnp_edit_inst_.pl1 11/15/82 1816.2rew 11/15/82 1501.9 81549 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Procedure to interpret fnp machine instructions */ /* Written February 1977 by Larry Johnson */ /* Modified January 1978 by Larry Johnson for assemble entry */ db_fnp_edit_inst_: proc (arg_corep, arg_fnp, arg_fnp_addr, arg_instr, arg_str); /* Parameters */ dcl arg_corep ptr; /* Pointer to core image, if dump */ dcl arg_fnp fixed bin; /* Fnp number, for running fnp */ dcl arg_instr bit (18); /* Instruction to edit */ dcl arg_str char (*) var; /* The output string */ dcl arg_asm_str char (*); /* The string to assemble */ dcl arg_expr_infop ptr; dcl arg_code fixed bin (35); dcl arg_fnp_addr fixed bin; /* Automatic */ dcl fnp fixed bin; dcl corep ptr; dcl str char (64) var; dcl instruction bit (18) aligned; dcl opc bit (12) aligned; dcl (i, j) fixed bin; dcl offset fixed bin; dcl width fixed bin init (7); /* Width to edit opcode field */ dcl code fixed bin (35); dcl val fixed bin (35); dcl temp_str char (4); dcl char_addr_val bit (3); dcl edited_addr char (32) var; dcl fnp_addr_known bit (1); dcl 1 mi aligned based (addr (instruction)), 2 i bit (1) unal, /* Indirect bit */ 2 x bit (2) unal, /* Index register */ 2 c bit (6) unal, /* The opcode (normally) */ 2 d bit (9) unal; /* The displacement */ /* Constants */ dcl reg_name (3) char (1) int static options (constant) init ("1", "2", "3"); dcl char_addr (0:7) char (3) int static options (constant) init ( "w.1", "w.2", "b.0", "b.1", "c.0", "c.1", "c.2", "idl"); dcl reg_code (10) char (2) int static options (constant) init ( "*", "1*", "2*", "3*", "*1", "*2", "*3", "1", "2", "3"); dcl reg_val (10) bit (3) unal int static options (constant) init ( "100"b, "101"b, "110"b, "111"b, "101"b, "110"b, "111"b, "001"b, "010"b, "011"b); dcl white_space char (2) int static options (constant) init (" "); /* Space and tab */ /* External stuff */ dcl ioa_$rsnnl entry options (variable); dcl db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_util_$edit_module_addr_paren entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35)); dcl error_table_$bad_arg ext fixed bin (35); dcl (addr, bin, bit, copy, index, length, ltrim, reverse, rtrim, search, substr, unspec) builtin; /* Edit an instruction */ fnp_addr_known = "1"b; start: instruction = arg_instr; str = ""; opc = substr (instruction, 1, 12); optablep = addr (db_fnp_opcodes_$); do i = 1 to optable.cnt; /* Find instruction in table */ opp = addr (optable.entry (i)); if (opc & op.mask) = op.code then go to op_edit (op.type); end; arg_str = ""; return; /* Type 0 - storage reference instruction */ op_edit (0): if mi.x = "0"b then offset = fb (mi.d); /* 9 bit displacement for ic modified instructions */ else do; /* Offset depends in type of character addressing */ i = bin (substr (mi.d, 1, 3)); /* Get char addr code */ if i < 2 | i > 6 then offset = fb (mi.d); /* If invalid, use 9 bits */ else offset = fb (substr (mi.d, 4, 6)); /* Else use 6 bits */ end; call ioa_$rsnnl ("^va ^o", str, (0), width, op.name, offset); if mi.x = "0"b then do; /* IC modifier */ if mi.i then str = str || ",*"; if fnp_addr_known then do; /* Evaluate address */ call db_fnp_util_$edit_module_addr_paren (arg_corep, arg_fnp, arg_fnp_addr + offset, edited_addr, code); if code = 0 then do; str = str || copy (" ", 15 - length (str)); /* Increase to 15 characters */ str = str || edited_addr; end; end; end; else do; /* Index register modifier */ str = str || ","; str = str || reg_name (bin (mi.x)); if mi.i then str = str || "*"; i = bin (substr (mi.d, 1, 3)); /* Get byte address */ if i >= 2 & i <= 6 then do; /* Valid one */ str = str || ","; str = str || char_addr (i); end; end; go to op_done; /* Type 1 - immediate instructions */ op_edit (1): call ioa_$rsnnl ("^va ^o", str, (0), width, op.name, fb (mi.d)); go to op_done; /* Type 2 - iacxn instruction */ op_edit (2): call ioa_$rsnnl ("^va ^o", str, (0), width, op.name, fb (substr (mi.d, 4, 6))); if substr (mi.d, 1, 3) ^= "0"b then do; str = str || ","; str = str || char_addr (bin (substr (mi.d, 1, 3))); end; go to op_done; /* Type 3 - shifts */ op_edit (3): call ioa_$rsnnl ("^va ^o", str, (0), width, op.name, bin (substr (mi.d, 4, 6))); go to op_done; /* Type 4 - no operands */ op_edit (4): str = rtrim (op.name); go to op_done; /* All done */ op_done: arg_str = str; return; /* Entry which returns a compressed version */ compressed: entry (arg_corep, arg_fnp, arg_instr, arg_str); width = 1; fnp_addr_known = "0"b; go to start; /* Entry to "assemble" a character string into a machine instruction word */ assemble: entry (arg_corep, arg_fnp, arg_asm_str, arg_expr_infop, arg_instr, arg_code); corep = arg_corep; fnp = arg_fnp; expr_infop = arg_expr_infop; arg_code = 0; arg_instr = "0"b; instruction = "0"b; str = rtrim (ltrim (arg_asm_str, white_space), white_space); /* Trim down input */ i = search (str, white_space); /* Look for space after opcode */ if i = 0 then i = length (str); else i = i-1; optablep = addr (db_fnp_opcodes_$); do j = 1 to optable.cnt; opp = addr (optable.entry (j)); if op.name = substr (str, 1, i) then go to op_found; /* Found opcode match */ end; asm_bad: arg_code = error_table_$bad_arg; return; op_found: instruction = op.code; /* Start instruction with opcode */ if i >= length (str) then go to asm_complete; /* No operands */ str = ltrim (substr (str, i+1), white_space); if str = "" then go to asm_complete; go to asm (op.type); /* Complete instruction based on type */ asm (0): /* Storage reference */ call get_char_addr; /* Remove char addressing */ if length (str) >= 2 then do; /* May have index register */ i = index (reverse (str), ","); /* Look for comma before index */ if (i = 2) | (i = 3) then do; /* May really be there */ temp_str = substr (str, length (str) - i + 2); /* Copy end of string */ do j = 1 to 10; /* Check possible codes */ if temp_str = reg_code (j) then do; /* Found match */ mi.i = substr (reg_val (j), 1, 1); mi.x = substr (reg_val (j), 2, 2); str = substr (str, 1, length (str) - i); /* Trim off index */ go to eval_disp; end; end; go to asm_bad; end; end; eval_disp: call eval_str; /* Evaluate rest of string as expression */ if char_addr_val = "0"b then mi.d = substr (unspec (val), 28); /* 9 bit displacement */ else do; substr (mi.d, 1, 3) = char_addr_val; substr (mi.d, 4, 6) = substr (unspec (val), 31); /* 6 bit displacement */ end; go to asm_complete; asm (1): /* Immediate instructions */ call eval_str; /* Whole expr is amount */ mi.d = substr (unspec (val), 28); go to asm_complete; asm (2): /* Iacxn */ call get_char_addr; go to eval_disp; /* Rest is like storage reference */ asm (3): /* Shifts */ call eval_str; substr (mi.d, 4, 6) = substr (unspec (val), 31); /* 6 bit disp */ go to asm_complete; asm (4): /* No operand instruction */ go to asm_bad; /* Operand is error */ asm_complete: arg_instr = instruction; arg_code = 0; return; /* Fixed of bit function which respects the leading sign bit */ fb: proc (bits) returns (fixed bin); dcl bits bit (*); dcl i fixed bin (35); if substr (bits, 1, 1) = "0"b then i = 0; else i = -1; substr (unspec (i), 37 - length (bits)) = bits; return (i); end fb; /* Remove character addressing from instruction specification */ get_char_addr: proc; dcl i fixed bin; char_addr_val = "0"b; if length (str) < 4 then return; /* Too short */ if substr (str, length (str) - 3, 1) ^= "," then return; /* Should be of form ,xxx */ temp_str = substr (str, length (str)-2); /* Copy the xxx part */ do i = 2 to 6; /* Check legal forms */ if temp_str = char_addr (i) then do; char_addr_val = bit (bin (i, 3), 3); str = substr (str, 1, length (str)-4); return; end; end; return; end get_char_addr; /* Evaluate operand of instruction */ eval_str: proc; dcl i fixed bin; val = 0; if str = "" then return; call db_fnp_eval_ (corep, fnp, (str), expr_infop, "", i, code); if code ^= 0 then go to asm_bad; val = i; return; end eval_str; %include debug_fnp_data; end db_fnp_edit_inst_;  db_fnp_env_.pl1 06/01/84 1547.1r w 06/01/84 1427.8 283842 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_ENV_ - Contains entries used by debug_fnp to maintain its environment. The selecting of dumps, core images, and live FNP's, and the switching between them is all done here */ /* Created September 1978 by Larry Johnson, mostly from other modules, to centralize all this code */ /* Modified July 1979 by Larry Johnson to handle empty dumps better, and to add -login_channel to line command */ /* Modified August 1979 by Larry Johnson to automatically select the channel causing a dump */ /* Modified 83-12-23 BIM for new config cards */ db_fnp_env_: proc; /* Arguments */ dcl arg_corep ptr; /* Address of the dump */ dcl arg_fnp fixed bin; dcl arg_cmd_infop ptr; dcl arg_expr_infop ptr; dcl arg_envp ptr; /* Automatic */ dcl code fixed bin (35); dcl i fixed bin; dcl dir char (168); dcl ename char (32); dcl dnx fixed bin; dcl segp ptr; dcl p ptr; dcl fnp fixed bin; dcl tag char (1); dcl areap ptr; dcl tty_name char (32); dcl empty_dump bit (1); dcl continue_scan_label local label; dcl version char (4) aligned; dcl (bind_time, boot_time, up_time) fixed bin (71); dcl time_string char (24); dcl mem_word (1) bit (18) unal; dcl print_channel_name bit (1); dcl ptwp ptr; dcl (entry_cnt1, entry_cnt2) fixed bin; dcl (namep1, namep2) ptr init (null); dcl (entryp1, entryp2) ptr init (null); /* Based */ dcl system_area area based (areap); dcl 1 entries1 (entry_cnt1) aligned based (entryp1), /* Data from hcs_$star_ */ 2 type bit (2) unal, 2 nnames fixed bin (15) unal, 2 nindex fixed bin (17) unal; dcl names1 (1) char (32) aligned based (namep1); dcl 1 entries2 (entry_cnt2) aligned based (entryp2), /* Data from hcs_$star_ */ 2 type bit (2) unal, 2 nnames fixed bin (15) unal, 2 nindex fixed bin (17) unal; dcl names2 (1) char (32) aligned based (namep2); dcl dnp ptr; dcl 1 dn aligned based (dnp), 2 sort_key unal, 3 year char (2), 3 month char (2), 3 day char (2), 3 hour char (2), 3 min char (2), 3 fnp char (1), 2 ename char (32), /* Real entry name */ 2 fdump bit (1); /* Set if this is from fdump */ dcl dntabp ptr init (null); dcl dntab_size fixed bin; dcl 1 dntab aligned based (dntabp), 2 dne (dntab_size) like dn; dcl listp ptr init (null); dcl list_size fixed bin; dcl 1 list aligned based (listp), /* List of pointers for sort_items_ */ 2 cnt fixed bin, 2 dnp (list_size refer (list.cnt)) ptr unal; dcl one_k_words (1024) bit (36) aligned based; /* For looking at emptyness of dumps */ dcl 1 fdump aligned based, /* Format of fdump segment */ 2 fnp_dump (8), 3 memory (0:32767) bit (18) unal; dcl 1 ptw unal based (ptwp), /* Format of FNP page table entry */ 2 base_address fixed bin (10) uns, 2 read_only bit (1), 2 secure bit (1), 2 active bit (1), 2 count fixed bin (5) uns; /* Constants */ dcl name char (11) int static options (constant) init ("db_fnp_env_"); dcl fnp_dump_starname char (32) int static options (constant) init ("fnp.?.??????.????"); dcl fdump_starname char (32) int static options (constant) init ("??????.????.*.*.355"); /* Static */ dcl crver fixed bin int static; dcl crldt fixed bin int static; dcl crbdt fixed bin int static; dcl crreg fixed bin int static; dcl crpte fixed bin int static; dcl t_line fixed bin int static; dcl constants_setup bit (1) int static init ("0"b); /* External stuff */ dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl config_$find_2 entry (character (4) aligned, character (4) aligned, pointer); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl db_fnp_disp_cmd_$forget entry; dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl db_fnp_reader_$get_operand entry (ptr); dcl db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin); dcl db_fnp_util_$cv_chan_name entry (ptr, fixed bin, char (*), char (*), fixed bin, fixed bin (35)); dcl db_fnp_util_$get_chan_addrs entry (ptr, fixed bin, char (*), ptr, fixed bin (35)); dcl encode_clock_value_ entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (71), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl get_wdir_ entry () returns (char (168)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl parse_tty_name_ entry (char (*), fixed bin, bit (1), fixed bin, fixed bin); dcl sort_items_$char entry (ptr, fixed bin (24)); dcl user_info_$terminal_data entry (char (*), char (*), char (*), fixed bin, char (*)); dcl parse_fnp_name_ entry (char (*), fixed bin); dcl get_fnp_name_ entry (fixed bin) returns (char (32)); dcl error_table_$bad_arg ext fixed bin (35); dcl error_table_$nomatch ext fixed bin (35); dcl (cleanup, conversion) condition; dcl (addr, addrel, bin, clock, divide, hbound, length, max, null, string, substr, unspec) builtin; /* Entry to setup the default environment, FNP a, when the command begins. */ init: entry (arg_envp); envp = arg_envp; env.corep = null (); env.dump_dir = ">dumps"; env.dir, env.ename = ""; env.segp = null (); string (env.flags) = "0"b; env.tty_name = ""; env.fnp = -1; env.dump_time = 0; call setup_constants; call db_fnp_disp_cmd_$forget; call find_configured_fnps; /* Check config deck for FNP's */ call find_first_configured_fnp ("1"b); if fnp > 0 then do; env.fnp = fnp; env.fnp_sw = "1"b; end; return; /* Entry used by cleanup handler by main command */ term: entry (arg_envp); envp = arg_envp; if env.segp ^= null () then do; call hcs_$terminate_noname (env.segp, (0)); env.segp = null (); end; return; /* Command to select a specific FNP */ fnp_cmd: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call get_opt_tag; if tag = "" then do; /* Use first configured fnp */ call find_first_configured_fnp ("0"b); if fnp < 0 then go to error_return; end; if ^substr (env.fnps_configured, fnp, 1) then do; call ioa_ ("FNP ^a is not configured.", tag); go to error_return; end; call forget; env.fnp = fnp; env.fnp_sw = "1"b; return; /* Command to select a core image */ image_cmd: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; on cleanup call clean_up; call get_seg; call forget; env.fnp = -1; env.segp = segp; env.dir = dir; env.ename = ename; env.corep = addrel (segp, 1); /* Core image has length word */ env.image_sw = "1"b; return; /* Command to select a specific dump by name */ dump_cmd: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; on cleanup call clean_up; call get_seg; /* Check arg */ call forget; env.fnp = -1; /* Don't know FNP */ env.segp = segp; env.dir = dir; env.ename = ename; env.corep = segp; env.dump_sw = "1"b; /* Check format of the dump name. If it one we recognize, we can infer which FNP the dump is for, or select a valid dump from an FDUMP */ call match_star_name_ (env.ename, fnp_dump_starname, code); if code = 0 then do; /* Standard FNP dump */ call parse_fnp_name_ (substr (env.ename, 5, 1), fnp); if fnp < 0 then fnp = 0; if fnp ^= 0 then env.fnp = fnp; /* Got good fnp */ if unspec (env.segp -> one_k_words) = "0"b then call ioa_ ("^a^[>^]^a appears empty.", env.dir, (env.dir ^= ">"), env.ename); call setup_crashed_line; call ioa_ ("^[Using line ^a^;^sNo TIB available^]", (env.tty_name ^= ""), env.tty_name); return; end; call match_star_name_ (env.ename, fdump_starname, code); /* Check for standard fdump format */ if code = 0 then do; do fnp = 1 to hbound (env.segp -> fdump.fnp_dump, 1); /* Look for non-empty section */ p = addr (env.segp -> fdump.fnp_dump (fnp)); if unspec (p -> one_k_words) ^= "0"b then do; /* Found good data */ use_some_dump: env.fdump_sw = "1"b; env.corep = p; env.fnp = fnp; call setup_crashed_line; call ioa_ ("^[Using line ^a^;^sNo TIB available.^]", (env.tty_name ^= ""), env.tty_name); return; end; end; call ioa_ ("^a^[>^]^a appears empty.", env.dir, (env.dir ^= ">"), env.ename); fnp = 1; /* Use first fnp */ p = addr (env.segp -> fdump.fnp_dump (fnp)); go to use_some_dump; end; call ioa_ ("^a is non-standard dump name. FNP not known.", env.ename); return; /* Entry to set or print the default dump directory */ dump_dir: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call get_operand; if cmd_info.endline then do; call ioa_ ("Dump directory is ^a", env.dump_dir); return; end; if operand = "-wd" | operand = "-working_dir" then dir = get_wdir_ (); else do; call absolute_pathname_ (operand, dir, code); if code ^= 0 then do; call com_err_ (code, "", "^a", operand); go to error_return; end; end; env.dump_dir = dir; return; /* Entry to print a list of available dumps */ dumps: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; on cleanup call clean_up; call list_dumps; do i = list_size to 1 by -1; dnp = list.dnp (i); call ioa_ ("^a", dn.ename); end; call clean_up; return; /* Entry to find the most recent dump */ last_dump: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; continue_scan_label = prev_dump_continue; on cleanup call clean_up; call get_opt_tag; call list_dumps; do i = list_size to 1 by -1; dnp = list.dnp (i); if tag = "" then go to return_dump_info; /* Any fnp ok */ if dn.fdump then go to return_dump_info; /* Has all fnp's */ if dn.fnp = tag then go to return_dump_info; end; call ioa_ ("No dumps for FNP ^a", tag); go to error_return; return_dump_info: call forget; empty_dump = "0"b; ename = dn.ename; call hcs_$initiate (env.dump_dir, ename, "", 0, 0, segp, code); if segp = null then do; /* Can't access dump */ call com_err_ (code, name, "^a^[>^]^a", env.dump_dir, (env.dump_dir ^= ">"), ename); if list_size = 1 then go to error_return; env.ename = ename; go to continue_scan_label; end; if ^dn.fdump then do; /* Simple dump is easy */ if unspec (segp -> one_k_words) = "0"b then do; call ioa_ ("^a^[>^]^a appears empty.", env.dump_dir, (env.dump_dir ^= ">"), ename); empty_dump = "1"b; end; env.dir = env.dump_dir; env.ename = ename; env.segp = segp; env.corep = segp; env.dump_sw = "1"b; call parse_fnp_name_ (dn.fnp, env.fnp); call set_dump_time; call setup_crashed_line; if empty_dump then if list_size > 1 then go to continue_scan_label; call ioa_ ("Using ^a, ^[line ^a^;^sNo TIB available.^]", env.ename, (env.tty_name ^= ""), env.tty_name); call clean_up; return; end; if tag ^= "" then do; /* See if request fnp in this dump */ call parse_fnp_name_ (tag, i); p = addr (segp -> fdump.fnp_dump (i)); if unspec (p -> one_k_words) = "0"b then do; call ioa_ ("No data for FNP ^a in ^a", tag, ename); empty_dump = "1"b; end; go to use_fdump; end; do i = 1 to hbound (segp -> fdump.fnp_dump, 1); /* Look at pieces of fdumps */ p = addr (segp -> fdump.fnp_dump (i)); if unspec (p -> one_k_words) ^= "0"b then /* Found good component */ go to use_fdump; end; i = 1; p = addr (segp -> fdump.fnp_dump (1)); call ioa_ ("^a^[>^]^a appears empty.", env.dump_dir, (env.dump_dir ^= ">"), ename); empty_dump = "1"b; use_fdump: env.ename = ename; env.dir = env.dump_dir; env.segp = segp; env.corep = p; env.fnp = i; env.dump_sw, env.fdump_sw = "1"b; call set_dump_time; call setup_crashed_line; if empty_dump then if list_size > 1 then go to continue_scan_label; call ioa_ ("Using ^a (fnp ^a), ^[line ^a^;^sNo TIB available.^]", env.ename, get_fnp_name_ (env.fnp), (env.tty_name ^= ""), env.tty_name); call clean_up; return; /* Find the next earliest dump */ prev_dump: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; if ^env.dump_sw then do; call ioa_ ("Not currently using a dump."); go to error_return; end; continue_scan_label = prev_dump_continue; on cleanup call clean_up; call get_opt_tag; call list_dumps; prev_dump_continue: call find_current; do i = dnx - 1 to 1 by -1; dnp = list.dnp (i); if tag = "" then go to return_dump_info; if dn.fdump then go to return_dump_info; if dn.fnp = tag then go to return_dump_info; end; if tag ^= "" then call ioa_ ("No more dumps for FNP ^a", tag); else call ioa_ ("^a is the oldest dump.", env.ename); go to error_return; /* Get the next lastest dump */ next_dump: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; if ^env.dump_sw then do; call ioa_ ("Not currently using a dump."); go to error_return; end; continue_scan_label = next_dump_continue; on cleanup call clean_up; call get_opt_tag; call list_dumps; next_dump_continue: call find_current; do i = dnx + 1 to list_size; dnp = list.dnp (i); if tag = "" then go to return_dump_info; if dn.fdump then go to return_dump_info; if tag = dn.fnp then go to return_dump_info; end; if tag ^= "" then call ioa_ ("No more dumps for FNP ^a", tag); else call ioa_ ("^a is the most recent dump", env.ename); go to error_return; /* Select a differnt fnp from a multi-fnp segment */ select_fdump_fnp: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; if ^env.dump_sw then do; call ioa_ ("Only valid on dumps."); go to error_return; end; call get_tag; p = addr (env.segp -> fdump.fnp_dump (fnp)); if unspec (p -> one_k_words) = "0"b then /* No data */ call ioa_ ("No data for FNP ^a in ^a", tag, env.ename); if fnp ^= env.fnp then do; /* Something changing */ call forget_fnp; env.fnp = fnp; env.corep = p; end; call setup_crashed_line; if env.tty_name ^= "" then call ioa_ ("^[Using line ^a^;^sNo TIB available.^]", env.tty_name); return; /* Procedure to print name of current dump, image, fnp, etc */ what: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; if ^(env.fnp_sw | env.dump_sw | env.image_sw) then do; call ioa_ ("Nothing"); return; end; call get_version; if env.fnp_sw then call ioa_ ("FNP ^a, version ^a", get_fnp_name_ (env.fnp), version); else if image_sw then call ioa_ ("Core image in ^a^[>^]^a, version ^a", env.dir, (env.dir ^= ">"), env.ename, version); else if env.dump_sw then if ^env.fdump_sw then call ioa_ ("Dump in ^a^[>^]^a, version ^a", env.dir, (env.dir ^= ">"), env.ename, version); else call ioa_ ("Fdump in ^a^[>^]^a (fnp ^a), version ^a", env.dir, (env.dir ^= ">"), env.ename, get_fnp_name_ (env.fnp), version); return; /* Entry to implement the when command which prints interesting stuff about times */ when: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call get_version; call fetch (crldt, 4, addr (bind_time), "0"b); if code ^= 0 then go to error_return; call fetch (crbdt, 4, addr (boot_time), "0"b); if code ^= 0 then go to error_return; call date_time_ (bind_time, time_string); call ioa_ ("MCS version ^a, bound on ^a", version, time_string); if boot_time ^= 0 then do; call date_time_ (boot_time, time_string); call ioa_ ("Booted on ^a", time_string); end; if env.fnp_sw then do; up_time = max (0, clock () - boot_time); call ioa_ ("FNP has been up for ^a", edit_interval (up_time)); end; if env.dump_sw & env.dump_time ^= 0 then do; up_time = max (0, env.dump_time - boot_time); call ioa_ ("FNP up for ^a before crash", edit_interval (up_time)); end; return; /* Entry to select a specific fnp channel. It will switch FNP's to get the requested line if necessary */ line: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; if ^(fnp_sw | dump_sw) then do; call ioa_ ("Only valid on running FNP, or a dump."); go to error_return; end; call get_operand; if cmd_info.endline then do; /* No operands, print current line */ if env.tty_name = "" then call ioa_ ("No line selected."); else call ioa_ ("Line ^a. ^[TIB at ^o^]", env.tty_name, expr_info.tib_known, expr_info.tib_addr); return; end; tty_name = operand; print_channel_name = "0"b; if operand = "-login" | operand = "-login_channel" then do; call user_info_$terminal_data ((""), (""), tty_name, (0), ("")); print_channel_name = "1"b; end; else if operand = "-crash" then do; if ^env.dump_sw then do; call ioa_ ("Not current using a dump."); go to error_return; end; call find_crashed_line ("0"b); if tty_name = "" then go to error_return; print_channel_name = "1"b; end; i = cv_oct_check_ (tty_name, code); /* An octal line number is always for this FNP */ if code = 0 then fnp = max (1, env.fnp); /* If we know the FNP, that is */ else call parse_tty_name_ (tty_name, fnp, ("0"b), (0), (0)); /* Check name, ignoring all but fnp result */ if fnp < 0 then do; /* Bad format name */ call ioa_ ("Illegal tty name: ^a", tty_name); go to error_return; end; if (env.fnp > 0) & (env.fnp ^= fnp) then do; /* If current FNP known, do some checking */ if env.fnp_sw then do; /* Running live fnp's */ if ^substr (env.fnps_configured, fnp, 1) then do; call ioa_ ("^a is on FNP ^a which is not configured.", tty_name, get_fnp_name_ (fnp)); go to error_return; end; call ioa_ ("Switching to FNP ^a", get_fnp_name_ (fnp)); call forget_fnp; env.fnp = fnp; end; else if env.fdump_sw then do; /* Running fdump */ p = addr (env.segp -> fdump.fnp_dump (fnp)); /* Find piece for new fnp */ if unspec (p -> one_k_words) = "0"b then do; call ioa_ ("^a is on FNP ^a; no data in ^a for FNP ^a", tty_name, get_fnp_name_ (fnp), env.ename, get_fnp_name_ (fnp)); go to error_return; end; call ioa_ ("Switching to FNP ^a", get_fnp_name_ (fnp)); call forget_fnp; env.corep = p; env.fnp = fnp; end; else do; call ioa_ ("^a is on FNP ^a, dump is for FNP ^a", tty_name, get_fnp_name_ (fnp), get_fnp_name_ (env.fnp)); go to error_return; end; end; call setup_line_data ("0"b); if env.tty_name = "" then go to error_return; if print_channel_name then call ioa_ ("Using ^a", env.tty_name); return; /* Procedure to check an argument for a valid FNP tag */ get_tag: proc; call get_operand_req ("Tag"); tag_join: call parse_fnp_name_ (operand, fnp); if fnp < 0 then do; call ioa_ ("Invalid FNP tag: ^a", operand); go to error_return; end; tag = operand; return; get_opt_tag: entry; call get_operand; if cmd_info.endline then do; tag = ""; return; end; go to tag_join; end get_tag; /* Procedure to check an argument for a pathname */ get_seg: proc; call get_operand_req ("Pathname"); call expand_pathname_ (operand, dir, ename, code); if code ^= 0 then do; call com_err_ (code, "", "^a", operand); go to error_return; end; call check_star_name_$entry (ename, code); if code = 1 | code = 2 then do; /* Allow starnames as shorthand */ areap = get_system_free_area_ (); call hcs_$star_ (dir, ename, 3, areap, entry_cnt1, entryp1, namep1, code); if code ^= 0 then do; call com_err_ (code, "", "^a^[>^]^a", dir, (dir ^= ">"), ename); go to error_return; end; if entry_cnt1 > 1 then do; call ioa_ ("^a matches multiple entries in ^a", ename, dir); go to error_return; end; ename = names1 (entries1.nindex (1)); /* Use first name */ free entries1; free names1; entryp1, namep1 = null (); end; call hcs_$initiate (dir, ename, "", 0, 0, segp, code); if segp = null then do; call com_err_ (code, "", "^a^[>^]^a", dir, (dir ^= ">"), ename); go to error_return; end; return; end get_seg; /* Be sure a required operand is present */ get_operand_req: proc (s); dcl s char (*); call get_operand; if ^cmd_info.endline then return; call ioa_ ("^a missing.", s); go to error_return; end get_operand_req; get_operand: proc; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; return; end get_operand; /* Procedure for "forgetting" the current fnp, dump, etc., in preperation for a new one */ forget: proc; call forget_fnp; env.dump_sw = "0"b; env.fnp_sw = "0"b; env.image_sw = "0"b; env.fdump_sw = "0"b; env.dump_time = 0; if env.segp ^= null () then do; call hcs_$terminate_noname (env.segp, code); env.segp = null (); end; env.corep = null (); env.fnp = -1; return; end forget; /* Forget data associated with the current FNP. This is used with last drastic environment changes, like when changing to a new fnp in an fdump */ forget_fnp: proc; string (expr_info.flags) = "0"b; env.tty_name = ""; call db_fnp_disp_cmd_$forget; /* Forget next buffer address */ return; end forget_fnp; /* Procedure to find the current dump in the dump list */ find_current: proc; do dnx = 1 to list_size; dnp = list.dnp (dnx); if dn.ename = env.ename then return; end; call ioa_ ("Unable to find current dump: ^a", env.ename); go to error_return; end find_current; /* Procedure to convert a dump time back into a clock value */ set_dump_time: proc; on conversion go to return_no_time; call encode_clock_value_ (bin (dn.month), bin (dn.day), 1900 + bin (dn.year), bin (dn.hour), bin (dn.min), 0, 0, 0, " ", env.dump_time, code); if code ^= 0 then env.dump_time = 0; return; return_no_time: env.dump_time = 0; return; end set_dump_time; /* Get the current version */ get_version: proc; dcl i fixed bin; dcl test_char bit (9); call fetch (crver, 2, addr (version), "0"b); if code ^= 0 then version = "?"; do i = 1 to length (version); test_char = unspec (substr (version, i, 1)); if test_char < "040"b3 | test_char > "176"b3 then version = "?"; end; return; end get_version; /* Procedure to edit a time interval */ edit_interval: proc (arg_interval) returns (char (64) var); dcl arg_interval fixed bin (71); dcl interval fixed bin (71); dcl (hours, minutes) fixed bin; dcl work_string char (64) var; interval = arg_interval + 30000000; hours = divide (interval, 3600000000, 17, 0); interval = interval - 3600000000 * hours; minutes = divide (interval, 60000000, 17, 0); call ioa_$rsnnl ("^[^d hour^[s^]^;^2s^]^[^[, ^]^d min^[s^]^;^3s^]^[seconds^]", work_string, (0), (hours ^= 0), hours, (hours ^= 1), (minutes ^= 0), (hours ^= 0), minutes, (minutes ^= 1), ((hours = 0) & (minutes = 0))); return (work_string); end edit_interval; /* Procedure to get a list of dumps */ list_dumps: proc; dcl i fixed bin; areap = get_system_free_area_ (); call hcs_$star_ (env.dump_dir, fnp_dump_starname, 3, areap, entry_cnt1, entryp1, namep1, code); /* List normal fnp dumps */ if (code ^= 0) & (code ^= error_table_$nomatch) then go to list_dumps_error; call hcs_$star_ (env.dump_dir, fdump_starname, 3, areap, entry_cnt2, entryp2, namep2, code); /* List fdumps */ if (code ^= 0) & (code ^= error_table_$nomatch) then go to list_dumps_error; if (entry_cnt1 + entry_cnt2) = 0 then do; /* None of either kind */ call ioa_ ("No dumps in ^a", env.dump_dir); go to error_return; end; dntab_size = entry_cnt1 + entry_cnt2; /* Number of dumps is regular count + fdumps */ allocate dntab in (system_area); dnx = 0; do i = 1 to entry_cnt1; /* Make entries for regular dumps */ dnx = dnx+1; dnp = addr (dntab.dne (dnx)); dn.ename = names1 (entries1.nindex (i)); dn.year = substr (dn.ename, 11, 2); dn.month = substr (dn.ename, 7, 2); dn.day = substr (dn.ename, 9, 2); dn.hour = substr (dn.ename, 14, 2); dn.min = substr (dn.ename, 16, 2); dn.fnp = substr (dn.ename, 5, 1); dn.fdump = "0"b; end; do i = 1 to entry_cnt2; /* Scan each fdump */ dnx = dnx+1; dnp = addr (dntab.dne (dnx)); dn.ename = names2 (entries2.nindex (i)); dn.year = substr (dn.ename, 5, 2); dn.month = substr (dn.ename, 1, 2); dn.day = substr (dn.ename, 3, 2); dn.hour = substr (dn.ename, 8, 2); dn.min = substr (dn.ename, 10, 2); dn.fnp = ""; dn.fdump = "1"b; end; list_size = dnx; /* Total dumps */ allocate list in (system_area); do i = 1 to list_size; list.dnp (i) = addr (dntab.dne (i)); end; call sort_items_$char (listp, length (string (dn.sort_key))); return; list_dumps_error: call com_err_ (code, name, "^a", env.dump_dir); go to error_return; end list_dumps; error_return: cmd_info.flush = "1"b; call clean_up; return; /* Pick up initial arguments */ setup: proc; cmd_infop = arg_cmd_infop; expr_infop = arg_expr_infop; envp = cmd_info.envp; return; end setup; setup_constants: proc; if constants_setup then return; crver = db_fnp_sym_util_$get_value (".crver"); crldt = db_fnp_sym_util_$get_value (".crldt"); crbdt = db_fnp_sym_util_$get_value (".crbdt"); crreg = db_fnp_sym_util_$get_value (".crreg"); crpte = db_fnp_sym_util_$get_value (".crpte"); t_line = db_fnp_sym_util_$get_value ("t.line"); constants_setup = "1"b; return; end setup_constants; /* Procedure to scan the config deck for fnp cards */ find_configured_fnps: proc; %include config_prph_fnp_card; declare fnpx fixed bin; env.fnps_configured = "0"b; do fnpx = 1 to 8; prph_fnp_cardp = null (); call config_$find_2 ("prph", "fnp" || get_fnp_name_ (fnpx), prph_fnp_cardp); if prph_fnp_cardp ^= null () then substr (env.fnps_configured, fnpx, 1) = "1"b; end; return; end find_configured_fnps; /* Procedure to select the first configured FNP */ find_first_configured_fnp: proc (quiet_sw); dcl quiet_sw bit (1); dcl (i, j) fixed bin; fnp = -1; j = 0; do i = 1 to length (env.fnps_configured); if substr (env.fnps_configured, i, 1) then do; if fnp = -1 then fnp = i; j = j + 1; end; end; if j = 0 then do; call ioa_ ("No FNP's configured."); return; end; tag = get_fnp_name_ (fnp); if j > 1 then if ^quiet_sw | (fnp ^= 1) then call ioa_ ("Using FNP ^a", tag); return; end find_first_configured_fnp; /* Called for a dump to find the line casuing the crash */ setup_crashed_line: proc; call find_crashed_line ("1"b); if tty_name ^= "" then call setup_line_data ("1"b); return; end setup_crashed_line; find_crashed_line: proc (quiet_sw); dcl quiet_sw bit (1); dcl (i, base) fixed bin; tty_name = ""; call fetch (crreg, 1, addr (mem_word), quiet_sw); /* Get address of saved registers */ if code ^= 0 then return; i = bin (mem_word (1)); call fetch (i, 1, addr (mem_word), "1"b); /* Read contents of ic */ if code ^= 0 then do; if ^quiet_sw then call ioa_ ("Address of saved registers invalid (.crreg = ^o)", i); return; end; if mem_word (1) = "0"b then do; if ^quiet_sw then call ioa_ ("No fault occured."); return; end; call fetch (i + 4, 1, addr (mem_word), quiet_sw); /* Read value of x1 */ if code ^= 0 then return; if mem_word (1) & "700001"b3 then do; /* Known bad bits for a tib address */ bad_x1: if ^quiet_sw then call ioa_ ("x1 does not point at a tib"); return; end; i = bin (mem_word (1)); call fetch (crpte, 1, addr (mem_word), quiet_sw); /* See if paging being used */ if code ^= 0 then return; if mem_word (1) ^= "0"b then do; /* There is page table */ call fetch (bin (mem_word (1)), 1, addr (mem_word), quiet_sw); /* Get it */ if code ^= 0 then return; ptwp = addr (mem_word (1)); if ptw.active then do; base = 32768 - 256 * (ptw.count + 1); /* Start of window */ if i >= base then /* X1 points into window */ i = (i - base) + 256 * ptw.base_address; end; end; call fetch (i + t_line, 1, addr (mem_word), quiet_sw); if code ^= 0 then go to bad_x1; if (mem_word (1) = "0"b) | (mem_word (1) & "776000"b3) then go to bad_x1; call ioa_$rsnnl ("^o", tty_name, (0), bin (mem_word (1))); return; end find_crashed_line; setup_line_data: proc (quiet_sw); dcl quiet_sw bit (1); env.tty_name = ""; /* Forget current name */ string (expr_info.flags) = "0"b; call db_fnp_util_$get_chan_addrs (env.corep, env.fnp, tty_name, expr_infop, code); if code = error_table_$bad_arg then do; if ^quiet_sw then call ioa_ ("^a not configured.", tty_name); return; end; else if code ^= 0 then do; if ^quiet_sw then call com_err_ (code, "", "Getting data on ^a", tty_name); return; end; call db_fnp_util_$cv_chan_name (env.corep, env.fnp, tty_name, ename, (0), code); /* Get canonical tty name */ if code = 0 then env.tty_name = ename; else env.tty_name = tty_name; return; end setup_line_data; fetch: proc (a, l, p, q); dcl a fixed bin; /* Address to read */ dcl l fixed bin; /* Length to read */ dcl p ptr; /* Where to put it */ dcl q bit (1); /* Quiet switch */ call db_fnp_memory_$fetch (env.corep, env.fnp, a, l, p, code); if code ^= 0 then if ^q then if l = 1 then call com_err_ (code, name, "Unable to read fnp location ^o.", a); else call com_err_ (code, name, "Unable to read fnp locations ^o thru ^o", a, a + l - 1); return; end fetch; /* Cleanup handler */ clean_up: proc; if listp ^= null then free list; if dntabp ^= null then free dntab; if namep1 ^= null then free names1; if namep2 ^= null then free names2; if entryp1 ^= null then free entries1; if entryp2 ^= null then free entries2; return; end clean_up; %include debug_fnp_data; end db_fnp_env_;  db_fnp_eval_.pl1 11/15/82 1816.2rew 11/15/82 1502.0 197910 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_EVAL_ - Procedure to evaluate expressions intended to be fnp addresses */ /* Written February 1977 by Larry Johnson */ /* Modified January 1977 by Larry Johnson to accept 'string' as machine instruction format */ /* Modified January 1981 by Robert Coren to evaluate symbols in channel metering areas */ db_fnp_eval_: proc (arg_corep, arg_fnp, arg_expr, arg_expr_infop, arg_caller, arg_result, arg_code); /* Parameters */ dcl arg_corep ptr; /* Pointer to segment containg core image */ dcl arg_fnp fixed bin; /* Number of running fnp */ dcl arg_expr char (*); /* The expression to evaluate */ dcl arg_expr_infop ptr; /* Optional pointer to supplementary information */ dcl arg_caller char (*); /* Caller name to go in error messages */ dcl arg_result fixed bin; /* The answer */ dcl arg_code fixed bin (35); /* Automatic */ dcl corep ptr; dcl fnp fixed bin; dcl result fixed bin; dcl code fixed bin (35); dcl ntoken fixed bin; /* Number of tokens */ dcl exprp ptr; /* Pointer to unparsed part of expression */ dcl exprl fixed bin; /* Length of unparsed part */ dcl expr char (exprl) based (exprp); /* The unparsed part of expression */ dcl tstart fixed bin; /* Starting token in sub-expression */ dcl tend fixed bin; /* Last token in sub-expression */ dcl tcur fixed bin; /* Current token */ dcl n_ind fixed bin; /* Count of indirects in expression */ dcl n_mult fixed bin; /* Count of multiplies and divides */ dcl n_add fixed bin; /* Count of adds and subtracts */ dcl 1 auto_expr_info like expr_info; dcl 1 token_list aligned, 2 entry (255) unal, 3 token like token; /* Definition of a token */ dcl tokenp ptr; dcl 1 token unaligned based (tokenp), 2 prev fixed bin (8), /* Backwards pointer */ 2 next fixed bin (8), /* Forwards pointer */ 2 type fixed bin (8), /* Kind of token */ 2 sub fixed bin (8), /* Sub-type, for some tokens */ 2 val fixed bin (35); /* Values for token.type */ dcl (start_token init (0), /* Start of expression */ leftp_token init (1), /* Left parenthesis */ rightp_token init (2), /* Right parenthesis */ mult_token init (3), /* Multiply (sub=1), or divide (sub=2) */ add_token init (4), /* Add (sub=1), or subtract (sub=2) */ ind_token init (5), /* Indirect thru fnp word */ sym_token init (6), /* Symbol or constant */ end_token init (7)) /* End of expression */ fixed bin int static options (constant); /* External stuff */ dcl ioa_ entry options (variable); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned); dcl com_err_ entry options (variable); dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl db_fnp_sym_util_$lookup entry (char (*), ptr); dcl db_fnp_sym_util_$lookup_user entry (ptr, char (*), ptr); dcl db_fnp_opblock_util_$lookup entry (char (*), bit (18), fixed bin (35)); dcl db_fnp_util_$lookup_module entry (ptr, fixed bin, char (*), fixed bin, fixed bin (35)); dcl db_fnp_edit_inst_$assemble entry (ptr, fixed bin, char (*), ptr, bit (18), fixed bin (35)); dcl error_table_$bad_arg ext fixed bin (35); dcl (addr, divide, hbound, index, length, null, search, string, substr, unspec, verify) builtin; /* Initialization */ corep = arg_corep; fnp = arg_fnp; exprp = addr (arg_expr); exprl = length (arg_expr); expr_infop = arg_expr_infop; if expr_infop = null then do; /* If no structure, setup dummy */ expr_infop = addr (auto_expr_info); string (expr_info.flags) = "0"b; expr_info.user_tablep = null; end; expr_info.type = type_oct; expr_info.len = 1; /* Now evaluate the expression */ code = 0; if substr (expr, 1, 1) = "'" then do; /* Special machine instruction format */ call eval_inst; go to eval_return; end; call parse_expr; call eval_expr; eval_return: arg_result = result; arg_code = 0; return; error_return: /* If error */ arg_result = 0; arg_code = code; return; /* Procedure to parse the expression */ parse_expr: proc; dcl nparen fixed bin; /* For paren level counting */ dcl i fixed bin; ntoken = 0; call new_token (start_token); /* First, start of expr token */ nparen = 0; do while (exprl > 0); /* Loop until end */ i = index ("()*/+|-,", substr (expr, 1, 1)); /* Check for special character */ if i = 0 then do; /* Must be symbol */ if sym_or_rightp_or_ind () then go to bad_char; call parse_sym; go to next_token; end; else go to parse_op (i); /* Branch, depending on character */ parse_op (1): /* Left paren */ if sym_or_rightp_or_ind () then go to bad_char; call new_token (leftp_token); nparen = nparen + 1; call adv (1); go to next_token; parse_op (2): /* Right paren */ if token.type = start_token | mult_or_add () then go to bad_char; if nparen ^> 0 then do; if exprl = length (arg_expr) then go to bad_char; else call err ("Too many "")""."); end; call new_token (rightp_token); nparen = nparen - 1; call adv (1); go to next_token; parse_op (3): /* "*" - may be multiply or reference to loc counter */ if sym_or_rightp_or_ind () then do; /* Multiply */ call new_token (mult_token); token.sub = 1; end; else do; /* Reference to location counter */ if ^expr_info.star_known then call err ("Value of ""*"" is not known.");; call new_token (sym_token); token.val = expr_info.star_addr; end; call adv (1); go to next_token; parse_op (4): /* Divide */ if start_or_leftp () | mult_or_add () then go to bad_char; call new_token (mult_token); token.sub = 2; call adv (1); go to next_token; parse_op (5): /* Add */ parse_op (6): /* Add, alternate form ("|") */ parse_op (7): /* Subtract */ if start_or_leftp () then call new_token (sym_token); /* Unary, treat as 0+ or 0- */ else if mult_or_add () then go to bad_char; call new_token (add_token); if substr (expr, 1, 1) = "-" then token.sub = 2; else token.sub = 1; call adv (1); go to next_token; parse_op (8): /* Comma, must be start of ",*" */ if (exprl < 2) | ((exprl >= 2) & substr (expr, 2, 1) ^= "*") then call err ("Missing ""*"" after "",""."); if start_or_leftp () | mult_or_add () then go to bad_char; call new_token (ind_token); call adv (2); go to next_token; next_token: end; if nparen ^= 0 then call err ("Parens do not balance."); /* Must balance in end */ if mult_or_add () then call err ("Expression ends badly."); call new_token (end_token); return; end parse_expr; /* Procedure to parse a constant or a symbol name */ parse_sym: proc; dcl val fixed bin (35); dcl bval bit (36) aligned based (addr (val)); dcl (i, j) fixed bin; dcl dec_sw bit (1) init ("0"b); dcl opval bit (18); dcl tib_meter fixed bin; dcl tib_page_base fixed bin; dcl meter_orig fixed bin (18) unsigned unaligned; i = verify (expr, "0123456789"); /* Try constant first */ if i ^= 1 then do; /* It is a constant */ if i = 0 then i = length (expr); /* Rest of expr is a constant */ else i = i - 1; if i < length (expr) then if substr (expr, i+1, 1) = "." then dec_sw = "1"b; /* Decimal constant */ if dec_sw then do; val = cv_dec_check_ (substr (expr, 1, i), code); if code ^= 0 then do; code = 0; call err ("Invalid decimal integer: ""^a"".", substr (expr, 1, i)); end; if val < -262144 | val > 262143 then call err ("Decimal integer not in range -262144 to 262143: ^a", substr (expr, 1, i)); call adv (i+1); end; else do; /* Octal number */ val = cv_oct_check_ (substr (expr, 1, i), code); if code ^= 0 then do; code = 0; call err ("Invalid octal integer: ""^a"".", substr (expr, 1, i)); end; if substr (bval, 1, 18) ^= "0"b & substr (bval, 1, 18) ^= "777777"b3 then call err ("Octal integer not in range -400000 to 377777: ^a", substr (expr, 1, i)); call adv (i); end; if val > 0 then if substr (bval, 19, 1) then /* Really negative */ substr (bval, 1, 18) = "777777"b3; call new_token (sym_token); /* Set up token for symbol */ token.val = val; return; end; /* Symbol must be a name */ i = search (expr, "()*/+|-,"); /* Look for end */ if i = 1 then go to bad_char; if i = 0 then i = length (expr); else i = i - 1; call db_fnp_util_$lookup_module (corep, fnp, substr (expr, 1, i), j, code); if code = 0 then do; call new_token (sym_token); token.val = j; call adv (i); return; end; call db_fnp_opblock_util_$lookup (substr (expr, 1, i), opval, code); if code = 0 then do; call new_token (sym_token); unspec (token.val) = "777777"b3 || opval; call adv (i); return; end; call db_fnp_edit_inst_$assemble (corep, fnp, substr (expr, 1, i), expr_infop, opval, code); /* May symbol is a machine opcode mneumonic */ if code = 0 then do; call new_token (sym_token); if substr (opval, 1, 1) then unspec (token.val) = "777777"b3 || opval; else unspec (token.val) = "000000"b3 || opval; call adv (i); return; end; call db_fnp_sym_util_$lookup_user (expr_info.user_tablep, substr (expr, 1, i), symp); if symp = null then do; call db_fnp_sym_util_$lookup (substr (expr, 1, i), symp); if symp = null then do; code = 0; call err ("Invalid symbol: ""^a"".", substr (expr, 1, i)); end; end; code = 0; call new_token (sym_token); token.val = sym.value; if sym.reloc = reloc_tib then /* Must add in tib */ if ^expr_info.tib_known then call err ("Illegal use of ""^a"". Address of TIB not known.", substr (expr, 1, i)); else token.val = token.val + expr_info.tib_addr; else if sym.reloc = reloc_hwcm then if ^expr_info.hwcm_known then call err ("Illegal use of ""^a"". Address of HWCM not known.", substr (expr, 1, i)); else token.val = token.val + expr_info.hwcm_addr; else if sym.reloc = reloc_sfcm then if ^expr_info.sfcm_known then call err ("Illegal use of ""^a"". Address of SFCM not known.", substr (expr, 1, i)); else token.val = token.val + expr_info.sfcm_addr; else if sym.reloc = reloc_meters then /* add in value of t.metr */ if ^expr_info.tib_known then call err ("Illegal use of ""^a"". Address of TIB not known.", substr (expr, 1, i)); else do; call db_fnp_eval_ (corep, fnp, "t.metr", expr_infop, arg_caller, tib_meter, code); /* get value of t.metr */ if code ^= 0 then do; arg_code = code; return; end; tib_page_base = 256*(divide (expr_info.tib_addr, 256, 17, 0)); /* allow for possible virtual address */ tib_meter = tib_page_base + mod (tib_meter,256); call db_fnp_memory_$fetch (corep, fnp, tib_meter, 1, addr (meter_orig), code); if code ^= 0 then do; arg_code = code; return; end; meter_orig = tib_page_base + mod (meter_orig, 256); /* make sure we have abs. address */ token.val = token.val + meter_orig; end; expr_info.type = sym.type; expr_info.len = sym.len; call adv (i); return; end parse_sym; /* Procedures which to some comon tests on the previous token */ mult_or_add: proc returns (bit (1)); return (token.type = mult_token | token.type = add_token); end mult_or_add; start_or_leftp: proc returns (bit (1)); return (token.type = start_token | token.type = leftp_token); end start_or_leftp; sym_or_rightp_or_ind: proc returns (bit (1)); return (token.type = sym_token | token.type = rightp_token | token.type = ind_token); end sym_or_rightp_or_ind; /* Procedure to create a new token and trhread it in */ new_token: proc (type); dcl type fixed bin; /* Type of new token */ if ntoken = hbound (token_list.entry, 1) then call err ("Expression too long."); if ntoken > 0 then token.next = ntoken + 1; /* Set pointer in prev token */ ntoken = ntoken + 1; tokenp = addr (token_list.entry (ntoken)); token.prev = ntoken - 1; token.next = 0; token.type = type; token.sub = 0; token.val = 0; return; end new_token; /* Procedure to advance pointer in expression */ adv: proc (n); dcl n fixed bin; /* Amount to move */ exprp = substraddr (expr, n+1); /* Adjust pointer */ exprl = exprl - n; /* Adjust length */ return; end adv; /* Procedure to evaluate the expression by scanning the list of tokens */ /* The procedure is to find the inner most expression, evaluate it, and continue. At the end, there should only be 3 tokens left: the start, the end, and one symbol token containing the final value */ eval_expr: proc; do while (ntoken > 3); call find_sub_expr; /* Find some inner expression to work on */ call eval_sub_expr; /* And reduce it to a value */ end; tokenp = addr (token_list.entry (1)); /* Pointer to start token */ tokenp = addr (token_list.entry (token.next)); /* Second token, containing the value */ result = token.val; /* Get the answer */ return; end eval_expr; /* Procedure to locate an inner expression to evaluate. This will be either a part of the expression delimited by parens, or, if no parens left, the entire expression. */ /* The following variables are set for future use: tstart - the first token in the expression found tend - the last n_ind - the number of indirection tokens between tstart and tend n_mult - likewise for mult tokens n_add - likewise for add tokens */ find_sub_expr: proc; n_ind, n_mult, n_add = 0; tstart, tcur = 1; tokenp = addr (token_list.entry (tstart)); do while ((token.type ^= rightp_token) & (token.type ^= end_token)); if token.type = leftp_token then do; tstart = tcur; /* Maybe expression will start here */ n_ind, n_mult, n_add = 0; /* Must reset counters for inner level */ end; else if token.type = ind_token then n_ind = n_ind + 1; else if token.type = mult_token then n_mult = n_mult + 1; else if token.type = add_token then n_add = n_add + 1; tcur = token.next; /* On to next one */ tokenp = addr (token_list.entry (tcur)); end; tend = tcur; end find_sub_expr; /* Procedure to evaluate sub-expression once it has been isolated. */ /* The sub-expression is repeatedly scanned for mult tokens, add tokens, and ind tokens, in that order. Repeated scans are necessary because indirect ops must be done before mult or add ops after them, and vice versa */ eval_sub_expr: proc; do while ((n_ind + n_mult + n_add) > 0); if n_mult > 0 then call eval_op (mult_token, n_mult); if n_add > 0 then call eval_op (add_token, n_add); if n_ind > 0 then call eval_ind; end; call del_token (tstart); /* Delete parens one expression is evaluated */ call del_token (tend); return; end eval_sub_expr; /* This procedure scans looking for either mult tokens or add tokens to be evaluated. As many are evaluated as possible. The scan stops with either a an ind token, or exhausting the count of tokens being handled. */ eval_op: proc (token_type, token_cnt); dcl token_type fixed bin; /* The kind of token being evaluated, mult or add */ dcl token_cnt fixed bin; /* Number still unevaluated in sub-expression */ tcur = tstart; tokenp = addr (token_list.entry (tcur)); do while ((token.type ^= ind_token) & (token_cnt > 0)); if token.type = token_type then do; /* Got one */ call compute_op; /* Go do the arithmetic */ token_cnt = token_cnt - 1; end; tcur = token.next; tokenp = addr (token_list.entry (tcur)); end; return; /* Every thing possible is done */ end eval_op; /* Procedure called to evalue a mult or add token. Once the arithmetic is done, the value is stored in the first sym token. the operator token and the second symbol token are deleted. This procedure is called with tcur as the operator token being evaluated */ compute_op: proc; dcl (del1, del2) fixed bin; /* The two tokens to be deleted */ dcl (val1, val2) fixed bin (35); /* Values of the two symbols */ dcl p ptr; del1 = tcur; /* The operator token will be deleted */ del2 = token.next; /* As well as the second operand */ p = addr (token_list.entry (token.next)); /* Pointter to second symbol token */ val2 = p -> token.val; p = addr (token_list.entry (token.prev)); /* Pointer to the first symbol */ val1 = p -> token.val; if token.type = add_token then do; /* Add or subtract */ if token.sub = 1 then val1 = val1 + val2; else val1 = val1 - val2; end; else do; /* Multiply or divide */ if token.sub = 1 then val1 = val1 * val2; else do; if val2 = 0 then call err ("Division by zero."); else val1 = divide (val1, val2, 35, 0); end; end; tcur = token.prev; /* Make first operand the current token */ tokenp = addr (token_list.entry (tcur)); token.val = val1; /* Save answer */ expr_info.type = type_oct; expr_info.len = 1; call del_token (del1); /* Delete operator */ call del_token (del2); /* And the sedond operand */ return; end compute_op; /* Procedure to scan for and evalute indirections. The will do as many indirections as specified, but will not scan past an add or mult token */ eval_ind: proc; dcl bitval bit (36); dcl 1 word_buf aligned, 2 val bit (18) unal, 2 pad bit (18) unal; tcur = tstart; tokenp = addr (token_list.entry (tcur)); do while (^mult_or_add () & (n_ind > 0)); if token.type = ind_token then do; /* Found one */ tcur = token.prev; /* Back up to look at token with address */ tokenp = addr (token_list.entry (tcur)); call db_fnp_memory_$fetch (corep, fnp, (token.val), 1, addr (word_buf), code); if code ^= 0 then call err ("Unable to read FNP memory location ^o to do indrection.", token.val); substr (bitval, 19) = word_buf.val; /* Put in right half of word */ if substr (word_buf.val, 1, 1) = "0"b then substr (bitval, 1, 18) = "0"b; /* Propagate sign */ else substr (bitval, 1, 18) = "777777"b3; unspec (token.val) = bitval; n_ind = n_ind - 1; expr_info.type = type_oct; expr_info.len = 1; call del_token ((token.next)); /* Delete ind token */ end; tcur = token.next; tokenp = addr (token_list.entry (tcur)); end; end eval_ind; /* Procedure to delete a token by untreading it from the list */ del_token: proc (n); dcl n fixed bin; /* The token to go */ dcl (next, prev) fixed bin; dcl p ptr; p = addr (token_list.entry (n)); prev = p -> token.prev; next = p -> token.next; if (prev = 0) | (next = 0) then return; /* Ndver delete start or end */ p = addr (token_list.entry (prev)); p -> token.next = next; p = addr (token_list.entry (next)); p -> token.prev = prev; ntoken = ntoken - 1; return; end del_token; /* Handle an expression in single-quuotes (') as a machine instruction */ eval_inst: proc; dcl (i, j) fixed bin; dcl inst bit (18); dcl fb35 fixed bin (35); i = 1; /* Starting index to assemble */ j = length (expr); /* Length to assemble */ if substr (expr, 1, 1) = "'" then do; /* Strip leading quote */ i = 2; j = j-1; end; if substr (expr, length (expr), 1) = "'" then j = j-1; /* Strip trailing quote */ call db_fnp_edit_inst_$assemble (corep, fnp, substr (expr, i, j), expr_infop, inst, code); if code ^= 0 then do; if arg_caller ^= "" then call com_err_ (0, arg_caller, "Invalid machine instruction: ^a"); else call ioa_ ("Invalid machine instruction: ^a", expr); go to error_return; end; if substr (inst, 1, 1) then unspec (fb35) = "777777"b3 || inst; /* If negative number */ else fb35 = bin (inst); result = fb35; return; end eval_inst; /* Error routines */ bad_char: if exprl < length (arg_expr) then call err ("""^a"" after ""^a"" is invalid.", substr (expr, 1, 1), substr (arg_expr, 1, length (arg_expr) - exprl)); else call err ("""^a"" at beginning is invalid.", substr (expr, 1, 1)); /* General error subroutine */ err: proc options (variable); dcl s char (256); dcl p ptr; call cu_$arg_list_ptr (p); call ioa_$general_rs (p, 1, 2, s, (0), "1"b, "0"b); if code ^= 0 | arg_caller ^= "" then call com_err_ (code, arg_caller, "Invalid expression: ""^a"". ^a", arg_expr, s); else call ioa_ ("Invalid expression: ""^a"". ^a", arg_expr, s); if code = 0 then code = error_table_$bad_arg; go to error_return; end err; /* Simulate substraddr builtin temporarily */ substraddr: proc (c, n) returns (ptr); dcl c char (*); dcl n fixed bin; dcl ca (n) char (1) unal based (addr (c)); return (addr (ca (n))); end substraddr; %include debug_fnp_data; end db_fnp_eval_;  db_fnp_memory_.pl1 11/15/82 1816.2rew 11/15/82 1449.4 90864 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ db_fnp_memory_: proc; /* Parameters */ dcl arg_corep ptr; /* Address of fnp memory in a segment */ dcl arg_fnp fixed bin; /* The fnp number */ dcl arg_fnp_addr fixed bin; /* The fnp address to access */ dcl arg_fnp_len fixed bin; /* Length of data, in fnp words */ dcl arg_data_ptr ptr; /* Addr where data is to be stored */ dcl arg_code fixed bin (35); dcl arg_caller char (*); /* Name of caller, for command_query_ */ dcl arg_mode fixed bin; /* Options for store call - 0 = just patch, 1 = list changes and patch, 2 = list changes, ask if ok, then patch */ /* Automatic */ dcl corep ptr; dcl fnp fixed bin; dcl fnp_name char (1); dcl code fixed bin (35); dcl state fixed bin; dcl mode fixed bin; dcl i fixed bin; dcl data_ptr ptr; dcl fnp_addr fixed bin; dcl check_buf (32) bit (18) unal; /* Holds original copy */ dcl answer char (3) var; /* Reply from command_query_ */ dcl fnp_len fixed bin; /* Length of memory being moved */ dcl fnp_mem (fnp_len) bit (18) unal based; /* A piece of fnp memory */ dcl dir char (168); dcl ename char (32); dcl replace_acl bit (1); dcl save_modes bit (36); dcl 1 segment_acl (1) aligned, 2 access_name char (32), 2 modes bit (36), 2 zero_pad bit (36), 2 status_code fixed bin (35); dcl 1 delete_acl (1) aligned, 2 access_name char (32), 2 status_code fixed bin (35); dcl dump_seg (0:32767) bit (18) unal based (corep); /* Declaration of a dump */ dcl 1 fnp_info aligned, /* Data structure for dump/patch fnp */ 2 fnp_addr fixed bin, 2 fnp_len fixed bin, 2 data_ptr ptr, 2 prev_data_ptr ptr; /* Constants */ dcl 1 query_info aligned int static options (constant), /* For command_query_ */ 2 version fixed bin init (2), 2 yes_or_no bit (1) unal init ("1"b), 2 supp_name bit (1) unal init ("0"b), 2 pad bit (34) unal init ("0"b), 2 code1 fixed bin (35) init (0), 2 code2 fixed bin (35) init (0); /* Internal static */ dcl call_type fixed bin int static init (0); /* Says which kind of ring0 call to use */ dcl init_sw bit (1) int static init ("0"b); dcl crmem fixed bin int static; /* External stuff */ dcl phcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35)); dcl hphcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35)); dcl phcs_$tty_control entry (char (*), char (*), ptr, fixed bin (35)); dcl hphcs_$tty_control entry (char (*), char (*), ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl sub_err_ entry options (variable); dcl command_query_ entry options (variable); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl get_group_id_$tag_star entry returns (char (32)); dcl db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin); dcl get_fnp_name_ entry (fixed bin) returns (char (32)); dcl error_table_$bad_arg ext fixed bin (35); dcl error_table_$unimplemented_version ext fixed bin (35); dcl error_table_$moderr ext fixed bin (35); dcl error_table_$dev_offset_out_of_bounds ext fixed bin (35); dcl linkage_error condition; dcl no_write_permission condition; dcl (addr, min, null, substr) builtin; /* Entry to fetch fnp memory */ fetch: entry (arg_corep, arg_fnp, arg_fnp_addr, arg_fnp_len, arg_data_ptr, arg_code); corep = arg_corep; /* Get ptr to memory image (if in segment) */ fnp_addr = arg_fnp_addr; fnp_len = arg_fnp_len; if corep = null then do; /* Dumping a real fnp */ fnp = arg_fnp; fnp_name = get_fnp_name_ (fnp); fnp_info.fnp_addr = fnp_addr; fnp_info.fnp_len = arg_fnp_len; fnp_info.data_ptr = arg_data_ptr; fnp_info.prev_data_ptr = null; do while (fnp_len > 0); fnp_info.fnp_len = min (fnp_len, 64); retry_dump_call: if call_type = 0 then do; /* Haven't established which call yet */ on linkage_error go to call_1_failed; call phcs_$tty_order (fnp, "dump_fnp", addr (fnp_info), state, code); revert linkage_error; /* It worked */ call_type = 1; go to check_fetch_code; call_1_failed: on linkage_error go to call_2_failed; call phcs_$tty_control (fnp_name, "dump_fnp", addr (fnp_info), code); revert linkage_error; call_type = 2; go to check_fetch_code; call_2_failed: revert linkage_error; call sub_err_ (0, "db_fnp_memory_", "h", null (), (0), "No access to phcs_ gate; unable to read FNP memory."); go to retry_dump_call; end; else if call_type = 1 then call phcs_$tty_order (fnp, "dump_fnp", addr (fnp_info), state, code); else call phcs_$tty_control (fnp_name, "dump_fnp", addr (fnp_info), code); check_fetch_code: if code ^= 0 then go to fetch_return; fnp_info.fnp_addr = fnp_info.fnp_addr + fnp_info.fnp_len; /* Check next address */ fnp_info.data_ptr = addr (fnp_info.data_ptr -> fnp_mem (fnp_info.fnp_len + 1)); fnp_len = fnp_len - fnp_info.fnp_len; end; end; else do; /* Dumping from a segment */ call check_bounds; if code ^= 0 then go to fetch_return; arg_data_ptr -> fnp_mem = addr (dump_seg (arg_fnp_addr)) -> fnp_mem; code = 0; end; fetch_return: arg_code = code; return; /* Entry to store into FNP memory */ store: entry (arg_corep, arg_fnp, arg_fnp_addr, arg_fnp_len, arg_data_ptr, arg_caller, arg_mode, arg_code); corep = arg_corep; fnp = arg_fnp; fnp_addr = arg_fnp_addr; fnp_len = arg_fnp_len; mode = arg_mode; data_ptr = arg_data_ptr; if fnp_len < 1 | fnp_len > 32 then do; code = error_table_$bad_arg; go to store_return; end; call fetch (corep, fnp, fnp_addr, fnp_len, addr (check_buf), code); /* Get old values */ if code ^= 0 then go to store_return; if mode ^= 0 then do; /* If reporting needed */ do i = 1 to fnp_len; call ioa_ ("^6w ^.3b to ^.3b", fnp_addr + i - 1, check_buf (i), data_ptr -> fnp_mem (i)); end; if mode = 2 then do; /* Must ask for verification */ call command_query_ (addr (query_info), answer, arg_caller, "Correct?"); if answer ^= "yes" then do; code = 0; go to store_return; end; end; end; if corep ^= null then do; /* Patching a segment */ on no_write_permission go to force_access; addr (dump_seg (fnp_addr)) -> fnp_mem = data_ptr -> fnp_mem; revert no_write_permission; code = 0; go to store_return; force_access: revert no_write_permission; call hcs_$fs_get_path_name (corep, dir, (0), ename, code); /* Get seg name, needed for acl primitives */ if code ^= 0 then go to store_return; segment_acl.access_name (1) = get_group_id_$tag_star (); /* Get my current acl entry */ segment_acl.zero_pad (1) = "0"b; call hcs_$list_acl (dir, ename, null (), (null ()), addr (segment_acl), (1), code); if code ^= 0 then go to store_return; if segment_acl.status_code (1) = 0 then do; /* I did have an entry */ save_modes = segment_acl.modes (1); /* Save them */ replace_acl = "1"b; /* Remember to put them back */ end; else replace_acl = "0"b; /* No acl to replace */ segment_acl.modes (1) = "101"b; /* Give rw access to me */ segment_acl.zero_pad (1) = "0"b; call hcs_$add_acl_entries (dir, ename, addr (segment_acl), 1, code); if code ^= 0 then go to store_return; on no_write_permission begin; /* Ready to begin, but be careful */ code = error_table_$moderr; go to cleanup_acl; end; addr (dump_seg (fnp_addr)) -> fnp_mem = data_ptr -> fnp_mem; /* Try again */ code = 0; /* It worked */ cleanup_acl: revert no_write_permission; if replace_acl then do; /* Put back old access */ segment_acl.modes (1) = save_modes; segment_acl.zero_pad (1) = "0"b; call hcs_$add_acl_entries (dir, ename, addr (segment_acl), 1, (0)); end; else do; delete_acl.access_name (1) = segment_acl.access_name (1); call hcs_$delete_acl_entries (dir, ename, addr (delete_acl), 1, (0)); end; end; else do; /* Patching a real FNP */ fnp_name = get_fnp_name_ (fnp); fnp_info.fnp_addr = fnp_addr; fnp_info.fnp_len = fnp_len; fnp_info.data_ptr = data_ptr; fnp_info.prev_data_ptr = addr (check_buf); if call_type = 1 then call hphcs_$tty_order (fnp, "patch_fnp", addr (fnp_info), state, code); else if call_type = 2 then call hphcs_$tty_control (fnp_name, "patch_fnp", addr (fnp_info), code); else code = error_table_$unimplemented_version; /* Can't happen */ end; store_return: arg_code = code; return; /* Internal procedure to check that an address and length is valid. This is only used for accesses to segments */ check_bounds: proc; dcl n fixed bin (18); if ^init_sw then do; crmem = db_fnp_sym_util_$get_value (".crmem"); init_sw = "1"b; end; if fnp_addr < 0 | fnp_len <= 0 then do; code = error_table_$bad_arg; return; end; n = bin (dump_seg (crmem), 18); if n < 32767 | mod (n+1, 32768) ^= 0 then n = 262143; /* Assume 256k for clobbered seg */ if fnp_addr > n | (fnp_addr + fnp_len - 1) > n then do; code = error_table_$dev_offset_out_of_bounds; return; end; code = 0; return; end check_bounds; end db_fnp_memory_;  db_fnp_opblock_util_.pl1 11/15/82 1816.2rew 11/15/82 1502.0 36036 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_OPBLOCK_UTIL_ - Procedure to display fnp memory in opblock format */ /* Written March 1977 by Larry Johnson */ db_fnp_opblock_util_: proc; /* Parameters */ dcl arg_corep ptr; /* Pointer to segment contining core image */ dcl arg_fnp fixed bin; /* Number of a running fnp */ dcl arg_fnp_addr fixed bin; /* The starting address being displayed */ dcl arg_fnp_len fixed bin; /* The number of words */ dcl arg_data_ptr ptr; /* Pointer to the words to display */ dcl arg_code fixed bin (35); dcl arg_opname char (*); dcl arg_opval bit (18); /* Automatic */ dcl corep ptr; dcl fnp fixed bin; dcl fnp_addr fixed bin; dcl fnp_len fixed bin; dcl data_ptr ptr; dcl code fixed bin (35); dcl i fixed bin; dcl edited_addr char (32) var; dcl opblock_addr char (32) var; dcl opval bit (18); dcl opname char (6); dcl fnp_mem (fnp_len) bit (18) unal based (data_ptr); /* External stuff */ dcl ioa_ entry options (variable); dcl db_fnp_util_$edit_module_addr entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35)); dcl error_table_$noentry ext fixed bin (35); dcl (addr, bin, bit, hbound, lbound, rtrim, substr) builtin; /* Entry to display memory in opblock format */ display: entry (arg_corep, arg_fnp, arg_fnp_addr, arg_fnp_len, arg_data_ptr, arg_code); corep = arg_corep; fnp = arg_fnp; fnp_addr = arg_fnp_addr; fnp_len = arg_fnp_len; data_ptr = arg_data_ptr; opblock_tablep = addr (db_fnp_opblocks_$); /* Loop thru all the words */ do i = 1 to fnp_len; if substr (fnp_mem (i), 1, 9) = "777"b3 then do; call get_name (fnp_mem (i), opname); edited_addr = rtrim (opname); end; else do; call db_fnp_util_$edit_module_addr (corep, fnp, bin (fnp_mem (i)), edited_addr, code); if code ^= 0 then edited_addr = ""; else edited_addr = " " || edited_addr; end; call db_fnp_util_$edit_module_addr (corep, fnp, fnp_addr, opblock_addr, code); if code ^= 0 then opblock_addr = ""; call ioa_ ("^5w ^13a ^.3b ^a", fnp_addr, opblock_addr, fnp_mem (i), edited_addr); fnp_addr = fnp_addr + 1; end; arg_code = 0; return; /* Entry to lookup a symbol and returns its value as an opblock number */ lookup: entry (arg_opname, arg_opval, arg_code); opblock_tablep = addr (db_fnp_opblocks_$); do i = lbound (opblock_table.name, 1) to hbound (opblock_table.name, 1); if opblock_table.name (i) = arg_opname then do; substr (opval, 1, 9) = "777"b3; substr (opval, 10, 9) = bit (bin (i, 9), 9); arg_opval = opval; arg_code = 0; return; end; end; arg_opval = "0"b; arg_code = error_table_$noentry; return; /* Entry that given an opblock, returns its name */ get_name: entry (arg_opval, arg_opname); opval = arg_opval; arg_opname = ""; opblock_tablep = addr (db_fnp_opblocks_$); if substr (opval, 1, 9) ^= "777"b3 then return; i = bin (substr (opval, 10, 9)); if i < lbound (opblock_table.name, 1) | i > hbound (opblock_table.name, 1) then return; arg_opname = opblock_table.name (i); return; /* Debugging entry that will print the opblock table. This is just used as a command to check that the procedure that constructs the table works */ /* This entry is not retained. */ print_table: entry; opblock_tablep = addr (db_fnp_opblocks_$); do i = lbound (opblock_table.name, 1) to hbound (opblock_table.name, 1); call ioa_ ("^2o ^a", i, opblock_table.name (i)); end; return; %include debug_fnp_data; end db_fnp_opblock_util_;  db_fnp_opblocks_.cds 11/15/82 1816.2rew 11/15/82 1535.7 73548 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_OPBLOCKS_ - Procedure to create a table of interpreter opblock names */ /* The table is constructed by scanning the macros.map355 source file */ /* Written March 1977 by Larry Johnson */ /* Modified by R Holmstedt to use the new library >ldd>mcs. */ db_fnp_opblocks_: proc; /* Automatic */ dcl segp ptr; /* Pointer to entire macro segment */ dcl segl fixed bin; /* Its length */ dcl restp ptr; /* Pointer to unscanned (rest of) segment */ dcl restl fixed bin; /* Its length */ dcl max_cnt fixed bin; /* Max number of opblocks found */ dcl i fixed bin; dcl opname char (6); dcl ptr_array (1) ptr; /* For get_temp_segments_ */ dcl linep ptr; /* Pointer to current line */ dcl linel fixed bin; /* Its length */ dcl code fixed bin (35); dcl bit_count fixed bin (24); dcl dir char (168); dcl 1 cds like cds_args automatic; dcl line char (linel) based (linep); dcl rest char (restl) based (restp); /* Constants */ dcl white_space char (2) int static options (constant) init (" "); /* Space and tab */ dcl nl char (1) int static options (constant) init (" "); dcl name char (16) int static options (constant) init ("db_fnp_opblocks_"); dcl exclude_all char (32) int static options (constant) init ("**"); dcl macro_name char (13) int static options (constant) init ("macros.map355"); /* External stuff */ dcl com_err_ entry options (variable); dcl ioa_ entry options (variable); dcl cv_oct_ entry (char (*)) returns (fixed bin (35)); dcl get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl get_wdir_ entry returns (char (168)); dcl create_data_segment_ entry (ptr, fixed bin (35)); dcl error_table_$noentry ext fixed bin (35); dcl cleanup condition; dcl (addr, divide, index, max, null, search, size, string, substr, verify) builtin; /* Initialization */ ptr_array = null; segp = null; on cleanup call clean_up; call init_macro_seg; /* This locates the macro segment */ hunt_opstart: /* Must find the line *++opstart */ call get_line; if linep = null then do; /* End of file */ call com_err_ (0, name, "No *++opstart statement in ^a^[>^]^a", dir, dir ^= ">", macro_name); go to done; end; if linel < 10 then go to hunt_opstart; if substr (line, 1, 10) ^= "*++opstart" then go to hunt_opstart; /* Found start of opblock section */ call get_temp_segments_ (name, ptr_array, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to get temp segment"); go to done; end; opblock_tablep = ptr_array (1); max_cnt = -1; /* Now scan for maccros */ hunt_macro: call get_line; if linep = null then go to done_scan; /* End of segment */ if substr (line, 1, 1) = "*" then go to hunt_macro; /* Skip comments */ i = search (line, white_space); /* Find first white space */ if (i = 0) | (i = 1) then go to hunt_macro; /* Ignore lines with no label, or no white space */ opname = substr (line, 1, i-1); /* Save label */ call adv_line (i); /* Skip over label */ call skip_white_space; /* And any trailing white space */ i = search (line, white_space); /* Look for end of opcode */ if i = 0 then i = linel; else i = i-1; if i ^= 5 then go to hunt_macro; /* Cant be "macro" */ if substr (line, 1, 5) ^= "macro" then go to hunt_macro; /* Found start of a macro */ call get_line; /* Read next line */ if linep = null then go to done_scan; call skip_white_space; if linel < 3 then go to hunt_macro; /* Too short to say "oct" */ if substr (line, 1, 3) ^= "oct" then go to hunt_macro; call adv_line (3); call skip_white_space; if linel < 6 then go to hunt_macro; /* Too short to say 777*** */ if substr (line, 1, 3) ^= "777" then go to hunt_macro; if verify (substr (line, 4, 3), "01234567") ^= 0 then go to hunt_macro; /* A real opblock macro was found */ call store (opname, cv_oct_ (substr (line, 4, 3))); go to hunt_macro; /* Back for next */ /* Come here at end of segment */ done_scan: if max_cnt = -1 then do; call com_err_ (0, name, "No opblocks defined in ^a^[>^]^a", dir, dir ^= ">", macro_name); go to done; end; /* Now create the data segment */ cds.p (1) = opblock_tablep; cds.len (1) = size (opblock_table); cds.struct_name (1) = "opblock_table"; cds.p (2) = null; cds.len (2) = 0; cds.struct_name (2) = ""; cds.seg_name = name; cds.num_exclude_names = 1; cds.exclude_array_ptr = addr (exclude_all); string (cds.switches) = "0"b; cds.have_text = "1"b; call create_data_segment_ (addr (cds), code); if code ^= 0 then call com_err_ (code, name, "From create_data_segment_"); done: call clean_up; return; /* Procedure to initiate the macro source segment. It looks first in the working directory, then in >ldd>mcs>info */ init_macro_seg: proc; dir = get_wdir_ (); call hcs_$initiate_count (dir, macro_name, "", bit_count, 0, segp, code); if segp = null then do; if code ^= error_table_$noentry then do; macro_seg_err: call com_err_ (code, name, "^a^[>^]^a", dir, dir ^= ">", macro_name); go to done; end; dir = ">ldd>mcs>info"; /* Try library */ call hcs_$initiate_count (dir, macro_name, "", bit_count, 0, segp, code); if segp = null then go to macro_seg_err; end; call ioa_ ("^a: Using ^a^[>^]^a", name, dir, (dir ^= ">"), macro_name); segl = divide (bit_count, 9, 17, 0); restp = segp; restl = segl; return; end init_macro_seg; /* Procedure to isolate the next line in the source */ get_line: proc; dcl i fixed bin; get_next_line: if restl = 0 then do; /* End of file */ linep = null; return; end; i = index (rest, nl); if i = 0 then i, linel = restl; /* No more newlines */ else linel = i-1; linep = restp; restp = substraddr (rest, i+1); restl = restl - i; if linel = 0 then go to get_next_line; /* Ignor empty lines */ return; end get_line; /* Procedure called while pasring line to move pointer down the line */ adv_line: proc (n); dcl n fixed bin; /* How far too move */ linep = substraddr (line, n+1); linel = linel - n; return; end adv_line; /* Procedure to skip over any white space */ skip_white_space: proc; dcl i fixed bin; i = verify (line, white_space); /* Count white space charactrs */ if i = 0 then i = linel; /* All white line */ else i = i - 1; call adv_line (i); return; end skip_white_space; /* Procedure to store a new entry in the table */ store: proc (opn, n); dcl opn char (6); /* Name of block */ dcl n fixed bin; /* Its number */ dcl i fixed bin; do i = (max_cnt + 1) to (n - 1); /* Fill in any skipped entries */ opblock_table.name (i) = "**??**"; end; opblock_table.name (n) = opn; max_cnt = max (max_cnt, n); opblock_table.cnt = max_cnt; return; end store; /* Cleanup handler */ clean_up: proc; if segp ^= null then call hcs_$terminate_noname (segp, code); if ptr_array (1) ^= null then call release_temp_segments_ (name, ptr_array, code); return; end clean_up; /* Simulate substraddr builtin temporarily */ substraddr: proc (c, n) returns (ptr); dcl c char (*); dcl n fixed bin; dcl ca (n) char (1) unal based (addr (c)); return (addr (ca (n))); end substraddr; %include debug_fnp_data; %include cds_args; end db_fnp_opblocks_;  db_fnp_opcodes_.cds 11/15/82 1816.2rew 11/15/82 1535.9 62847 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_OPCODES_ - Procedure that defines a table of FNP opcodes */ /* Written February 1977 by Larry Johnson */ db_fnp_opcodes_: proc; /* Automatic */ dcl code fixed bin (35); dcl ptr_array (1) ptr; dcl 1 cds like cds_args automatic; /* Constants */ dcl name char (15) int static options (constant) init ("db_fnp_opcodes_"); dcl exclude_all char (32) int static options (constant) init ("**"); /* External */ dcl get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl create_data_segment_ entry (ptr, fixed bin (35)); dcl com_err_ entry options (variable); dcl cv_oct_ entry (char (*)) returns (fixed bin (35)); dcl (addr, null, translate) builtin; dcl cleanup condition; /* Setup temp segment */ ptr_array = null; on cleanup call clean_up; call get_temp_segments_ (name, ptr_array, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to get temp segment."); return; end; /* Fill the opcode table */ optablep = ptr_array (1); optable.cnt = 0; call build_table; /* Now create the data segment */ cds.p (1) = optablep; cds.len (1) = size (optable); cds.struct_name (1) = "optable"; cds.p (2) = null; cds.len (2) = 0; cds.struct_name (2) = ""; cds.seg_name = name; cds.num_exclude_names = 1; cds.exclude_array_ptr = addr (exclude_all); string (cds.switches) = "0"b; cds.have_text = "1"b; call create_data_segment_ (addr (cds), code); if code ^= 0 then call com_err_ (name, code); call clean_up; return; /* Procedure to fill the opcode table */ build_table: proc; call store (0, "ada ", "X06X"); call store (0, "adcx1 ", "X42X"); call store (0, "adcx2 ", "X02X"); call store (0, "adcx3 ", "X40X"); call store (0, "adq ", "X46X"); call store (0, "ana ", "X34X"); call store (0, "ansa ", "X32X"); call store (0, "aos ", "X76X"); call store (0, "asa ", "X16X"); call store (0, "cana ", "X31X"); call store (0, "cioc ", "X60X"); call store (0, "cmpa ", "X27X"); call store (0, "cmpq ", "X67X"); call store (0, "cmpx1 ", "X63X"); call store (0, "cmpx2 ", "X23X"); call store (0, "cmpx3 ", "X61X"); call store (0, "dvf ", "X21X"); call store (0, "era ", "X35X"); call store (0, "ersa ", "X62X"); call store (0, "lda ", "X07X"); call store (0, "ldex ", "X30X"); call store (0, "ldi ", "X44X"); call store (0, "ldq ", "X47X"); call store (0, "ldx1 ", "X43X"); call store (0, "ldx2 ", "X03X"); call store (0, "ldx3 ", "X41X"); call store (0, "mpf ", "X01X"); call store (0, "ora ", "X37X"); call store (0, "orsa ", "X72X"); call store (0, "sba ", "X26X"); call store (0, "sbq ", "X66X"); call store (0, "ssa ", "X36X"); call store (0, "sta ", "X17X"); call store (0, "stex ", "X70X"); call store (0, "sti ", "X54X"); call store (0, "stq ", "X57X"); call store (0, "stx1 ", "X53X"); call store (0, "stx2 ", "X13X"); call store (0, "stx3 ", "X50X"); call store (0, "stz ", "X56X"); call store (0, "szn ", "X20X"); call store (0, "tmi ", "X75X"); call store (0, "tnc ", "X45X"); call store (0, "tnz ", "X64X"); call store (0, "tov ", "X55X"); call store (0, "tpl ", "X65X"); call store (0, "tra ", "X71X"); call store (0, "tsy ", "X10X"); call store (0, "tze ", "X74X"); call store (0, "adaq ", "X15X"); call store (0, "ldaq ", "X04X"); call store (0, "sbaq ", "X24X"); call store (0, "staq ", "X14X"); call store (1, "iaa ", "773X"); call store (2, "iacx1 ", "173X"); call store (2, "iacx2 ", "273X"); call store (2, "iacx3 ", "373X"); call store (1, "iana ", "022X"); call store (1, "iaq ", "573X"); call store (1, "icana ", "222X"); call store (1, "icmpa ", "422X"); call store (1, "iera ", "322X"); call store (1, "ila ", "673X"); call store (1, "ilq ", "473X"); call store (1, "iora ", "122X"); call store (1, "sel ", "073X"); call store (1, "rier ", "012X"); call store (1, "ria ", "412X"); call store (1, "sier ", "052X"); call store (1, "sic ", "452X"); call store (3, "alp ", "3336"); call store (3, "alr ", "2336"); call store (3, "als ", "0336"); call store (3, "arl ", "2337"); call store (3, "ars ", "0337"); call store (3, "llr ", "2334"); call store (3, "lls ", "0334"); call store (3, "lrl ", "2335"); call store (3, "lrs ", "0335"); call store (3, "qlp ", "7336"); call store (3, "qlr ", "6336"); call store (3, "qls ", "4336"); call store (3, "qrl ", "6337"); call store (3, "qrs ", "4337"); call store (4, "caq ", "6333"); call store (4, "cax1 ", "4332"); call store (4, "cax2 ", "0332"); call store (4, "cax3 ", "4333"); call store (4, "cqa ", "7333"); call store (4, "cx1a ", "2332"); call store (4, "cx2a ", "3332"); call store (4, "cx3a ", "3333"); call store (4, "dis ", "4331"); call store (4, "eni ", "7331"); call store (4, "inh ", "3331"); call store (4, "nop ", "2331"); call store (4, "nrm ", "1336"); call store (4, "nrml ", "1334"); return; end build_table; /* Procedure to put one entry in the table */ store: proc (n, name, code); dcl n fixed bin; /* Opcode type */ dcl name char (6); /* Name of opcode */ dcl code char (4); /* Opcode - X means dont care */ dcl temp char (4); optable.cnt = optable.cnt + 1; opp = addr (optable.entry (optable.cnt)); op.name = name; op.type = n; temp = translate (code, "0", "X"); /* Replace xes by zeroes to get opcode */ op.code = bit (bin (cv_oct_ (temp), 12), 12); temp = translate (code, "077777777", "X01234567"); /* Get mask for finding opcode */ op.mask = bit (bin (cv_oct_ (temp), 12), 12); return; end store; clean_up: proc; if ptr_array (1) ^= null then call release_temp_segments_ (name, ptr_array, code); return; end clean_up; %include debug_fnp_data; %include cds_args; end db_fnp_opcodes_;  db_fnp_reader_.pl1 11/15/82 1816.2rew 11/15/82 1502.1 84159 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_READER_ - Contains entries for reading and parsing debug_fnp commands */ /* Written February 1977 by Larry Johnson */ /* Rewritten January 1978 by Larry Johnson to support multiple commands on a line */ db_fnp_reader_: proc; /* Arguments */ dcl arg_cmd_infop ptr; /* Pointer to command data */ /* Automatic */ dcl code fixed bin (35); dcl inlen fixed bin (21); dcl i fixed bin; dcl have_cmd_start bit (1); dcl next_char char (1) based (cmd_info.commandp); /* Constants */ dcl name char (14) int static options (constant) init ("db_fnp_reader_"); dcl nl char (1) int static options (constant) init (" "); /* External stuff */ dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl sub_err_ entry options (variable); dcl ioa_ entry options (variable); dcl iox_$user_input ext ptr; dcl (addr, index, length, null, search, substr, verify) builtin; /* Entry to read command line */ get_command: entry (arg_cmd_infop); cmd_infop = arg_cmd_infop; have_cmd_start = "0"b; get_command_retry: cmd_info.endline, cmd_info.error, cmd_info.opstring = "0"b; /* Find first character in command name */ get_command_startx: go to get_command_start (next_char_type ()); get_command_start (0): /* Data char */ if have_cmd_start then go to get_command_name; /* Good start */ get_command_start (4): /* White space */ call skip_char; /* Flush till command starts */ go to get_command_startx; get_command_start (1): /* Quote */ get_command_start (2): /* Apostrophe */ go to bad_command_char; /* These are invalid */ get_command_start (3): /* Semi-colon */ call skip_char; have_cmd_start = "1"b; /* Next char will start command name */ go to get_command_startx; get_command_start (5): /* End of line */ call iox_$get_line (iox_$user_input, addr (cmd_info.inbuf), length (cmd_info.inbuf), inlen, code); if code ^= 0 then do; cmd_info.flush = "1"b; call sub_err_ (code, name, "h", null, (0), "Unable to read from user_input"); go to get_command_retry; end; if inlen > 0 then if substr (cmd_info.inbuf, inlen, 1) = nl then inlen = inlen - 1; cmd_info.commandp = addr (cmd_info.inbuf); /* Start new command scan */ cmd_info.commandl = inlen; have_cmd_start = "1"b; /* Next char can start command */ cmd_info.flush = "0"b; go to get_command_startx; /* Count characters in command name */ get_command_name: cmd_info.operandp = cmd_info.commandp; /* Start of name */ cmd_info.operandl = 0; get_command_charx: go to get_command_char (next_char_type ()); get_command_char (0): /* Data char */ cmd_info.operandl = cmd_info.operandl + 1; /* Include in name */ call skip_char; if cmd_info.operandl = 1 then /* If first character */ if operand = "=" then return; /* Don't required whitespace after '=' command */ go to get_command_charx; get_command_char (1): /* Quote */ get_command_char (2): /* Apostrophe */ go to bad_command_char; get_command_char (3): /* Semi-colon */ get_command_char (4): /* White space */ get_command_char (5): /* End of line */ if cmd_info.operandl = 0 then go to get_command_retry; /* Start all over if null command */ else return; /* Otherwise command name is now found */ bad_command_char: call ioa_ ("Invalid ^a in command name.", next_char); cmd_info.flush = "1"b; go to get_command_retry; /* Entry to get one operand from command line */ get_operand: entry (arg_cmd_infop); cmd_infop = arg_cmd_infop; cmd_info.opstring, cmd_info.endline, cmd_info.error = "0"b; cmd_info.operandp = null; cmd_info.operandl = 0; /* Find start of an operand */ get_operand_startx: go to get_operand_start (next_char_type ()); get_operand_start (0): /* Data char */ cmd_info.operandp = cmd_info.commandp; /* Operand starts here */ go to get_operand_charx; get_operand_start (1): /* Quote */ go to get_operand_quote; /* Handel quoted operand */ get_operand_start (2): /* Apostrophe */ go to get_operand_apost; /* Handle apostrophed operand */ get_operand_start (3): /* Semi-colon */ get_operand_start (5): /* End of line */ cmd_info.endline = "1"b; /* No more operands */ return; get_operand_start (4): /* White space */ call skip_char; go to get_operand_startx; /* Keep looking */ /* Regular vanilla operand. count its characters */ get_operand_charx: go to get_operand_char (next_char_type ()); get_operand_char (0): /* Data char */ cmd_info.operandl = cmd_info.operandl + 1; /* Operand 1 longer */ call skip_char; go to get_operand_charx; get_operand_char (1): /* Quote */ get_operand_char (2): /* Apostrophe */ call ioa_ ("Invalid ^a in middle of operand", next_char); go to operand_err; get_operand_char (3): /* Semi colon */ get_operand_char (4): /* White space */ get_operand_char (5): /* End of line */ return; /* All indicate end of operand */ /* Here when operand starts with quuote. A dequoted version is reconstructed. */ get_operand_quote: cmd_info.operandp = addr (cmd_info.opbuf); /* Will build unquoted string here */ cmd_info.opstring = "1"b; call skip_char; get_quote_charx: go to get_quote_char (next_char_type ()); get_quote_char (0): /* Data char */ get_quote_char (2): /* Apostrophe */ get_quote_char (3): /* Semi colon */ get_quote_char (4): /* White space */ cmd_info.operandl = cmd_info.operandl + 1; /* All are operand characters */ substr (operand, cmd_info.operandl, 1) = next_char; call skip_char; go to get_quote_charx; get_quote_char (5): /* End of line */ call ioa_ ("Unmatched quotes"); go to operand_err; get_quote_char (1): /* Quote */ call skip_char; /* May be double quote or end of string */ /* Be sure quoted string terminates correctly */ go to char_after_quote (next_char_type ()); char_after_quote (0): /* Data char */ char_after_quote (2): /* Apostrophe */ call ioa_ ("Invalid ^a after quoted string", next_char); go to operand_err; char_after_quote (1): /* Quote */ go to get_quote_char (0); /* Treat as quote data char */ char_after_quote (3): /* Semi colon */ char_after_quote (4): /* White space */ char_after_quote (5): /* End of line */ return; /* All are valid end of quoted string */ /* Here when operand starts with apostrophe. count its characters */ get_operand_apost: cmd_info.operandl = 1; /* Include apostrophe in operand */ cmd_info.operandp = cmd_info.commandp; call skip_char; get_apost_charx: go to get_apost_char (next_char_type ()); get_apost_char (0): /* Data char */ get_apost_char (4): /* White space */ cmd_info.operandl = cmd_info.operandl + 1; /* Treat as data */ call skip_char; go to get_apost_charx; get_apost_char (1): /* Quote */ get_apost_char (3): /* Semi colon */ call ioa_ ("Invalid ^a in apostrophed string", next_char); go to operand_err; get_apost_char (5): /* End of line */ call ioa_ ("Unmatched apostrophes"); go to operand_err; get_apost_char (2): /* Should be closing apostrophe */ cmd_info.operandl = cmd_info.operandl + 1; call skip_char; /* Be sure qpostrophed string ends correctly */ go to char_after_apost (next_char_type ()); char_after_apost (0): /* Data char */ char_after_apost (1): /* Quote */ char_after_apost (2): /* Apostrophe */ call ioa_ ("Invalid ^a after apostrophed string", next_char); go to operand_err; char_after_apost (3): /* Sime colon */ char_after_apost (4): /* White space */ char_after_apost (5): /* End of line */ return; /* All valid ends of apostrophed operand */ /* Here when some error deteched in the operand */ operand_err: cmd_info.error = "1"b; cmd_info.flush = "1"b; return; /* Function which returns a code indicating the type of the next character on the command line */ /* Codes are: 0 = data character 1 = quote 2 = apostrophe 3 = semi-colon 4 = white space 5 = end of line */ next_char_type: proc returns (fixed bin); if cmd_info.flush then return (5); /* End of line */ if cmd_info.commandl = 0 then return (5); if next_char = """" then return (1); if next_char = "'" then return (2); if next_char = ";" then return (3); if next_char = " " | next_char = " " | next_char = nl then return (4); if unspec (next_char) = "014"b3 then return (4); return (0); /* Must be data */ end next_char_type; /* Skip next char in input stream */ skip_char: proc; cmd_info.commandp = substraddr (command, 2); cmd_info.commandl = cmd_info.commandl - 1; return; end skip_char; /* Simulate substraddr builtin temporarily */ substraddr: proc (c, n) returns (ptr); dcl c char (*); dcl n fixed bin; dcl ca (n) char (1) unal based (addr (c)); return (addr (ca (n))); end substraddr; %include debug_fnp_data; end db_fnp_reader_;  db_fnp_scheduler_.pl1 11/15/82 1816.2rew 11/15/82 1449.4 218736 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_SCHEDULER_ - Implements various command related to the scheduler */ /* Written January 1979 by Larry Johnson */ /* Modified December 1981 by Robert Coren for revised idle meters */ /* Modified March 1982 by Robert Coren to add meters for time spent in buffer management */ /* format: style4,delnl,insnl,^ifthendo */ db_fnp_scheduler_: proc; /* Parameters */ dcl arg_corep ptr; dcl arg_fnp fixed bin; dcl arg_expr_infop ptr; dcl arg_cmd_infop ptr; dcl arg_code fixed bin (35); /* Automatic */ dcl corep ptr; dcl fnp fixed bin; dcl theoretical_max fixed bin (35); dcl x float bin; dcl total_count fixed bin (71); dcl (i, j) fixed bin; dcl min_j fixed bin; dcl mix_offset fixed bin; dcl offset fixed bin; dcl module_counts (50) fixed bin (71); dcl icmdat_addr fixed bin; dcl icmdat_addr_known bit (1) init ("0"b); dcl skdata_addr fixed bin; dcl code fixed bin (35); dcl buf_meter_addr fixed bin; dcl data_high fixed bin; dcl datap ptr init (null); dcl table_base fixed bin; dcl table_mult fixed bin; dcl min_offset fixed bin; dcl ic_addr fixed bin; dcl line_length fixed bin; dcl hist_len fixed bin; dcl max_hits fixed bin (35); dcl scale float bin; dcl edited_addr char (32) var; dcl fraction_to_print float bin; dcl hits_removed fixed bin (71); dcl hits_to_remove fixed bin (71); dcl min_hits fixed bin (35); dcl n_min_hits fixed bin; dcl fnp_word (1) fixed bin (17) unal; dcl something_printed bit (1); dcl first_exec_found bit (1); dcl dsptabp ptr; dcl savtabp ptr; dcl skdata_count fixed bin; dcl sched_dsptabp ptr init (null); dcl sched_savtabp ptr init (null); dcl reset_sw bit (1); dcl delta_cycles fixed bin (35); dcl delta_idle_count fixed bin (35); dcl alloc_time fixed bin (35); dcl alloc_updates fixed bin (35); dcl alloc_more_than_1 fixed bin (35); dcl free_time fixed bin (35); dcl free_updates fixed bin (35); dcl free_more_than_1 fixed bin (35); dcl total_time fixed bin (35); dcl avg_alloc_time float bin; dcl avg_free_time float bin; dcl avg_all_time float bin; dcl pct_alloc float bin; dcl pct_free float bin; dcl pct_alloc_non_idle float bin; dcl pct_free_non_idle float bin; dcl idle_fraction float bin; dcl 1 modch aligned, 2 nmodules fixed bin, 2 entries (50), 3 name char (4), 3 address fixed bin; dcl 1 skdata, /* Format of data block in scheduler, pointed to by .crskd */ 2 total_idle_count bit (36), /* Cumulative total of idle count */ 2 idle_increments bit (36), /* Number of increments to idle counter */ 2 max_idle_count bit (36), /* Maximum value of idle counter */ 2 min_idle_count bit (36), /* Minimum value of idle counter */ 2 interval bit (18), /* Number of millisecond to start timer with */ 2 icmdat_addr bit (18), /* Address of icmdat in ic_sampler module */ 2 count bit (18), /* Number of master dispatcher levels */ 2 dsptab_addr bit (18), /* Address of master dispatcher table */ 2 savtab_addr bit (18); /* Address of master dispatcher save area */ dcl 1 icmdat, /* Format of data block in ic_sampler */ 2 action bit (18), /* Set code here to request action */ 2 confirm bit (18), /* Result of action reported here */ 2 enable bit (18), /* If non-zero, ic_sampling enabled */ 2 table_addr bit (18), /* Address of table of results */ 2 table_len bit (18), /* Length of table in words */ 2 shift bit (18), /* Amount addresses are shifted before counting */ 2 base bit (18), /* Lowest address monitored */ 2 pad bit (18), 2 out_of_range bit (36), /* Count of ic's out of bucket range */ 2 discnt bit (36); /* Count of ic's and scheduler dis instruction */ dcl 1 buf_meters aligned, 2 allocate like subr_time_meters, 2 free like subr_time_meters; /* Based */ dcl system_area area based (areap); dcl data (0:data_high) bit (36) based (datap); dcl 1 sched_dsptab unal based (sched_dsptabp), /* Master dispatchers control table */ 2 dsptab (skdata_count) unal like dsptab; dcl 1 dsptab unal based (dsptabp), 2 request bit (1), /* Level requested to run */ 2 execution bit (1), /* Level in execution, or interrupted */ 2 secondary_entry_present bit (1), 2 suppression bit (15), 2 primary_entry bit (18), 2 secondary_entry bit (18), 2 request_count bit (18); dcl 1 sched_savtab unal based (sched_savtabp), /* Master dispatchers register save area */ 2 savtab (skdata_count) unal like savtab; dcl 1 savtab unal based (savtabp), 2 x1 bit (18), 2 x2 bit (18), 2 x3 bit (18), 2 a bit (18), 2 q bit (18), 2 ind bit (18), 2 ic bit (18), 2 pad bit (18); dcl 1 subr_time_meters based aligned, 2 total_time fixed bin (35), 2 increments fixed bin (35), 2 instances_over_1 fixed bin (35), 2 maximum_time fixed bin; /* External */ dcl ioa_ entry options (variable); dcl com_err_ entry options (variable); dcl sub_err_ entry options (variable); dcl get_system_free_area_ entry returns (ptr); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin); dcl db_fnp_util_$get_special_modch entry (ptr, fixed bin, ptr, fixed bin (35)); dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl db_fnp_memory_$store entry (ptr, fixed bin, fixed bin, fixed bin, ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_reader_$get_operand entry (ptr); dcl db_fnp_util_$edit_module_addr_force entry (ptr, fixed bin, fixed bin, char (*) var, fixed bin (35)); dcl iox_$user_output ext ptr; dcl error_table_$unimplemented_version ext fixed bin (35); dcl cleanup condition; dcl conversion condition; dcl (addr, bin, bit, divide, fixed, float, hbound, lbound, length, max, min, null, string) builtin; /* Static */ dcl crskd fixed bin int static; dcl crbtm fixed bin int static; dcl etmb fixed bin int static; dcl areap ptr int static init (null); dcl constants_setup bit (1) int static init ("0"b); dcl saved_idle_increments (8) fixed bin (35) int static init ((8) 0); dcl saved_idle_count (8) fixed bin (35) int static init ((8) 0); dcl 1 saved_buf_meters (8) aligned internal static like buf_meters; /* Constants */ dcl name char (17) int static options (constant) init ("db_fnp_scheduler_"); dcl mdisp_desc (7) char (20) int static options (constant) init ( /* Names of master dispatcher levels */ "lsla", "dia terminate", "dia special", "hsla", "interval timer", "console", "secondary dispatcher"); dcl state_msgs (0:7) char (32) int static options (constant) init ( /* State descriptions derived from some bits */ /* Req exec first_exec_fnd */ "", /* 0 0 0 */ "", /* 0 0 1 */ "In execution", /* 0 1 0 */ "Interrupt", /* 0 1 1 */ "Requested", /* 1 0 0 */ "Requested", /* 1 0 1 */ "Requested, in execution", /* 1 1 0 */ "Requested, interrupted"); /* 1 1 1 */ /* Entry to read and print the idle time accumulated in the fnp */ idle_time: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call get_operand; if cmd_info.endline then reset_sw = "0"b; else if operand = "-reset" | operand = "-rs" then do; if corep ^= null () then do; call ioa_ ("Option -reset only allowed on running FNP."); go to error_return; end; reset_sw = "1"b; end; else do; call ioa_ ("Invalid operand: ^a", operand); go to error_return; end; call read_skdata; call fetch (crbtm, 1, addr (fnp_word)); buf_meter_addr = bin (fnp_word (1)); if buf_meter_addr = 0 then do; call ioa_ ("Buffer management meters not available."); return; end; call fetch (buf_meter_addr, 16, addr (buf_meters)); if corep = null () then do; /* Live fnp */ delta_cycles = bin (skdata.idle_increments) - saved_idle_increments (fnp); delta_idle_count = bin (skdata.total_idle_count) - saved_idle_count (fnp); alloc_time = buf_meters.allocate.total_time - saved_buf_meters (fnp).allocate.total_time; alloc_updates = buf_meters.allocate.increments - saved_buf_meters (fnp).allocate.increments; alloc_more_than_1 = buf_meters.allocate.instances_over_1 - saved_buf_meters (fnp).allocate.instances_over_1; free_time = buf_meters.free.total_time - saved_buf_meters (fnp).free.total_time; free_updates = buf_meters.free.increments - saved_buf_meters (fnp).free.increments; free_more_than_1 = buf_meters.free.instances_over_1 - saved_buf_meters (fnp).free.instances_over_1; end; else do; delta_cycles = bin (skdata.idle_increments); delta_idle_count = bin (skdata.total_idle_count); alloc_time = buf_meters.allocate.total_time; alloc_updates = buf_meters.allocate.increments; alloc_more_than_1 = buf_meters.allocate.instances_over_1; free_time = buf_meters.free.total_time; free_updates = buf_meters.free.increments; free_more_than_1 = buf_meters.free.instances_over_1; end; theoretical_max = delta_cycles * bin (skdata.max_idle_count, 36); if theoretical_max = 0 then call ioa_ ("No samples"); else do; idle_fraction = float (delta_idle_count) / float (theoretical_max); call ioa_ ("Idle time: ^.1f%", 1.0e2 * idle_fraction); end; total_time = delta_cycles * 1000; avg_alloc_time = float (alloc_time) / float (alloc_updates); avg_free_time = float (free_time) / float (free_updates); avg_all_time = float (alloc_time + free_time) / float (alloc_updates + free_updates); pct_alloc = 1.0e2 * float (alloc_time) / float (total_time); pct_free = 1.0e2 * float (free_time) / float (total_time); pct_alloc_non_idle = pct_alloc / (1.0 - idle_fraction); pct_free_non_idle = pct_free / (1.0 - idle_fraction); call ioa_ ("Time in buffer management routines^/^32tallocate^44tfree^53ttotal"); call ioa_ ("Average time per call (msec.)^35t^4.1f^44t^4.1f^54t^4.1f", avg_alloc_time, avg_free_time, avg_all_time); call ioa_ ("Percent of FNP^35t^4.1f^44t^4.1f^54t^4.1f", pct_alloc, pct_free, pct_alloc + pct_free); call ioa_ ("Percent of non-idle^35t^4.1f^44t^4.1f^54t^4.1f", pct_alloc_non_idle, pct_free_non_idle, pct_alloc_non_idle + pct_free_non_idle); call ioa_ ("Percent of calls > 1 msec.^35t^4.1f^44t^4.1f^54t^4.1f", 1.0e2 * float (alloc_more_than_1) / float (alloc_updates), 1.0e2 * float (free_more_than_1) / float (free_updates), 1.0e2 * float (alloc_more_than_1 + free_more_than_1) / float (alloc_updates + free_updates)); call ioa_ ("Maximum single call (msec.)^35t^4d^44t^4d", buf_meters.allocate.maximum_time, buf_meters.free.maximum_time); if reset_sw then do; saved_idle_increments (fnp) = bin (skdata.idle_increments); saved_idle_count (fnp) = bin (skdata.total_idle_count); saved_buf_meters (fnp) = buf_meters; end; return; /* SAMPLE_TIME Command - Sets or prints the scheduler sampling interval */ sample_time: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call get_operand; if cmd_info.endline then do; /* No operands - so print it */ call read_skdata; call ioa_ ("Sample interval: ^d msec.", bin (skdata.interval)); return; end; on conversion go to bad_interval; i = bin (operand); /* Get new time */ if i < 1 | i > 1000 then do; bad_interval: call ioa_ ("Bad sample interval: ^a", operand); go to error_return; end; if corep ^= null () then do; call ioa_ ("Sample time can only be set on running FNP."); go to error_return; end; call read_skdata; /* Just to be sure its the right scheduler */ fnp_word (1) = -i; /* elapsed timer counts up, so this has to be negative */ call store (skdata_addr + fnp_offset (addr (skdata), addr (skdata.interval)), 1, addr (fnp_word)); return; /* IC_SAMPLE Command - Summarize data in various ways */ ic_sample: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; call get_operand; if cmd_info.endline then do; call ioa_ ("Argument missing."); go to error_return; end; if operand = "start" then call perform_action (1); else if operand = "stop" then call perform_action (2); else if operand = "reset" then call perform_action (3); else if operand = "module" then go to ic_sample_module; else if operand = "histogram" | operand = "hist" then go to ic_sample_hist; else do; call ioa_ ("Unrecognized option: ^a", operand); go to error_return; end; return; /* Summarize data by module */ ic_sample_module: on cleanup call clean_up; modch.nmodules = hbound (modch.entries, 1); call db_fnp_util_$get_special_modch (corep, fnp, addr (modch), code); if code ^= 0 then do; call com_err_ (code, name, "Unable to get module chain."); go to error_return; end; call read_data; module_counts (*) = 0; total_count = bin (icmdat.discnt) + bin (icmdat.out_of_range); do i = lbound (data, 1) to hbound (data, 1); /* Check each entry */ if data (i) ^= "0"b then do; total_count = total_count + bin (data (i)); ic_addr = i * table_mult + table_base; /* Address represented by bucket */ min_offset = 100000; min_j = -1; do j = 1 to modch.nmodules; /* Find which module it is in */ offset = ic_addr - modch.address (j); if offset >= 0 & offset < min_offset then do; min_offset = offset; min_j = j; end; end; if min_j > 0 then module_counts (min_j) = module_counts (min_j) + bin (data (i)); end; end; if total_count = 0 then do; call ioa_ ("No data collected."); go to ic_sample_module_return; end; do i = 1 to modch.nmodules; if module_counts (i) > 0 then call ioa_ ("^6a^5.1f%", modch.name (i), 1.00e2 * float (module_counts (i)) / float (total_count)); end; if icmdat.out_of_range ^= "0"b then call ioa_ ("^/^6a^5.1f%", "orange", 1.00e2 * float (bin (icmdat.out_of_range)) / float (total_count)); call ioa_ ("^/^6a^5.1f%", "idle", 1.00e2 * float (bin (icmdat.discnt)) / float (total_count)); ic_sample_module_return: call clean_up; return; /* Print a histogram of all data buckets */ ic_sample_hist: call get_operand; if cmd_info.endline then fraction_to_print = 1.0; /* Print entire histogram */ else do; on conversion go to bad_fraction; fraction_to_print = float (operand); if fraction_to_print < 0.0 | fraction_to_print > 1.0 then do; bad_fraction: call ioa_ ("Invalid fraction to print: ^a", operand); go to error_return; end; end; on cleanup call clean_up; call read_data; line_length = get_line_length_$switch (iox_$user_output, code); if code ^= 0 then line_length = 132; if line_length < 20 then do; call ioa_ ("Line length (^d) is too short.", line_length); go to ic_sample_hist_return; end; hist_len = line_length - 18; /* Amount of line available for chart */ max_hits = 0; /* Find largest bucket */ total_count = 0; do i = lbound (data, 1) to hbound (data, 1); if bin (data (i)) > max_hits then max_hits = bin (data (i)); total_count = total_count + bin (data (i)); end; if max_hits = 0 then do; call ioa_ ("No data collected."); go to ic_sample_hist_return; end; scale = float (max_hits) / float (hist_len); if fraction_to_print < 1.0 then do; /* Must trim small buckets */ hits_to_remove = (1.0 - fraction_to_print) * float (total_count); hits_removed = 0; do while (hits_removed < hits_to_remove); min_hits = max_hits; /* First, find smallest number */ n_min_hits = 0; do i = lbound (data, 1) to hbound (data, 1); if data (i) ^= "0"b then if bin (data (i)) < min_hits then do; min_hits = bin (data (i)); n_min_hits = 1; end; else if bin (data (i)) = min_hits then n_min_hits = n_min_hits + 1; end; hits_removed = hits_removed + n_min_hits * min_hits; if hits_removed <= hits_to_remove then /* Remove all instances of the minimum */ do i = lbound (data, 1) to hbound (data, 1); /* Unless it would go over limit */ if bin (data (i)) = min_hits then data (i) = "0"b; end; end; end; do i = lbound (data, 1) to hbound (data, 1); if data (i) ^= "0"b then do; j = fixed (float (bin (data (i))) / scale); j = min (max (1, j), hist_len); /* Keep it in range */ ic_addr = table_base + i * table_mult; call db_fnp_util_$edit_module_addr_force (corep, fnp, ic_addr, edited_addr, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to convert address ^o.", ic_addr); go to ic_sample_hist_return; end; x = 1.00e2 * float (bin (data (i))) / float (total_count); call ioa_ ("^12a^5.1f ^v(*^)", edited_addr, x, j); end; end; ic_sample_hist_return: call clean_up; return; /* MDISP_DATA - Command to print master dispatcher data bases */ mdisp_data: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; on cleanup call clean_up; call read_skdata; skdata_count = bin (skdata.count); /* Number of dispatcher levels */ allocate sched_dsptab in (system_area); allocate sched_savtab in (system_area); i = divide (length (string (sched_dsptab)), 18, 17, 0); call fetch (bin (skdata.dsptab_addr), i, sched_dsptabp); i = divide (length (string (sched_savtab)), 18, 17, 0); call fetch (bin (skdata.savtab_addr), i, sched_savtabp); first_exec_found = "0"b; /* Remember previous instances of dsptab.exec */ something_printed = "0"b; do i = 1 to skdata_count; dsptabp = addr (sched_dsptab.dsptab (i)); if dsptab.request | dsptab.execution then do; savtabp = addr (sched_savtab.savtab (i)); something_printed = "1"b; call ioa_ ("Level ^d: ^a", i, mdisp_desc (i)); j = bin (dsptab.request || dsptab.execution || first_exec_found); /* Compute msg index */ call ioa_ (" ^a", state_msgs (j)); if dsptab.execution & first_exec_found then do; /* Found interrupted level */ call ioa_ (" aq ^.3b ^.3b", savtab.a, savtab.q); call ioa_ (" x1 ^.3b", savtab.x1); call ioa_ (" x2 ^.3b", savtab.x2); call ioa_ (" x3 ^.3b", savtab.x3); call ioa_ (" i ^.3b", savtab.ind); call ioa_ (" ic ^.3b", savtab.ic); end; if dsptab.execution then first_exec_found = "1"b; end; end; if ^something_printed then call ioa_ ("FNP was idling"); call clean_up; return; /* Setup arguments */ setup: proc; corep = arg_corep; fnp = arg_fnp; expr_infop = arg_expr_infop; cmd_infop = arg_cmd_infop; call setup_constants; return; end setup; setup_constants: proc; if constants_setup then return; crskd = db_fnp_sym_util_$get_value (".crskd"); crbtm = db_fnp_sym_util_$get_value (".crbtm"); etmb = db_fnp_sym_util_$get_value ("etmb"); areap = get_system_free_area_ (); unspec (saved_buf_meters) = "0"b; constants_setup = "1"b; return; end setup_constants; clean_up: proc; if datap ^= null () then free data; if sched_dsptabp ^= null () then free sched_dsptab; if sched_savtabp ^= null () then free sched_savtab; return; end clean_up; error_return: /* Non-local error exit */ call clean_up; cmd_info.flush = "1"b; return; /* Read and write memory words */ fetch: proc (a, n, p); dcl a fixed bin; dcl n fixed bin; dcl p ptr; call db_fnp_memory_$fetch (corep, fnp, a, n, p, code); if code = 0 then return; if n = 1 then call com_err_ (code, name, "Unable to read location ^o.", a); else call com_err_ (code, name, "Unable to read locations ^o thru ^o", a, a + n - 1); go to error_return; store: entry (a, n, p); call db_fnp_memory_$store (corep, fnp, a, n, p, name, 0, code); if code = 0 then return; if n = 1 then call com_err_ (code, name, "Unable to write location ^o.", a); else call com_err_ (code, name, "Unable to write locations ^o thru ^o", a, a + n - 1); go to error_return; end fetch; /* Get next operand from command line */ get_operand: proc; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; return; end get_operand; /* Read data block in scheduler module */ read_skdata: proc; dcl i fixed bin; dcl fnp_word (1) bit (18) unal; call fetch (crskd, 1, addr (fnp_word)); skdata_addr = bin (fnp_word (1)); /* Address of table */ if skdata_addr = 0 then do; call ioa_ ("Scheduler data not found."); /* Probably old core image */ go to error_return; end; i = divide (length (string (skdata)), 18, 17, 0); /* Number of fnp words to read */ call fetch (skdata_addr, i, addr (skdata)); icmdat_addr = bin (skdata.icmdat_addr); icmdat_addr_known = "1"b; return; end read_skdata; /* Read data table in ic_sampler module */ read_icmdat: proc; dcl i fixed bin; dcl fnp_word (1) bit (18) unal; if ^icmdat_addr_known then call read_skdata; if icmdat_addr = 0 then do; call ioa_ ("IC sampling module not configured."); go to error_return; end; i = divide (length (string (icmdat)), 18, 17, 0); call fetch (icmdat_addr, i, addr (icmdat)); return; end read_icmdat; /* Read the acutal table of ic samples */ read_data: proc; call read_icmdat; if icmdat.table_addr = "0"b | icmdat.table_len = "0"b then do; call ioa_ ("No ic sample table found."); go to error_return; end; data_high = divide (bin (icmdat.table_len), 2, 17, 0) - 1; allocate data in (system_area); call fetch (bin (icmdat.table_addr), bin (icmdat.table_len), datap); table_base = bin (icmdat.base); table_mult = 2 ** bin (icmdat.shift); return; end read_data; /* Procedure to perform an order to the ic_sampler module */ /* We store an action for it to do, and wait for it to notice it */ perform_action: proc (act); dcl act fixed bin; dcl i fixed bin; dcl fnp_word (1) bit (18) unal; if corep ^= null () then do; call ioa_ ("Only valid on running FNP."); go to error_return; end; call read_icmdat; fnp_word (1) = "0"b; /* Reset the conformation word */ call store (icmdat_addr + fnp_offset (addr (icmdat), addr (icmdat.confirm)), 1, addr (fnp_word)); fnp_word (1) = bit (bin (act, 18), 18); /* Set action */ call store (icmdat_addr + fnp_offset (addr (icmdat), addr (icmdat.action)), 1, addr (fnp_word)); call fetch (etmb, 1, addr (fnp_word)); /* Read remaining time in timer */ i = min (1000, 262144 - bin (fnp_word (1))); /* Compute sleep time */ call timer_manager_$sleep (1000 * (i + 50), "10"b); call read_icmdat; if icmdat.confirm = "000001"b3 then return; /* It worked */ if icmdat.confirm = "000000"b3 then do; call ioa_ ("FNP did not respond to action ^d.", act); go to error_return; end; call ioa_ ("FNP gave error confirmation ^d.", bin (icmdat.confirm)); go to error_return; end perform_action; /* Procedure that computes the offset between two Multics pointers in terms of 18-bit FNP words. */ fnp_offset: proc (p1, p2) returns (fixed bin); dcl (p1, p2) ptr; dcl fnp_mem (0:127) bit (18) unal based (p1); /* A piece of FNP memory */ dcl i fixed bin; do i = lbound (fnp_mem, 1) to hbound (fnp_mem, 1); if addr (fnp_mem (i)) = p2 then return (i); end; call sub_err_ (code, name, "s", null (), (0), "Unable to compute the offset between ^p and ^p", p1, p2); return (100000); end fnp_offset; %include debug_fnp_data; end db_fnp_scheduler_;  db_fnp_sym_util_.pl1 11/15/82 1816.2rew 11/15/82 1502.2 80082 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_SYM_UTIL_ - Manages debug_fnp symbol tables */ /* Written February 1977 by Larry Johnson */ /* Modified August 1979 by Larry Johnson for apropos command */ db_fnp_sym_util_: proc; /* Arguments */ dcl arg_sym char (*); dcl arg_symp ptr; dcl arg_user_tablep ptr; dcl arg_expr_infop ptr; dcl arg_corep ptr; dcl arg_fnp fixed bin; dcl arg_cmd_infop ptr; dcl arg_member char (*); dcl arg_value fixed bin; /* Automatic */ dcl (i, j) fixed bin; dcl req bit (1) init ("0"b); dcl set_sym_name char (6); dcl set_sym_value fixed bin; dcl code fixed bin (35); dcl apropos_listp ptr; dcl apr_cnt fixed bin; dcl found bit (1); /* Based */ dcl apropos_list (32) char (32) var based (apropos_listp); dcl based_area area based; /* Constants */ dcl name char (16) int static options (constant) init ("db_fnp_sym_util_"); /* External */ dcl sub_err_ entry options (variable); dcl ioa_ entry options (variable); dcl db_fnp_reader_$get_operand entry (ptr); dcl db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl cleanup condition; dcl (addr, addrel, hbound, index, null, unspec) builtin; /* Entry to lookup a name in the standard symbol table */ lookup: entry (arg_sym, arg_symp); lookup_start: symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_); lookup_join: do i = 1 to symbol_table.cnt; symp = addr (symbol_table.entry (i)); if arg_sym = sym.name then do; arg_symp = symp; return; end; end; if req then call sub_err_ (0, name, "s", null, (0), "Unable to get value for FNP symbol ""^a"".", arg_sym); arg_symp = null; /* Convertion meaning not found */ return; /* This entry is called by people who wont take no for an answer */ lookup_req: entry (arg_sym, arg_symp); req = "1"b; go to lookup_start; /* Entry to lookup symbol in users symbol table */ lookup_user: entry (arg_user_tablep, arg_sym, arg_symp); symbol_tablep = arg_user_tablep; if symbol_tablep = null then do; arg_symp = null; return; end; else go to lookup_join; /* Functions for returns values and lengths. these are not allowed to fail */ get_value: entry (arg_sym) returns (fixed bin); call lookup_req (arg_sym, symp); return (sym.value); get_length: entry (arg_sym) returns (fixed bin); call lookup_req (arg_sym, symp); return (sym.len); /* This entry, given a flag type and a value, returns the symbol that matches both */ lookup_member: entry (arg_value, arg_member, arg_sym); symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_); do i = 1 to symbol_table.cnt; symp = addr (symbol_table.entry (i)); if sym.flag_mem = arg_member then if sym.value = arg_value then do; arg_sym = sym.name; return; end; end; arg_sym = ""; return; /* Entry to implement the set command */ set_command: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); cmd_infop = arg_cmd_infop; expr_infop = arg_expr_infop; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; if cmd_info.endline then do; call ioa_ ("Symbol missing."); go to error_return; end; set_sym_name = operand; if set_sym_name ^= operand then do; call ioa_ ("Symbol name too long: ^a", operand); go to error_return; end; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; if cmd_info.endline then do; call ioa_ ("Value missing."); go to error_return; end; call db_fnp_eval_ (arg_corep, arg_fnp, operand, expr_infop, "", set_sym_value, code); if code ^= 0 then go to error_return; if set_sym_name = "*" then do; /* Check for standard names */ expr_info.star_addr = set_sym_value; expr_info.star_known = "1"b; return; end; else if set_sym_name = "tib" then do; expr_info.tib_addr = set_sym_value; expr_info.tib_known = "1"b; return; end; else if set_sym_name = "hwcm" then do; expr_info.hwcm_addr = set_sym_value; expr_info.hwcm_known = "1"b; return; end; else if set_sym_name = "sfcm" then do; expr_info.sfcm_addr = set_sym_value; expr_info.sfcm_known = "1"b; return; end; /* User defined symbol */ symbol_tablep = expr_info.user_tablep; do i = 1 to symbol_table.cnt; /* See if already there */ symp = addr (symbol_table.entry (i)); if sym.name = set_sym_name then go to store_sym; end; if symbol_table.cnt ^< symbol_table.maxcnt then do; /* See if room */ call ioa_ ("Symbol table full."); go to error_return; end; symbol_table.cnt = symbol_table.cnt + 1; i = symbol_table.cnt; store_sym: symp = addr (symbol_table.entry (i)); unspec (sym) = "0"b; sym.name = set_sym_name; sym.value = set_sym_value; sym.len = expr_info.len; sym.type = expr_info.type; sym.reloc = reloc_abs; sym.flag_mem = ""; return; /* Entry to implement the explain command */ explain: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); cmd_infop = arg_cmd_infop; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; if cmd_info.endline then do; call ioa_ ("Symbol missing"); go to error_return; end; do while (^cmd_info.endline); call lookup (operand, symp); if symp = null then call ioa_ ("Symbol ""^a"" undefined.", operand); else if sym.explain = "0"b then call ioa_ ("Symbol ""^a"" has no explanation.", operand); else do; exptextp = addrel (addr (db_fnp_symbols_$db_fnp_symbols_), sym.explain); call ioa_ ("""^a""^[ (in ^a)^;^s^] = ^a", operand, (sym.flag_mem ^= ""), sym.flag_mem, exptext.data); end; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; end; return; error_return: cmd_info.flush = "1"b; return; /* Implement apropos command. print symbols whose explanation contains the string given */ apropos: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); cmd_infop = arg_cmd_infop; apropos_listp = null (); on cleanup call apropos_cleanup; allocate apropos_list in (get_system_free_area_ () -> based_area); call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to apropos_error; if cmd_info.endline then do; call ioa_ ("Argument missing."); go to apropos_error; end; apr_cnt = 0; do while (^cmd_info.endline); if apr_cnt = hbound (apropos_list, 1) then do; call ioa_ ("Too many arguments"); go to apropos_error; end; apr_cnt = apr_cnt + 1; apropos_list (apr_cnt) = operand; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to apropos_error; end; symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_); found = "0"b; do i = 1 to symbol_table.cnt; symp = addr (symbol_table.entry (i)); if sym.explain ^= "0"b then do; exptextp = addrel (symbol_tablep, sym.explain); do j = 1 to apr_cnt; if index (exptext.data, apropos_list (j)) ^= 0 then do; found = "1"b; call ioa_ ("""^a""^[ (in ^a)^;^s^] = ^a", sym.name, (sym.flag_mem ^= ""), sym.flag_mem, exptext.data); go to next_apropos; end; end; end; next_apropos: end; if ^found then do; call ioa_ ("No symbols found."); go to apropos_error; end; call apropos_cleanup; return; apropos_error: call apropos_cleanup; go to error_return; apropos_cleanup: proc; if apropos_listp ^= null () then free apropos_list; return; end apropos_cleanup; /* This entry is a debuging entry to display the symbol table. It is called as a Multics command. */ db_fnp_dump_symbols: entry; symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_); if symbol_table.cnt = 0 then do; call ioa_ ("No symbols."); return; end; call ioa_ ("NAME VALUE LEN RELOC TYPE FLAG EXPLANATION^/"); do i = 1 to symbol_table.cnt; symp = addr (symbol_table.entry (i)); exptextp = addrel (symbol_tablep, sym.explain); call ioa_ ("^6a^7o^5o ^[ ^;tib ^;hwcm^;sfcm^;meters^] ^6a ^8a ^[^a^;^s^]", sym.name, sym.value, sym.len, sym.reloc + 1, short_type_names (sym.type), sym.flag_mem, (sym.explain ^= "0"b), exptext.data); end; call ioa_ ("^/^d symbol^[s^].^/", symbol_table.cnt, symbol_table.cnt ^= 1); return; %include debug_fnp_data; end db_fnp_sym_util_;  db_fnp_symbols_.cds 02/03/86 1012.8rew 02/03/86 0924.6 284121 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_SYMBOLS_ - Procedure to create a symbol table for debug_fnp */ /* The table is constructed by scanning the macros.map355 source file */ /* Written February 1978 by Larry Johnson to replace the old, canned symbol table */ /* Modified by R Holmstedt 6/81 to use the new library path >ldd>mcs. */ db_fnp_symbols_: proc; /* Automatic */ dcl segp ptr; /* Pointer to entire macro segment */ dcl segl fixed bin; /* Its length */ dcl restp ptr; /* Pointer to unscanned (rest of) segment */ dcl restl fixed bin; /* Its length */ dcl ptr_array (2) ptr; /* For get_temp_segments_ */ dcl linep ptr; /* Pointer to current line */ dcl linel fixed bin; /* Its length */ dcl code fixed bin (35); dcl bit_count fixed bin (24); dcl dir char (168); dcl lineno fixed bin init (0); /* Current line number, for errors */ dcl end_of_line bit (1); dcl reloc_type fixed bin; dcl wordp ptr; dcl wordl fixed bin; dcl sym_offset fixed bin; dcl label char (6); dcl flag_type char (6); dcl n_exp_words fixed bin init (0); /* Number of words used in explanations */ dcl explain_seg_ptr ptr; dcl 1 cds like cds_args automatic; dcl 1 dummy_symbol_table aligned, /* To define correct entry in object segment */ 2 db_fnp_symbols_ fixed bin; dcl line char (linel) based (linep); dcl rest char (restl) based (restp); dcl word char (wordl) based (wordp); dcl 1 explain_seg aligned based (explain_seg_ptr), /* Explanations are accumulated in this seg */ 2 unused bit (36), /* Dummy word so offset will never be 0 */ 2 data (1) bit (36) aligned; /* Constants */ dcl white_space char (2) int static options (constant) init (" "); /* Space and tab */ dcl nl char (1) int static options (constant) init (" "); dcl name char (16) int static options (constant) init ("db_fnp_symbols_"); dcl macro_name char (13) int static options (constant) init ("macros.map355"); dcl statement_name (9) char (16) int static options (constant) init ( "symrel", "symlen", "symtype", "symdef", "symflag", "symdel", "synval", "symget", "symgetr"); /* External stuff */ dcl ioa_ entry options (variable); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned); dcl com_err_ entry options (variable); dcl cu_$arg_list_ptr entry (ptr); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl get_wdir_ entry returns (char (168)); dcl create_data_segment_ entry (ptr, fixed bin (35)); dcl error_table_$noentry ext fixed bin (35); dcl cleanup condition; dcl (addr, addrel, bin, bit, divide, hbound, index, length, null, rel, search, size, string, substr, unspec, verify) builtin; /* Initialization */ ptr_array = null; segp = null; on cleanup call clean_up; call get_temp_segments_ (name, ptr_array, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to get temp segment."); go to done; end; symbol_tablep = ptr_array (1); explain_seg_ptr = ptr_array (2); exptextp = addr (explain_seg.data); /* Start data here */ call init_macro_seg; /* This locates the macro segment */ call build_symbol_table; /* And this does all the work */ call relocate_explanations; /* Copy symbols explanations in */ /* Now create the data segment */ cds.p (1) = symbol_tablep; cds.len (1) = size (symbol_table) + n_exp_words; dummy_symbol_table.db_fnp_symbols_ = 0; /* Reference dummy table so compiler doesnt delete it */ cds.struct_name (1) = "dummy_symbol_table"; cds.p (2) = null; cds.len (2) = 0; cds.struct_name (2) = ""; cds.seg_name = name; cds.num_exclude_names = 0; cds.exclude_array_ptr = null; string (cds.switches) = "0"b; cds.have_text = "1"b; call create_data_segment_ (addr (cds), code); if code ^= 0 then call com_err_ (code, name, "From create_data_segment_"); done: call clean_up; return; /* Procedure to scan the macro file and build the symbol table */ build_symbol_table: proc; dcl i fixed bin; dcl opname char (16); dcl r_sw bit (1); /* Set for symgetr */ dcl start_cnt fixed bin; dcl start_sym char (6); dcl end_sym char (6); dcl start_lineno fixed bin; dcl save_restp ptr; dcl save_restl fixed bin; read_line: call get_line; if linep = null then do; /* End of segment */ if symbol_table.cnt = 0 then do; call com_err_ (0, name, "No symbols defined."); go to done; end; else return; end; if length (line) <= 6 then go to read_line; /* Very short lines not interesting */ if substr (line, 1, 6) ^= "*++sym" then go to read_line; /* Not a line of importance */ call adv_line (3); /* Skip over *++ */ i = search (line, white_space); /* Find end of keyword */ if i = 0 then i = length (line); else i = i-1; opname = substr (line, 1, i); call adv_line (i); /* Skip over keyword */ call skip_white_space; /* And white space after it */ do i = 1 to hbound (statement_name, 1); if statement_name (i) = opname then go to statement_type (i); end; call com_err_ (0, name, "Invalid *++^a statement on line ^d.", opname, lineno); go to done; statement_type (1): /* *++ symrel */ if end_of_line then go to no_operand; /* Need operands */ do while (^end_of_line); call get_symword; call get_word; call check_reloc; /* Be sure this is valid relocation keyword */ sym.reloc = reloc_type; end; go to read_line; statement_type (2): /* *++ symlen */ if end_of_line then go to no_operand; do while (^end_of_line); call get_symword; /* Look up symbol */ call get_word; /* Get length */ if word = "" then do; call com_err_ (0, name, "Invalid length for ^a on line ^d.", sym.name, lineno); go to done; end; sym.len = eval (word); end; go to read_line; statement_type (3): /* *++ symtype */ if end_of_line then go to no_operand; do while (^end_of_line); call get_symword; call get_word; do i = lbound (long_type_names, 1) to hbound (long_type_names, 1); /* Check for valid type */ if word = long_type_names (i) | word = short_type_names (i) then go to got_type; end; call com_err_ (0, name, "Invalid type for ^a on line ^d.", sym.name, lineno); go to done; got_type: sym.type = i; end; go to read_line; statement_type (4): /* *++symdef - define a new symbol */ if end_of_line then go to no_operand; do while (^end_of_line); call get_word; if word = "" then go to no_operand; do i = 1 to symbol_table.cnt; /* Be sure not duplicate */ symp = addr (symbol_table.entry (i)); if sym.name = word then do; call com_err_ (0, name, "Attempt to multiply define ^a on line ^d.", word, lineno); go to done; end; end; symbol_table.cnt, symbol_table.maxcnt = symbol_table.cnt + 1; symp = addr (symbol_table.entry (symbol_table.cnt)); /* Addr of new entry */ sym.name = word; sym.value = 0; sym.len = 1; sym.reloc = reloc_abs; sym.type = type_oct; sym.flag_mem = ""; if ^end_of_line then do; /* There is value */ call get_word; sym.value = eval (word); end; end; go to read_line; statement_type (5): /* *++symflag */ if end_of_line then go to no_operand; do while (^end_of_line); call get_symword; if end_of_line then sym.flag_mem = ""; else do; call get_word; sym.flag_mem = word; end; end; go to read_line; statement_type (6): /* *++symdel - delete a previously defined symbol */ if end_of_line then go to no_operand; do while (^end_of_line); call get_symword; do i = sym_offset + 1 to symbol_table.cnt; /* Shift everything after it down */ symbol_table.entry (i-1) = symbol_table.entry (i); end; unspec (symbol_table.entry (symbol_table.cnt)) = "0"b; symbol_table.cnt, symbol_table.maxcnt = symbol_table.cnt - 1; end; go to read_line; statement_type (7): /* *++symval - sets the valuue of a symbol */ if end_of_line then go to no_operand; do while (^end_of_line); call get_symword; if end_of_line then sym.value = 0; else do; call get_word; sym.value = eval (word); end; end; go to read_line; statement_type (8): /* *++symget - gets a range of symbols into table */ r_sw = "0"b; go to statement_type_8_9; statement_type (9): /* *++symgetr - like symget, but adds them in reverse order */ r_sw = "1"b; statement_type_8_9: save_restp = restp; /* Save these values incase read-ahead needed */ save_restl = restl; start_lineno = lineno; start_cnt = symbol_table.cnt; /* Remember origonal count */ if end_of_line then go to no_operand; call get_word; /* Get starting symbol name */ if word = "" | end_of_line then go to no_operand; start_sym = word; call get_word; /* Ending symbol */ if word = "" then go to no_operand; end_sym = word; reloc_type = reloc_abs; /* Default relocation */ flag_type = ""; /* Default flag field */ if ^end_of_line then do; /* There may be relocation field */ call get_word; if word = "" then reloc_type = reloc_abs; else call check_reloc; end; if ^end_of_line then do; /* May be flag field */ call get_word; flag_type = word; end; scan_start_sym: call get_line; /* Search for starting symbol */ if linep = null then do; call com_err_ (0, name, "Cant't find starting symbol ""^a"" requested on line ^d.", start_sym, start_lineno); go to done; end; if substr (line, 1, 1) = "*" then go to scan_start_sym; call get_label; if label ^= start_sym then go to scan_start_sym; call make_sym_entry; /* Make entry for starting symbol */ if label = end_sym then go to done_sym_scan; scan_end_sym: call get_line; if linep = null then do; call com_err_ (0, name, "Can't find ending symbol ""^a"" requested on line ^d.", end_sym, start_lineno); go to done; end; if substr (line, 1, 1) = "*" then go to scan_end_sym; call get_label; if label = "" then go to scan_end_sym; call make_sym_entry; if label ^= end_sym then go to scan_end_sym; done_sym_scan: lineno = start_lineno; /* Back up to *++symget statement */ restp = save_restp; restl = save_restl; i = symbol_table.cnt - start_cnt; /* Number of symbols added */ if r_sw then begin; /* Reverse them if symgetr */ dcl j fixed bin; dcl 1 temp_table, 2 entry (i) unal, 3 one_symbol like sym unal; do j = 1 to i; /* Copy to temp table */ temp_table.entry (j) = symbol_table.entry (start_cnt + j); end; do j = i to 1 by -1; /* Copy back */ symbol_table.entry (symbol_table.cnt - j + 1) = temp_table.entry (j); end; end; go to read_line; no_operand: call com_err_ (0, name, "Missing operand for *++^a on line ^d.", opname, lineno); go to done; end build_symbol_table; /* Procedure called after the symbol table is build3t to copy in explanation data and compute offsets to it */ relocate_explanations: proc; dcl words (n_exp_words) bit (36) aligned based; dcl (p, q) ptr; dcl i fixed bin; if n_exp_words = 0 then return; p = addrel (symbol_tablep, size (symbol_table)); /* First word available for explanations */ q = addr (explain_seg.data); p -> words = q -> words; /* Copy it */ do i = 1 to symbol_table.cnt; /* Loop to adjust all offsets */ symp = addr (symbol_table.entry (i)); if sym.explain ^= "0"b then /* It has explanation */ sym.explain = bit (bin (bin (sym.explain, 17) + size (symbol_table) -1, 18), 18); end; return; end relocate_explanations; /* Procedure to initiate the macro source segment. It looks first in the working directory, then in >ldd>mcs>info */ init_macro_seg: proc; dir = get_wdir_ (); call hcs_$initiate_count (dir, macro_name, "", bit_count, 0, segp, code); if segp = null then do; if code ^= error_table_$noentry then do; macro_seg_err: call com_err_ (code, name, "^a^[>^]^a", dir, dir ^= ">", macro_name); go to done; end; dir = ">ldd>mcs>info"; /* Try library */ call hcs_$initiate_count (dir, macro_name, "", bit_count, 0, segp, code); if segp = null then go to macro_seg_err; end; call ioa_ ("^a: Using ^a^[>^]^a", name, dir, (dir ^= ">"), macro_name); segl = divide (bit_count, 9, 17, 0); restp = segp; restl = segl; return; end init_macro_seg; /* Procedure to isolate the next line in the source */ get_line: proc; dcl i fixed bin; get_next_line: end_of_line = "0"b; if restl = 0 then do; /* End of file */ linep = null; return; end; lineno = lineno+1; i = index (rest, nl); if i = 0 then i, linel = restl; /* No more newlines */ else linel = i-1; linep = restp; restp = substraddr (rest, i+1); restl = restl - i; if linel = 0 then go to get_next_line; /* Ignor empty lines */ return; end get_line; /* Procedure called while parsing line to move pointer down the line. */ adv_line: proc (n); dcl n fixed bin; /* How far too move */ linep = substraddr (line, n+1); linel = linel - n; if linel = 0 then end_of_line = "1"b; return; end adv_line; /* Procedure to skip over any white space */ skip_white_space: proc; dcl i fixed bin; i = verify (line, white_space); /* Count white space characters */ if i = 0 then i = linel; /* All white line */ else i = i - 1; call adv_line (i); return; end skip_white_space; /* Procedure to get the next word from the operand field. */ get_word: proc; dcl i fixed bin; if end_of_line | (linel = 0) then do; end_of_line = "1"b; wordp = null; wordl = 0; return; end; i = search (line, " ,"); /* Space, tab, and comma */ if i = 0 then i = length (line); else i = i - 1; wordp = linep; wordl = i; call adv_line (i); /* More forward over the word */ if linel > 0 then /* Check for end of line */ if substr (line, 1, 1) ^= "," then end_of_line = "1"b; else call adv_line (1); /* Skip ver comma */ return; end get_word; /* Procedure to get the next word as a symbol */ get_symword: proc; call get_word; do sym_offset = 1 to symbol_table.cnt; symp = addr (symbol_table.entry (sym_offset)); if sym.name = word then return; end; call com_err_ (0, name, "Undefined symbol ^a on line ^d", word, lineno); go to done; end get_symword; /* Check current word for valid relocation type */ check_reloc: proc; if word = "abs" then reloc_type = reloc_abs; else if word = "tib" then reloc_type = reloc_tib; else if word = "sfcm" then reloc_type = reloc_sfcm; else if word = "hwcm" then reloc_type = reloc_hwcm; else if word = "meters" then reloc_type = reloc_meters; else do; call com_err_ (0, name, "Invalid relocation type of ^a on line ^d", word, lineno); go to done; end; return; end check_reloc; /* Extrace label from assembler statement */ get_label: proc; dcl i fixed bin; i = search (line, white_space); if i = 1 then label = ""; /* No label */ else do; if i = 0 then i = length (line); /* Label is hole line */ else i = i-1; label = substr (line, 1, i); call adv_line (i); end; call skip_white_space; return; end get_label; /* Procedure to make a new symbol table entry by compiling the curent line */ make_sym_entry: proc; dcl i fixed bin; dcl dec_sw bit (1); i = search (line, white_space); /* Find end of opcode */ if i = 0 then i = length (line); else i = i-1; if substr (line, 1, i) = "set" | substr (line, 1, i) = "equ" then dec_sw = "1"b; /* Valid decimal op */ else if substr (line, 1, i) = "bool" then dec_sw = "0"b; else do; call com_err_ (0, name, "Unrecognized opcode ""^a"" defining ""^a"" on line ^d.", substr (line, 1, i), label, lineno); go to done; end; call adv_line (i); /* Over opcode */ call skip_white_space; symbol_table.cnt, symbol_table.maxcnt = symbol_table.cnt + 1; symp = addr (symbol_table.entry (symbol_table.cnt)); sym.name = label; sym.value = 0; sym.len = 1; sym.reloc = reloc_type; if flag_type = "" then sym.type = type_oct; else sym.type = type_bit; sym.flag_mem = flag_type; sym.explain = "0"b; sym.pad = "0"b; i = search (line, white_space); /* Find end of expression */ if i = 0 then i = length (line); else i = i-1; if dec_sw then sym.value = eval (substr (line, 1, i)); else sym.value = eval_oct (substr (line, 1, i)); call adv_line (i); /* Over expression */ if end_of_line then return; call skip_white_space; /* Move up to comment */ if end_of_line then return; exptext.len = length (line); /* Rest of line is explanation */ exptext.data = line; sym.explain = rel (exptextp); i = size (exptext); n_exp_words = n_exp_words + i; exptextp = addrel (exptextp, i); /* Loc for next eplanation */ return; end make_sym_entry; /* Cleanup handler */ clean_up: proc; if segp ^= null then call hcs_$terminate_noname (segp, code); if ptr_array (1) ^= null then call release_temp_segments_ (name, ptr_array, code); return; end clean_up; /* Simulate substraddr builtin temporarily */ substraddr: proc (c, n) returns (ptr); dcl c char (*); dcl n fixed bin; dcl ca (n) char (1) unal based (addr (c)); return (addr (ca (n))); end substraddr; /* Procedure to evaluate expressions in source lines. This code was copied origionally from db_fnp_eval_ */ eval: proc (arg_expr) returns (fixed bin); /* Parameters */ dcl arg_expr char (*); /* The expression to evaluate */ /* Automatic */ dcl result fixed bin; dcl code fixed bin (35); dcl ntoken fixed bin; /* Number of tokens */ dcl exprp ptr; /* Pointer to unparsed part of expression */ dcl exprl fixed bin; /* Length of unparsed part */ dcl expr char (exprl) based (exprp); /* The unparsed part of expression */ dcl tstart fixed bin; /* Starting token in sub-expression */ dcl tend fixed bin; /* Last token in sub-expression */ dcl tcur fixed bin; /* Current token */ dcl n_mult fixed bin; /* Count of multiplies and divides */ dcl n_add fixed bin; /* Count of adds and subtracts */ dcl dec_sw bit (1); dcl 1 token_list aligned, 2 entry (255) unal, 3 token like token; /* Definition of a token */ dcl tokenp ptr; dcl 1 token unaligned based (tokenp), 2 prev fixed bin (8), /* Backwards pointer */ 2 next fixed bin (8), /* Forwards pointer */ 2 type fixed bin (8), /* Kind of token */ 2 sub fixed bin (8), /* Sub-type, for some tokens */ 2 val fixed bin (35); /* Values for token.type */ dcl (start_token init (0), /* Start of expression */ leftp_token init (1), /* Left parenthesis */ rightp_token init (2), /* Right parenthesis */ mult_token init (3), /* Multiply (sub=1), or divide (sub=2) */ add_token init (4), /* Add (sub=1), or subtract (sub=2) */ sym_token init (6), /* Symbol or constant */ end_token init (7)) /* End of expression */ fixed bin int static options (constant); /* Initialization */ dec_sw = "1"b; /* Called at decimal entryry */ go to eval_start; eval_oct: entry (arg_expr) returns (fixed bin); dec_sw = "0"b; eval_start: exprp = addr (arg_expr); exprl = length (arg_expr); /* Now evaluate the expression */ call parse_expr; call eval_expr; return (result); /* Procedure to parse the expression */ parse_expr: proc; dcl nparen fixed bin; /* For paren level counting */ dcl i fixed bin; ntoken = 0; call new_token (start_token); /* First, start of expr token */ nparen = 0; do while (exprl > 0); /* Loop until end */ i = index ("()*/+|-", substr (expr, 1, 1)); /* Check for special character */ if i = 0 then do; /* Must be symbol */ if sym_or_rightp () then go to bad_char; call parse_sym; go to next_token; end; else go to parse_op (i); /* Branch, depending on character */ parse_op (1): /* Left paren */ if sym_or_rightp () then go to bad_char; call new_token (leftp_token); nparen = nparen + 1; call adv (1); go to next_token; parse_op (2): /* Right paren */ if token.type = start_token | mult_or_add () then go to bad_char; if nparen ^> 0 then do; if exprl = length (arg_expr) then go to bad_char; else call err ("Too many "")""."); end; call new_token (rightp_token); nparen = nparen - 1; call adv (1); go to next_token; parse_op (3): /* "*" - multiply */ if ^sym_or_rightp () then go to bad_char; call new_token (mult_token); token.sub = 1; call adv (1); go to next_token; parse_op (4): /* Divide */ if start_or_leftp () | mult_or_add () then go to bad_char; call new_token (mult_token); token.sub = 2; call adv (1); go to next_token; parse_op (5): /* Add */ parse_op (6): /* Add, alternate form ("|") */ parse_op (7): /* Subtract */ if start_or_leftp () then call new_token (sym_token); /* Unary, treat as 0+ or 0- */ else if mult_or_add () then go to bad_char; call new_token (add_token); if substr (expr, 1, 1) = "-" then token.sub = 2; else token.sub = 1; call adv (1); go to next_token; next_token: end; if nparen ^= 0 then call err ("Parens do not balance."); /* Must balance in end */ if mult_or_add () then call err ("Expression ends badly."); call new_token (end_token); return; end parse_expr; /* Procedure to parse a constant or a symbol name */ parse_sym: proc; dcl val fixed bin (35); dcl bval bit (36) aligned based (addr (val)); dcl (i, j) fixed bin; dcl p ptr; i = verify (expr, "0123456789"); /* Try constant first */ if i ^= 1 then do; /* It is a constant */ if i = 0 then i = length (expr); /* Rest of expr is a constant */ else i = i - 1; if dec_sw then do; val = cv_dec_check_ (substr (expr, 1, i), code); if code ^= 0 then call err ("Invalid decimal integer: ""^a"".", substr (expr, 1, i)); if val < -262144 | val > 262143 then call err ("Decimal integer not in range -262144 to 262143: ^a", substr (expr, 1, i)); call adv (i); end; else do; /* Octal number */ val = cv_oct_check_ (substr (expr, 1, i), code); if code ^= 0 then call err ("Invalid octal integer: ""^a"".", substr (expr, 1, i)); if substr (bval, 1, 18) ^= "0"b & substr (bval, 1, 18) ^= "777777"b3 then call err ("Octal integer not in range -400000 to 377777: ^a", substr (expr, 1, i)); call adv (i); end; if val > 0 then if substr (bval, 19, 1) then /* Really negative */ substr (bval, 1, 18) = "777777"b3; call new_token (sym_token); /* Set up token for symbol */ token.val = val; return; end; /* Symbol must be a name */ i = search (expr, "()*/+|-"); /* Look for end */ if i = 1 then go to bad_char; if i = 0 then i = length (expr); else i = i - 1; do j = 1 to symbol_table.cnt; p = addr (symbol_table.entry (j)); if p -> sym.name = substr (expr, 1, i) then go to sym_found; end; call err ("Invalid symbol: ^a", substr (expr, 1, i)); sym_found: call new_token (sym_token); token.val = p -> sym.value; call adv (i); return; end parse_sym; /* Procedures which to some comon tests on the previous token */ mult_or_add: proc returns (bit (1)); return (token.type = mult_token | token.type = add_token); end mult_or_add; start_or_leftp: proc returns (bit (1)); return (token.type = start_token | token.type = leftp_token); end start_or_leftp; sym_or_rightp: proc returns (bit (1)); return (token.type = sym_token | token.type = rightp_token); end sym_or_rightp; /* Procedure to create a new token and trhread it in */ new_token: proc (type); dcl type fixed bin; /* Type of new token */ if ntoken = hbound (token_list.entry, 1) then call err ("Expression too long."); if ntoken > 0 then token.next = ntoken + 1; /* Set pointer in prev token */ ntoken = ntoken + 1; tokenp = addr (token_list.entry (ntoken)); token.prev = ntoken - 1; token.next = 0; token.type = type; token.sub = 0; token.val = 0; return; end new_token; /* Procedure to advance pointer in expression */ adv: proc (n); dcl n fixed bin; /* Amount to move */ exprp = substraddr (expr, n+1); /* Adjust pointer */ exprl = exprl - n; /* Adjust length */ return; end adv; /* Procedure to evaluate the expression by scanning the list of tokens */ /* The procedure is to find the inner most expression, evaluate it, and continue. At the end, there should only be 3 tokens left: the start, the end, and one symbol token containing the final value */ eval_expr: proc; do while (ntoken > 3); call find_sub_expr; /* Find some inner expression to work on */ call eval_sub_expr; /* And reduce it to a value */ end; tokenp = addr (token_list.entry (1)); /* Pointer to start token */ tokenp = addr (token_list.entry (token.next)); /* Second token, containing the value */ result = token.val; /* Get the answer */ return; end eval_expr; /* Procedure to locate an inner expression to evaluate. This will be either a part of the expression delimited by parens, or, if no parens left, the entire expression. */ /* The following variables are set for future use: tstart - the first token in the expression found tend - the last n_mult - likewise for mult tokens n_add - likewise for add tokens */ find_sub_expr: proc; n_mult, n_add = 0; tstart, tcur = 1; tokenp = addr (token_list.entry (tstart)); do while ((token.type ^= rightp_token) & (token.type ^= end_token)); if token.type = leftp_token then do; tstart = tcur; /* Maybe expression will start here */ n_mult, n_add = 0; /* Must reset counters for inner level */ end; else if token.type = mult_token then n_mult = n_mult + 1; else if token.type = add_token then n_add = n_add + 1; tcur = token.next; /* On to next one */ tokenp = addr (token_list.entry (tcur)); end; tend = tcur; end find_sub_expr; /* Procedure to evaluate sub-expression once it has been isolated. */ /* The sub-expression is repeatedly scanned for mult tokens, add tokens */ eval_sub_expr: proc; do while ((n_mult + n_add) > 0); if n_mult > 0 then call eval_op (mult_token, n_mult); if n_add > 0 then call eval_op (add_token, n_add); end; call del_token (tstart); /* Delete parens one expression is evaluated */ call del_token (tend); return; end eval_sub_expr; /* This procedure scans looking for either mult tokens or add tokens to be evaluated. */ eval_op: proc (token_type, token_cnt); dcl token_type fixed bin; /* The kind of token being evaluated, mult or add */ dcl token_cnt fixed bin; /* Number still unevaluated in sub-expression */ tcur = tstart; tokenp = addr (token_list.entry (tcur)); do while (token_cnt > 0); if token.type = token_type then do; /* Got one */ call compute_op; /* Go do the arithmetic */ token_cnt = token_cnt - 1; end; tcur = token.next; tokenp = addr (token_list.entry (tcur)); end; return; /* Every thing possible is done */ end eval_op; /* Procedure called to evalue a mult or add token. Once the arithmetic is done, the value is stored in the first sym token. the operator token and the second symbol token are deleted. This procedure is called with tcur as the operator token being evaluated */ compute_op: proc; dcl (del1, del2) fixed bin; /* The two tokens to be deleted */ dcl (val1, val2) fixed bin (35); /* Values of the two symbols */ dcl p ptr; del1 = tcur; /* The operator token will be deleted */ del2 = token.next; /* As well as the second operand */ p = addr (token_list.entry (token.next)); /* Pointter to second symbol token */ val2 = p -> token.val; p = addr (token_list.entry (token.prev)); /* Pointer to the first symbol */ val1 = p -> token.val; if token.type = add_token then do; /* Add or subtract */ if token.sub = 1 then val1 = val1 + val2; else val1 = val1 - val2; end; else do; /* Multiply or divide */ if token.sub = 1 then val1 = val1 * val2; else do; if val2 = 0 then call err ("Division by zero."); else val1 = divide (val1, val2, 35, 0); end; end; tcur = token.prev; /* Make first operand the current token */ tokenp = addr (token_list.entry (tcur)); token.val = val1; /* Save answer */ call del_token (del1); /* Delete operator */ call del_token (del2); /* And the sedond operand */ return; end compute_op; /* Procedure to delete a token by untreading it from the list */ del_token: proc (n); dcl n fixed bin; /* The token to go */ dcl (next, prev) fixed bin; dcl p ptr; p = addr (token_list.entry (n)); prev = p -> token.prev; next = p -> token.next; if (prev = 0) | (next = 0) then return; /* Ndver delete start or end */ p = addr (token_list.entry (prev)); p -> token.next = next; p = addr (token_list.entry (next)); p -> token.prev = prev; ntoken = ntoken - 1; return; end del_token; /* Error routines */ bad_char: if exprl < length (arg_expr) then call err ("""^a"" after ""^a"" is invalid.", substr (expr, 1, 1), substr (arg_expr, 1, length (arg_expr) - exprl)); else call err ("""^a"" at beginning is invalid.", substr (expr, 1, 1)); /* General error subroutine */ err: proc options (variable); dcl s char (256); dcl p ptr; call cu_$arg_list_ptr (p); call ioa_$general_rs (p, 1, 2, s, (0), "1"b, "0"b); call com_err_ (0, name, "Invalid expression in line ^d: ""^a"". ^a", lineno, arg_expr, s); go to done; end err; end eval; %include debug_fnp_data; %include cds_args; end db_fnp_symbols_;  db_fnp_trace_.pl1 11/15/82 1816.2rew 11/15/82 1502.2 134217 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_TRACE_ - Implements db_fnp commands that deal with the trace table */ /* Written 1977 by Larry Johnson */ /* Modified August 1979 by Larry Johnson to make use of .crtsz and to improve command interface */ db_fnp_trace_: proc; /* Parameters */ dcl arg_corep ptr; dcl arg_fnp fixed bin; dcl arg_cmd_infop ptr; dcl arg_expr_infop ptr; /* Automatic */ dcl corep ptr; dcl fnp fixed bin; dcl (i, j) fixed bin; dcl code fixed bin (35); dcl trace_mask bit (18) unal; /* Current mask word */ dcl temp_name char (16); dcl set bit (1); dcl trace_sw (1) bit (18) unal; dcl tcur fixed bin; dcl mem_word (1) bit (18) unal; dcl (print_start, print_count) fixed bin; /* Args on print trace */ dcl trace_message char (128) var; dcl trace_req_msgp ptr init (null ()); dcl trace_req_msg_cnt fixed bin; dcl (start_given, count_given) bit (1); dcl something_printed bit (1); dcl 1 modch aligned, /* Module table required by format_fnp_trace_msg_ */ 2 nmodules fixed bin init (30), 2 entries (30), 3 name char (4), 3 address fixed bin; /* Constants */ dcl mask_name (10) char (4) int static options (constant) init ( "sked", "dia", "intp", "util", "lsla", "hsla", "cons", "trac", "init", "ptrc"); dcl name char (13) int static options (constant) init ("db_fnp_trace_"); /* Static */ dcl symbols_looked_up bit (1) int static init ("0"b); dcl crtra fixed bin int static; /* Address of trace mask */ dcl crtsw fixed bin int static; /* Global trace switch */ dcl crtrb fixed bin int static; /* Base of trace table */ dcl crtrc fixed bin int static; /* Current entry */ dcl crmem fixed bin int static; /* Last word of memory */ dcl crtsz fixed bin int static; /* Size of trace table */ dcl h1mb fixed bin int static; /* Hsla 1 mailbox - used as lower bound on address checking */ dcl free_areap ptr int static; /* Address of temp area */ dcl free_area area based (free_areap); /* Stuff associated with trace table */ dcl trace_tab_size fixed bin; /* Its length */ dcl trace_tab_start fixed bin; /* Starting memory addrress */ dcl trace_tab_current fixed bin; /* Current entry */ dcl trace_tab_cnt fixed bin; /* Number of entries */ dcl trace_tabp ptr init (null); /* Address of table */ dcl trace_tab (trace_tab_size) bit (18) unal based (trace_tabp); /* Format of a trace message entry */ dcl tmsgp ptr; dcl 1 tmsg unal based (tmsgp), 2 module bit (6) unal, /* Module logging message */ 2 type bit (6) unal, /* Message number */ 2 length bit (6) unal, /* Number of data words */ 2 time bit (18) unal, 2 data (1) bit (18) unal; /* Array of tmsg.length words */ dcl flag_word bit (18) unal based (tmsgp); /* For checking sentinels */ dcl logical_end bit (18) int static options (constant) init ("525252"b3); dcl physical_end bit (18) int static options (constant) init ("525250"b3); /* Based */ dcl trace_req_msg (10) char (32) var based (trace_req_msgp); /* External */ dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl db_fnp_memory_$store entry (ptr, fixed bin, fixed bin, fixed bin, ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin); dcl db_fnp_reader_$get_operand entry (ptr); dcl db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_util_$get_special_modch entry (ptr, fixed bin, ptr, fixed bin (35)); dcl format_fnp_trace_msg_ entry (ptr, ptr, char (*) var); dcl (ioa_, ioa_$nnl) entry options (variable); dcl com_err_ entry options (variable); dcl get_system_free_area_ entry returns (ptr); dcl cleanup condition; dcl (addr, bin, hbound, length, max, min, null, substr, unspec) builtin; /* Entry to print the trace table */ print_trace: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call init; on cleanup call clean_up; if corep = null then do; /* Be sure tracing is disabled for running fnp */ call fetch (crtsw, 1, addr (trace_sw (1))); if trace_sw (1) = "0"b then do; call ioa_ ("Tracing not disabled. Use stop_trace first."); go to error_return; end; end; print_start = 1; print_count = -1; start_given, count_given = "0"b; call get_operand; do while (^cmd_info.endline); if substr (operand, 1, 1) = "/" then do; /* scan string */ if trace_req_msgp = null () then do; allocate trace_req_msg in (free_area); trace_req_msg_cnt = 0; end; if trace_req_msg_cnt = hbound (trace_req_msg, 1) then do; call ioa_ ("Too many strings requested."); go to error_return; end; trace_req_msg_cnt = trace_req_msg_cnt + 1; i = length (operand) - 1; if substr (operand, length (operand), 1) = "/" then i = i - 1; trace_req_msg (trace_req_msg_cnt) = substr (operand, 2, i); end; else if ^start_given then do; call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", print_start, code); if code ^= 0 then go to error_return; start_given = "1"b; end; else if ^count_given then do; call db_fnp_eval_ (corep, fnp, operand, expr_infop, "", print_count, code); if code ^= 0 then go to error_return; count_given = "1"b; end; else do; call ioa_ ("Unrecognized operand: ^a", operand); go to error_return; end; call get_operand; end; call db_fnp_util_$get_special_modch (corep, fnp, addr (modch), code); if code ^= 0 then modch.nmodules = 0; call capture_trace; /* Find trace table */ if print_start < 0 then print_start = trace_tab_cnt + print_start + 1; /* Measuring from end */ print_start = max (1, print_start); if print_start > trace_tab_cnt then do; call ioa_ ("Trace table contains only ^d entries.", trace_tab_cnt); go to error_return; end; i = 1; tcur = trace_tab_current; tmsgp = addr (trace_tab (tcur - trace_tab_start + 1)); do while (i < print_start); /* Loop past unneeded entries at start */ if flag_word = physical_end then tcur = trace_tab_start; else do; i = i + 1; tcur = tcur + bin (tmsg.length) + 2; end; tmsgp = addr (trace_tab (tcur - trace_tab_start + 1)); end; i = 0; something_printed = "0"b; do while (i ^= print_count); /* Loop till enough printed */ if flag_word = logical_end then go to print_trace_end; else if flag_word = physical_end then tcur = trace_tab_start; else do; call format_fnp_trace_msg_ (tmsgp, addr (modch), trace_message); if trace_req_msgp ^= null () then do; /* strings requested */ do j = 1 to trace_req_msg_cnt; if index (trace_message, trace_req_msg (j)) > 0 then go to print_it; end; go to skip_it; end; print_it: call ioa_ ("^a", trace_message); something_printed = "1"b; skip_it: i = i + 1; tcur = tcur + bin (tmsg.length) + 2; end; tmsgp = addr (trace_tab (tcur - trace_tab_start + 1)); end; print_trace_end: if trace_req_msgp ^= null & ^something_printed then do; call ioa_ ("No trace messages match request."); go to error_return; end; call clean_up; return; /* Entry to set and/or print the trace mask */ mask: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call init; call fetch (crtra, 1, addr (trace_mask)); /* Read current mask */ call get_operand; /* Get first openard */ if cmd_info.endline then do; /* No operands, print mask */ call ioa_$nnl ("Trace mask is ^.3b:", trace_mask); do i = 1 to hbound (mask_name, 1); if substr (trace_mask, i, 1) then call ioa_$nnl (" ^a", mask_name (i)); end; call ioa_ (""); return; end; do while (^cmd_info.endline); /* Parse operands for new mask */ if substr (operand, 1, 1) = "+" then do; /* Must set bit */ set = "1"b; temp_name = substr (operand, 2); end; else if substr (operand, 1, 1) = "^" | substr (operand, 1, 1) = "-" then do; /* Reset */ set = "0"b; temp_name = substr (operand, 2); end; else do; /* Default is to set */ set = "1"b; temp_name = operand; end; if temp_name = "all" then do; if set then trace_mask = "777777"b3; else trace_mask = "0"b; go to next_trace_name; end; else if temp_name = "none" then do; if set then trace_mask = "0"b; else trace_mask = "777777"b3; go to next_trace_name; end; else do i = 1 to hbound (mask_name, 1); /* Look op name */ if mask_name (i) = temp_name then do; /* Got it */ substr (trace_mask, i, 1) = set; go to next_trace_name; end; end; call ioa_ ("Invalid trace mask name: ^a", temp_name); go to error_return; next_trace_name: call get_operand; end; call store (crtra, 1, addr (trace_mask)); /* Store result */ return; /* Entries to turn tracing on and off */ start_trace: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); trace_sw (1) = "0"b; start_or_stop_trace: call init; call store (crtsw, 1, addr (trace_sw (1))); return; stop_trace: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); trace_sw (1) = "000001"b3; go to start_or_stop_trace; /* Initializatioon */ init: proc; corep = arg_corep; fnp = arg_fnp; cmd_infop = arg_cmd_infop; expr_infop = arg_expr_infop; if symbols_looked_up then return; crtra = db_fnp_sym_util_$get_value (".crtra"); crtsw = db_fnp_sym_util_$get_value (".crtsw"); crtrb = db_fnp_sym_util_$get_value (".crtrb"); crtrc = db_fnp_sym_util_$get_value (".crtrc"); crmem = db_fnp_sym_util_$get_value (".crmem"); crtsz = db_fnp_sym_util_$get_value (".crtsz"); h1mb = db_fnp_sym_util_$get_value ("h1mb"); free_areap = get_system_free_area_ (); symbols_looked_up = "1"b; return; end init; /* Read and write memory words */ fetch: proc (a, n, p); dcl a fixed bin; dcl n fixed bin; dcl p ptr; call db_fnp_memory_$fetch (corep, fnp, a, n, p, code); if code = 0 then return; if n = 1 then call com_err_ (code, name, "Unable to read location ^o.", a); else call com_err_ (code, name, "Unable to read locations ^o thru ^o", a, a+n-1); go to error_return; store: entry (a, n, p); call db_fnp_memory_$store (corep, fnp, a, n, p, name, 0, code); if code = 0 then return; if n = 1 then call com_err_ (code, name, "Unable to write location ^o.", a); else call com_err_ (code, name, "Unable to write locations ^o thru ^o", a, a+n-1); go to error_return; end fetch; /* Get next operand from command line */ get_operand: proc; call db_fnp_reader_$get_operand (cmd_infop); if cmd_info.error then go to error_return; return; end get_operand; error_return: cmd_info.flush = "1"b; call clean_up; return; clean_up: proc; if trace_tabp ^= null () then free trace_tab; if trace_req_msgp ^= null () then free trace_req_msg; return; end clean_up; /* Procedure to "capture" the trace table */ capture_trace: proc; dcl offset fixed bin; /* Offset to current section */ dcl p ptr; dcl mem_size fixed bin; call fetch (crtrb, 1, addr (mem_word)); /* Read start address */ trace_tab_start = bin (mem_word (1)); if trace_tab_start = 0 then do; call ioa_ ("No trace table."); go to error_return; end; call fetch (crtrc, 1, addr (mem_word)); /* Read current pointer */ trace_tab_current = bin (mem_word (1)); tcur = trace_tab_current; call fetch (crmem, 1, addr (mem_word)); mem_size = bin (mem_word (1)); if (trace_tab_start < h1mb) | /* Gullability checks on pointers */ (trace_tab_start > mem_size) | (trace_tab_current < h1mb) | (trace_tab_current > mem_size) | (trace_tab_current < trace_tab_start) then do; bad_pointers: call ioa_ ("Unable to capture trace buffers: pointers inconsistent."); go to error_return; end; call fetch (crtsz, 1, addr (mem_word)); /* Read trace size */ if mem_word (1) = "0"b then do; /* The following code is for pre-MR8 systems where trace size is not known */ offset = 0; trace_tab_size = 1024; /* Read first 1024 words */ allocate trace_tab in (free_area); fetch_more: call fetch (trace_tab_start+offset, 1024, addr (trace_tab (offset+1))); /* Read next 1024 words */ if (trace_tab_current - trace_tab_start) >= trace_tab_size then do; /* Dont have section with current entry yet */ capture_more: /* So must grow table */ trace_tab_size = trace_tab_size+1024; allocate trace_tab in (free_area) set (p); /* Allocate bigger one */ trace_tab_size = trace_tab_size - 1024 ; /* Revert to smaller size temporarily */ unspec (p -> trace_tab) = unspec (trace_tab); /* Copy to new area */ free trace_tab; trace_tab_size = trace_tab_size + 1024; trace_tabp = p; /* New space ready */ offset = offset+1024; go to fetch_more; /* Go read next section */ end; check_next_entry: tmsgp = addr (trace_tab (tcur - trace_tab_start + 1)); if flag_word = physical_end | flag_word = logical_end then go to count_trace_entries; /* Whole table found */ tcur = tcur + bin (tmsg.length) + 2; /* Address of next one */ if tcur >= trace_tab_start + trace_tab_size then go to capture_more; /* Havent read necessary part yet */ else go to check_next_entry; end; /* The following code is MR8 and later systems where trace table size is known */ else do; trace_tab_size = bin (mem_word (1)); if trace_tab_current > trace_tab_start + trace_tab_size then go to bad_pointers; allocate trace_tab in (free_area); do offset = 0 to trace_tab_size - 1 by 1024; call fetch (trace_tab_start + offset, min (1024, trace_tab_size - offset), addr (trace_tab (offset + 1))); end; end; /* Now analyze captured trace */ count_trace_entries: trace_tab_cnt = 0; tcur = trace_tab_current; tmsgp = addr (trace_tab (tcur - trace_tab_start + 1)); do while (flag_word ^= logical_end); /* Loop to count entries */ if flag_word = physical_end then tcur = trace_tab_start; else do; tcur = tcur + bin (tmsg.length) + 2; trace_tab_cnt = trace_tab_cnt + 1; end; tmsgp = addr (trace_tab (tcur - trace_tab_start + 1)); end; return; end capture_trace; %include debug_fnp_data; end db_fnp_trace_;  db_fnp_util_.pl1 11/15/82 1816.2rew 11/15/82 1449.5 208944 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DB_FNP_UTIL_ - A series of entries that deal with internal tables in the FNP */ /* Written January 1977 by Larry Johnson */ /* format: style4,delnl,insnl,^ifthendo */ db_fnp_util_: proc; /* Parameters */ dcl arg_corep ptr; /* Pointer to segment containing fnp memory */ dcl arg_fnp fixed bin; /* The fnp number, for real fnps */ dcl arg_edited_addr char (*) var; /* String built by edit_module_addr entry */ dcl arg_fnp_addr fixed bin; /* Address in fnp memory */ dcl arg_code fixed bin (35); dcl arg_mod_name char (*); /* Name of module to be looked up */ dcl arg_tty_name char (*); /* Name of tty channel */ dcl arg_chan_name char (*); dcl arg_tty_line_no fixed bin; dcl arg_expr_infop ptr; dcl arg_modchp ptr; dcl arg_cmd_infop ptr; /* Automatic */ dcl fnp fixed bin; dcl code fixed bin (35); dcl (i, j, k) fixed bin; dcl mod_name char (8); dcl fnp_addr fixed bin; dcl corep ptr; /* Pointer to fnp core image */ dcl min_offset fixed bin; dcl addr_temp1 char (8) var; dcl addr_temp2 char (16) var; dcl word_buf bit (18) unal; dcl tty_fnp_no fixed bin; /* Fnp to which a tty is connected */ dcl tty_hsla_sw bit (1); /* Set if tty is on hsla */ dcl tty_la_no fixed bin; /* The relative hsla or lsla number */ dcl tty_chan_no fixed bin; /* Relative channel on channel */ dcl tty_slot_no fixed bin; /* Time slot position on lsla */ dcl tty_line_no fixed bin; dcl mem_word bit (18) unal; dcl force_sw bit (1); dcl paren_sw bit (1); dcl 1 tty_name unal, /* Format of a tty channel name */ 2 fnp_name char (1), 2 dot char (1), 2 la_type char (1), 2 la_no picture "9", 2 chan_no picture "99"; dcl modchp ptr; dcl 1 modch aligned based (modchp), /* Special module table used by trace */ 2 nmodules fixed bin, 2 entries (modch.nmodules), 3 name char (4), 3 address fixed bin; /* based */ dcl 1 fnptab aligned based (fnptabp), 2 per_fnp (0:8), 3 init_switches, 4 modtab_init bit (1) unal, /* Set when module table setup */ 4 iomtab_init bit (1) unal, /* Set when iom table setup */ 4 lslatab_init (0:5) bit (1) unal, 4 hslatab_init (0:2) bit (1) unal, 3 bind_time fixed bin (71), 3 boot_time fixed bin (71), 3 nmodules fixed bin, 3 per_module (50), 4 name char (6), 4 start fixed bin, 4 date char (6), 3 iom_table, 4 lsla_tab_addr (0:5) fixed bin, /* Addr of lsla tables in fnp */ 4 hsla_tab_addr (0:2) fixed bin, /* Likewise for hslas */ 3 per_lsla (0:5), 4 lsla_hwcm_addr fixed bin, 4 lsla_sfcm_addr fixed bin, 4 lsla_tib_addr (0:51) fixed bin (17) unal, 4 lsla_slot_no (0:51) fixed bin (17) unal, 3 per_hsla (0:2), 4 hsla_mbx_addr fixed bin, 4 hsla_tib_addr (0:31) fixed bin (17) unal; /* External stuff */ dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl db_fnp_sym_util_$get_value entry (char (*)) returns (fixed bin); dcl db_fnp_sym_util_$get_length entry (char (*)) returns (fixed bin); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl com_err_ entry options (variable); dcl parse_tty_name_ entry (char (*), fixed bin, bit (1), fixed bin, fixed bin); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl get_temp_segment_ entry (char (*), pointer, fixed bin (35)); dcl get_fnp_name_ entry (fixed bin) returns (char (32)); dcl error_table_$bad_arg ext fixed bin (35); dcl error_table_$noentry ext fixed bin (35); dcl (addr, bin, divide, hbound, lbound, min, mod, null, rtrim, size, string, substr, translate) builtin; /* constants */ dcl name char (12) int static options (constant) init ("db_fnp_util_"); dcl xlate (0:63) char (1) int static options (constant) init ( /* Bcd to ascii xlation table */ "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "[", "#", "@", ":", ">", "?", " ", "A", "B", "C", "D", "E", "F", "G", "H", "I", "&", ".", "]", "(", "<", "^", "|", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "-", "$", "*", ")", ";", "'", "+", "/", "S", "T", "U", "V", "W", "X", "Y", "Z", "_", ",", "%", "=", """", "!"); /* INTERNAL STATIC DATA */ dcl fnptabp ptr int static init (null ()); dcl constants_computed bit (1) int static init ("0"b); dcl crldt fixed bin int static; /* Address of bind time in 355 */ dcl crmod fixed bin int static; /* Address of module chain in 355 */ dcl criom fixed bin int static; dcl crtdt fixed bin int static; /* Address of T&D executive TIB */ dcl h_sfcm fixed bin int static; /* Offset to sfcm pointer in hwcm */ dcl h1ch fixed bin int static; /* First hsla channel number */ dcl l1ch fixed bin int static; /* First lsla channel number */ dcl hwcm_len fixed bin int static; /* PRINT_MODULE_TABLE - Entry that will print the module table for the fnp. This entry is a debug_fnp command. */ print_module_table: entry (arg_corep, arg_fnp, arg_cmd_infop, arg_expr_infop); call setup; cmd_infop = arg_cmd_infop; call setup_module_table; if code ^= 0 then do; call com_err_ (code, "", "Unable to get module table."); cmd_info.flush = "1"b; return; end; do i = 1 to fnptab.nmodules (fnp); call ioa_ ("^6a^8o ^a/^a/^a", fnptab.name (fnp, i), fnptab.start (fnp, i), substr (fnptab.date (fnp, i), 1, 2), substr (fnptab.date (fnp, i), 3, 2), substr (fnptab.date (fnp, i), 5, 2)); end; return; /* LOOKUP_MODULE - Entry to lookup one name in the module table */ lookup_module: entry (arg_corep, arg_fnp, arg_mod_name, arg_fnp_addr, arg_code); call setup; call setup_module_table; if code ^= 0 then do; arg_code = code; arg_fnp_addr = 0; return; end; mod_name = translate (arg_mod_name, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ"); do i = 1 to fnptab.nmodules (fnp); if fnptab.name (fnp, i) = mod_name then do; arg_fnp_addr = fnptab.start (fnp, i); arg_code = 0; return; end; end; arg_code = error_table_$noentry; arg_fnp_addr = 0; return; /* GET_SPECIAL_MODCH - returns module table in special form used by format_fnp_trace_msg_ */ get_special_modch: entry (arg_corep, arg_fnp, arg_modchp, arg_code); call setup; call setup_module_table; if code ^= 0 then do; arg_code = code; return; end; modchp = arg_modchp; i = min (fnptab.nmodules (fnp), modch.nmodules); /* Return what fits */ do j = 1 to i; modch.name (j) = fnptab.name (fnp, j); modch.address (j) = fnptab.start (fnp, j); end; modch.nmodules = i; /* Return actual count */ arg_code = 0; return; /* EDIT_MODULE_ADDR - Entry to edit a fnp address in the form module|offset */ edit_module_addr: entry (arg_corep, arg_fnp, arg_fnp_addr, arg_edited_addr, arg_code); force_sw, paren_sw = "0"b; edit_module_addr_join: call setup; fnp_addr = arg_fnp_addr; call setup_module_table; if code ^= 0 then do; arg_code = code; arg_edited_addr = ""; return; end; j = -1; /* No module found */ if fnp_addr < 0 | fnp_addr > 32767 then go to edit_module_offset; min_offset = 32768; do i = 1 to fnptab.nmodules (fnp); /* Check addr against each module */ k = fnp_addr - fnptab.start (fnp, i); /* Get an offset */ if (k >= 0) & (k < min_offset) then do; /* Found a possible */ j = i; /* Save its index */ min_offset = k; /* Remember lowest value found */ end; end; edit_module_offset: if j = -1 then addr_temp1 = ""; /* No module */ else do; addr_temp1 = rtrim (fnptab.name (fnp, j)); addr_temp1 = addr_temp1 || "|"; fnp_addr = min_offset; end; call ioa_$rsnnl ("^o", addr_temp2, (0), fnp_addr);/* Edit offset */ if addr_temp1 = "" then do; /* Out of range */ if force_sw | paren_sw then arg_edited_addr = addr_temp2; else arg_edited_addr = ""; end; else do; if ^paren_sw then arg_edited_addr = addr_temp1 || addr_temp2; else call ioa_$rsnnl ("^o (^a^a)", arg_edited_addr, (0), arg_fnp_addr, addr_temp1, addr_temp2); end; arg_code = 0; return; /* EDIT_MODULE_ADDR_FORCE - Like above, but returns octal for out of module range address */ edit_module_addr_force: entry (arg_corep, arg_fnp, arg_fnp_addr, arg_edited_addr, arg_code); force_sw = "1"b; paren_sw = "0"b; go to edit_module_addr_join; /* EDIT_MODULE_ADDR_PAREN - Like above, but returns "addr (mod|offset)" */ edit_module_addr_paren: entry (arg_corep, arg_fnp, arg_fnp_addr, arg_edited_addr, arg_code); force_sw = "0"b; paren_sw = "1"b; go to edit_module_addr_join; /* GET_CHAN_ADDRS - Entry which takes a tty channel name and finds its TIB address */ get_chan_addrs: entry (arg_corep, arg_fnp, arg_chan_name, arg_expr_infop, arg_code); call setup; expr_infop = arg_expr_infop; expr_info.tib_known, expr_info.hwcm_known, expr_info.sfcm_known = "0"b; tty_line_no = cv_oct_check_ (arg_chan_name, code);/* Check for all octal */ if code = 0 then do; call parse_tty_line_no; if tty_fnp_no < 0 then go to char_to_tib_bad_arg; end; else do; /* Character form name */ call parse_tty_name_ (arg_chan_name, tty_fnp_no, tty_hsla_sw, tty_la_no, tty_chan_no); if tty_fnp_no < 0 then go to char_to_tib_bad_arg; if arg_fnp > 0 then if arg_fnp ^= tty_fnp_no then /* Line not on current FNP */ go to char_to_tib_bad_arg; end; if tty_la_no = 7 /* handle T&D channel specially */ then do; call validate_fnp_data; call db_fnp_memory_$fetch (corep, fnp, crtdt, 1, addr (mem_word), code); if code ^= 0 then go to char_to_tib_err; if mem_word = "0"b then go to char_to_tib_bad_arg; expr_info.tib_addr = bin (mem_word); expr_info.tib_known = "1"b; /* but other data bases remain unknown */ end; else do; call setup_la_table; /* Find appropriate table */ if code ^= 0 then go to char_to_tib_err; if tty_hsla_sw then do; expr_info.hwcm_addr = fnptab.hsla_mbx_addr (fnp, tty_la_no) + hwcm_len * tty_chan_no; expr_info.hwcm_known = "1"b; if fnptab.hsla_tib_addr (fnp, tty_la_no, tty_chan_no) = 0 then go to char_to_tib_bad_arg; expr_info.tib_addr = fnptab.hsla_tib_addr (fnp, tty_la_no, tty_chan_no); expr_info.tib_known = "1"b; call db_fnp_memory_$fetch (corep, fnp, expr_info.hwcm_addr + h_sfcm, 1, addr (mem_word), code); if code ^= 0 then go to char_to_tib_err; expr_info.sfcm_addr = bin (mem_word); expr_info.sfcm_known = "1"b; end; else do; if tty_chan_no < 0 then call cv_lsla_slot_no; if tty_chan_no < 0 | tty_chan_no > 51 then go to char_to_tib_bad_arg; if fnptab.lsla_tib_addr (fnp, tty_la_no, tty_chan_no) = 0 then go to char_to_tib_bad_arg; expr_info.tib_addr = fnptab.lsla_tib_addr (fnp, tty_la_no, tty_chan_no); expr_info.tib_known = "1"b; expr_info.hwcm_addr = fnptab.lsla_hwcm_addr (fnp, tty_la_no); expr_info.hwcm_known = "1"b; expr_info.sfcm_addr = fnptab.lsla_sfcm_addr (fnp, tty_la_no); expr_info.sfcm_known = "1"b; end; end; arg_code = 0; return; char_to_tib_bad_arg: code = error_table_$bad_arg; char_to_tib_err: arg_code = code; return; /* Procedure that given a tty line number, computes a name */ cv_line_no: entry (arg_corep, arg_fnp, arg_tty_line_no, arg_tty_name, arg_code); call setup; tty_line_no = arg_tty_line_no; call parse_tty_line_no; /* Break number into components */ if tty_fnp_no < 0 then do; /* Error */ cv_line_bad: arg_code = error_table_$bad_arg; return; end; if ^tty_hsla_sw then do; call setup_la_table; if code ^= 0 then do; arg_code = code; return; end; call cv_lsla_slot_no; if tty_chan_no < 0 then go to cv_line_bad; end; tty_name.fnp_name = get_fnp_name_ (max (arg_fnp, 1)); tty_name.dot = "."; if tty_la_no = 7 then do; tty_name.la_type = "c"; tty_name.la_no, tty_name.chan_no = 0; end; else do; if tty_hsla_sw then tty_name.la_type = "h"; else tty_name.la_type = "l"; tty_name.la_no = tty_la_no; tty_name.chan_no = tty_chan_no; end; arg_tty_name = string (tty_name); arg_code = 0; return; /* Entry that given a name of a tty channel in either octal or ttyxxx form, returns the ttyname and the tty line number */ cv_chan_name: entry (arg_corep, arg_fnp, arg_chan_name, arg_tty_name, arg_tty_line_no, arg_code); call setup; arg_tty_line_no = 0; arg_tty_name = ""; tty_line_no = cv_oct_check_ (arg_chan_name, code);/* Try octal */ if code = 0 then /* Easy case, another entry already does this */ call cv_line_no (corep, arg_fnp, tty_line_no, arg_tty_name, code); else do; /* Given ttyxxx form */ call parse_tty_name_ (arg_chan_name, tty_fnp_no, tty_hsla_sw, tty_la_no, tty_chan_no); if tty_fnp_no < 0 then do; cv_chan_bad: arg_code = error_table_$bad_arg; return; end; if arg_fnp > 0 then if tty_fnp_no ^= arg_fnp then /* On wrong FNP */ go to cv_chan_bad; if tty_hsla_sw then /* Compute line number for hsla */ tty_line_no = 512 + 64 * tty_la_no + tty_chan_no; else do; /* Lslas are harder */ call setup_la_table; /* Need more data */ tty_slot_no = fnptab.lsla_slot_no (fnp, tty_la_no, tty_chan_no); if tty_slot_no = 0 then go to cv_chan_bad; tty_line_no = 64 * tty_la_no + tty_slot_no; end; arg_tty_name = arg_chan_name; /* Just return name given */ code = 0; end; arg_tty_line_no = tty_line_no; arg_code = code; return; /* Procedure to setup internal static fnp table */ setup_module_table: proc; dcl (i, j) fixed bin; dcl chainloc fixed bin; dcl 1 chain aligned, /* Entry in module chain */ 2 next bit (18) unal, 2 name (6) bit (6) unal, 2 start bit (18) unal, 2 date (6) bit (6) unal; call validate_fnp_data; if code ^= 0 then return; if fnptab.modtab_init (fnp) then return; /* Table all setup */ i = 0; call db_fnp_memory_$fetch (corep, fnp, crmod, 1, addr (chain.next), code); /* Get module chain start */ if code ^= 0 then return; chainloc = bin (chain.next); /* First chain is here */ do while ((chainloc ^= 0) & (i < hbound (fnptab.per_module, 2))); call db_fnp_memory_$fetch (corep, fnp, chainloc, 6, addr (chain), code); if code ^= 0 then return; i = i + 1; fnptab.start (fnp, i) = bin (chain.start); mod_name = ""; do j = 1 to 6; /* Convert name */ substr (mod_name, j, 1) = xlate (bin (chain.name (j))); end; fnptab.name (fnp, i) = translate (mod_name, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ"); do j = 1 to 6; /* Convert date */ substr (fnptab.date (fnp, i), j, 1) = xlate (bin (chain.date (j))); end; chainloc = bin (chain.next); /* Next pointer */ end; fnptab.nmodules (fnp) = i; fnptab.modtab_init (fnp) = "1"b; return; end setup_module_table; /* Procedure to get the table for the current line adapter setup */ setup_la_table: proc; call validate_fnp_data; if code ^= 0 then return; call setup_iom_table; /* Need this first */ if code ^= 0 then return; if tty_hsla_sw then call setup_hsla_table; /* Let some one else do the work */ else call setup_lsla_table; return; end setup_la_table; /* Procedure to find the iom table */ setup_iom_table: proc; dcl auto_iom_table (size (iom_table)) bit (36) aligned; /* To read iom table into */ dcl i fixed bin; if fnptab.iomtab_init (fnp) then return; /* Only do this once */ call db_fnp_memory_$fetch (corep, fnp, criom, 1, addr (word_buf), code); if code ^= 0 then return; itblp = addr (auto_iom_table); call db_fnp_memory_$fetch (corep, fnp, bin (word_buf), 2 * size (iom_table), itblp, code); if code ^= 0 then return; fnptab.lsla_tab_addr (fnp, *) = 0; fnptab.hsla_tab_addr (fnp, *) = 0; do i = lbound (iom_table, 1) to hbound (iom_table, 1); /* Pick out line adapters */ if iom_table.dev_type (i) = HSLA then fnptab.hsla_tab_addr (fnp, i - h1ch) = bin (iom_table.table (i)); else if iom_table.dev_type (i) = LSLA then fnptab.lsla_tab_addr (fnp, i - l1ch) = bin (iom_table.table (i)); end; fnptab.iomtab_init (fnp) = "1"b; code = 0; return; end setup_iom_table; /* Procedure to find all tib addresses for 1 hsla */ setup_hsla_table: proc; dcl auto_hsla_table (size (hsla_table)) bit (36) aligned; /* To read hsla table into */ dcl i fixed bin; if tty_chan_no < 0 | tty_chan_no > 31 then go to bad_hsla; if ^fnptab.hslatab_init (fnp, tty_la_no) then do; /* Only do this if new hsla */ i = fnptab.hsla_tab_addr (fnp, tty_la_no); /* Address of hsla table */ if i = 0 then do; /* Nothing on this hsla */ bad_hsla: code = error_table_$bad_arg; return; end; tblp = addr (auto_hsla_table); call db_fnp_memory_$fetch (corep, fnp, i, 2 * size (hsla_table), tblp, code); if code ^= 0 then return; do i = lbound (hsla_table, 1) to hbound (hsla_table, 1); /* Copy addresses */ fnptab.hsla_tib_addr (fnp, tty_la_no, i) = hsla_table.tib_addr (i); end; fnptab.hsla_mbx_addr (fnp, tty_la_no) = get_mbx_addr ("h"); fnptab.hslatab_init (fnp, tty_la_no) = "1"b; end; code = 0; return; end setup_hsla_table; /* Procedure to find all the tib addresses for 1 lsla */ setup_lsla_table: proc; dcl auto_lsla_table (size (lsla_table)) bit (36) aligned; /* To read lsla table into */ dcl (i, j, k) fixed bin; dcl mem_word bit (18) unal; if ^fnptab.lslatab_init (fnp, tty_la_no) then do; /* If not done yet */ i = fnptab.lsla_tab_addr (fnp, tty_la_no); /* Addr of lsla table */ if i = 0 then do; code = error_table_$bad_arg; return; end; tblp = addr (auto_lsla_table); call db_fnp_memory_$fetch (corep, fnp, i, 2 * size (lsla_table), tblp, code); if code ^= 0 then return; j, k = 0; fnptab.lsla_tib_addr (fnp, tty_la_no, *) = 0; fnptab.lsla_slot_no (fnp, tty_la_no, *) = 0; do i = 1 to hbound (lsla_table, 1); /* Copy all tib address */ if lsla_table.slot_id (i) = "111"b then go to setup_lsla_done; if lsla_table.tib_addr (i) ^= k then do; /* New tib */ fnptab.lsla_tib_addr (fnp, tty_la_no, j), k = lsla_table.tib_addr (i); fnptab.lsla_slot_no (fnp, tty_la_no, j) = i; j = j + 1; end; end; setup_lsla_done: fnptab.lsla_hwcm_addr (fnp, tty_la_no) = get_mbx_addr ("l"); call db_fnp_memory_$fetch (corep, fnp, fnptab.lsla_hwcm_addr (fnp, tty_la_no) + h_sfcm, 1, addr (mem_word), code); if code ^= 0 then return; fnptab.lsla_sfcm_addr (fnp, tty_la_no) = bin (mem_word); fnptab.lslatab_init (fnp, tty_la_no) = "1"b; end; code = 0; return; end setup_lsla_table; /* Procedure line parse_tty_name that "parses" a line number */ parse_tty_line_no: proc; tty_fnp_no = -1; /* Error flag */ tty_hsla_sw = (tty_line_no >= 512); tty_chan_no = mod (tty_line_no, 64); tty_la_no = mod (divide (tty_line_no, 64, 17, 0), 8); if tty_line_no ^= (512 * bin (tty_hsla_sw, 1) + 64 * tty_la_no + tty_chan_no) then return; /* Doesn't compute */ if tty_hsla_sw then do; if tty_la_no > 2 & tty_la_no ^= 7 then return; if tty_la_no = 7 /* this should be T&D channel */ & tty_chan_no ^= 63 /* but it isn't */ then return; end; else do; if tty_la_no > 5 then return; tty_slot_no = tty_chan_no; /* This is really a time slot */ tty_chan_no = -1; /* The subchannel isn't known */ end; tty_fnp_no = 1; /* No error */ return; end parse_tty_line_no; /* Procedure to convert from a lsla slot number to channel number */ cv_lsla_slot_no: proc; dcl i fixed bin; do i = lbound (fnptab.lsla_slot_no, 3) to hbound (fnptab.lsla_slot_no, 3); if fnptab.lsla_slot_no (fnp, tty_la_no, i) = tty_slot_no then do; tty_chan_no = i; return; end; if fnptab.lsla_slot_no (fnp, tty_la_no, i) > tty_slot_no then do; tty_chan_no = i - 1; /* Other than the first time slot of a channel */ return; end; end; return; /* Couldn't do it */ end cv_lsla_slot_no; /* Procedure which checks to be sure that the static FNP data is still valid. */ /* The check is to see if times in the core image have changed */ validate_fnp_data: proc; dcl 1 times aligned, 2 bind_time fixed bin (71), 2 boot_time fixed bin (71); call compute_constants; call db_fnp_memory_$fetch (corep, fnp, crldt, 8, addr (times), code); /* Get bind and boot time */ if code ^= 0 then return; if fnptab.bind_time (fnp) ^= times.bind_time | fnptab.boot_time (fnp) ^= times.boot_time then string (fnptab.init_switches (fnp)) = "0"b; fnptab.bind_time (fnp) = times.bind_time; fnptab.boot_time (fnp) = times.boot_time; return; end validate_fnp_data; /* Procedure to computing the addresses of some constants in the 355 */ compute_constants: proc; dcl i fixed bin; if fnptabp = null () then call get_temp_segment_ (name, fnptabp, code); if constants_computed then return; /* Do this once per process */ crldt = db_fnp_sym_util_$get_value (".crldt"); crmod = db_fnp_sym_util_$get_value (".crmod"); criom = db_fnp_sym_util_$get_value (".criom"); crtdt = db_fnp_sym_util_$get_value (".crtdt"); h_sfcm = db_fnp_sym_util_$get_value ("h.sfcm"); l1ch = db_fnp_sym_util_$get_value ("l1ch"); h1ch = db_fnp_sym_util_$get_value ("h1ch"); hwcm_len = db_fnp_sym_util_$get_length ("hwcm"); do i = lbound (fnptab.init_switches, 1) to hbound (fnptab.init_switches, 1); string (fnptab.init_switches (i)) = "0"b; end; fnptab.bind_time = 0; /* And all these numbers */ fnptab.boot_time = 0; constants_computed = "1"b; return; end compute_constants; /* Get address of a mailbox */ get_mbx_addr: proc (t) returns (fixed bin); dcl t char (1); dcl 1 mb_name unal, 2 type char (1) unal, 2 num picture "9" unal, 2 mb char (2) unal; mb_name.type = t; mb_name.num = tty_la_no + 1; mb_name.mb = "mb"; return (db_fnp_sym_util_$get_value (string (mb_name))); end get_mbx_addr; /* Initialization procedure to copy seg pointer and fnp args */ setup: proc; corep = arg_corep; if corep = null then fnp = arg_fnp; /* Real fnp */ else fnp = 0; return; end setup; %include mcs_memory_map; %include debug_fnp_data; end db_fnp_util_;  debug_fnp.pl1 11/15/82 1816.2rew 11/15/82 1502.3 113373 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DEBUG_FNP - A tool for analyzing FNP dumps and debugging FNP software. */ /* Written February 1977 by Larry Johnson */ /* Modified 7/24/78 by J. Stern to add buffer_status command */ /* Modified September 1978 by Larry Johnson for call_trace command */ debug_fnp: db_fnp: proc; /* Automatic and related things */ dcl code fixed bin (35); dcl i fixed bin; dcl fnp fixed bin; /* Current fnp, if working on live fnp */ dcl corep ptr; /* Pointer to fnp core image in a segment */ dcl arg_ptr ptr; dcl arg_len fixed bin; dcl arg char (arg_len) based (arg_ptr); dcl 1 auto_expr_info like expr_info aligned automatic; dcl 1 auto_cmd_info like cmd_info aligned automatic; dcl 1 auto_env like env aligned automatic; dcl 1 user_symbol_table aligned, 2 cnt fixed bin, 2 maxcnt fixed bin, 2 entry (50) unal, 3 one_symbol like sym unal; /* Constants */ dcl name char (9) int static options (constant) init ("debug_fnp"); /* Commands are numbered internally as follows: 01 - fnp 02 - dump 03 - image 04 - map 05 - e 06 - quit 07 - convert_address 08 - display 09 - line 10 - . 11 - patch 12 - = 13 - what 14 - why 15 - regs 16 - buffer 17 - buffer_chain 18 - set 19 - set_break 20 - start 21 - reset_break 22 - list_break 23 - dump_dir 24 - dumps 25 - last_dump 26 - prev_dump 27 - trace_mask 28 - start_trace 29 - stop_trace 30 - print_trace 31 - select_fnp 32 - next_dump 33 - block 34 - block_chain 35 - flags 36 - explain 37 - buffer_status 38 - call_trace 39 - set_flag 40 - clear_flag 41 - idle_time 42 - ic_sample 43 - sample_time 44 - mdisp_data 45 - apropos 46 - when */ /* List of commands and their abbreviations. An index in this array is translated by cmd_no into a command number */ dcl cmd_list (61) char (16) int static options (constant) init ( "fnp", /* 1 */ "dump", /* 2 */ "image", /* 3 */ "map", /* 4 */ "e", /* 5 */ "quit", /* 6 */ "q", /* 7 */ "convert_address", /* 8 */ "cva", /* 9 */ "display", /* 10 */ "d", /* 11 */ "line", /* 12 */ ".", /* 13 */ "patch", /* 14 */ "=", /* 15 */ "what", /* 16 */ "why", /* 17 */ "regs", /* 18 */ "buffer", /* 19 */ "buf", /* 20 */ "buffer_chain", /* 21 */ "bufc", /* 22 */ "set", /* 23 */ "set_break", /* 24 */ "sb", /* 25 */ "start", /* 26 */ "sr", /* 27 */ "reset_break", /* 28 */ "rb", /* 29 */ "list_break", /* 30 */ "lb", /* 31 */ "dump_dir", /* 32 */ "dumps", /* 33 */ "last_dump", /* 34 */ "prev_dump", /* 35 */ "trace_mask", /* 36 */ "start_trace", /* 37 */ "stop_trace", /* 38 */ "print_trace", /* 39 */ "select_fnp", /* 40 */ "next_dump", /* 41 */ "block", /* 42 */ "blk", /* 43 */ "block_chain", /* 44 */ "blkc", /* 45 */ "flags", /* 46 */ "explain", /* 47 */ "buffer_status", /* 48 */ "bstat", /* 49 */ "call_trace", /* 50 */ "trace_call", /* 51 */ "trace_calls", /* 52 */ "set_flag", /* 53 */ "clear_flag", /* 54 */ ".q", /* 55 */ "idle_time", /* 56 */ "ic_sample", /* 57 */ "sample_time", /* 58 */ "mdisp_data", /* 59 */ "apropos", /* 60 */ "when"); /* 61 */ /* This array maps the index of "cmd_list" into a command number */ dcl cmd_no (61) fixed bin (11) unal int static options (constant) init ( 01, 02, 03, 04, 05, 06, 06, 07, 07, 08, /* 01-10 */ 08, 09, 10, 11, 12, 13, 14, 15, 16, 16, /* 11-20 */ 17, 17, 18, 19, 19, 20, 20, 21, 21, 22, /* 21-30 */ 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, /* 31-40 */ 32, 33, 33, 34, 34, 35, 36, 37, 37, 38, /* 41-50 */ 38, 38, 39, 40, 06, 41, 42, 43, 44, 45, /* 51-60 */ 46); /* 61 */ /* This array, indexed by command number says whether some fnp, dump, or core image must be selected before the command can be used. */ dcl select_required (46) bit (1) unal int static options (constant) init ( "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, /* 01-10 */ "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, /* 11-20 */ "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, /* 21-30 */ "1"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, /* 31-40 */ "1"b, "1"b, "1"b, "1"b, "0"b, "1"b); /* 41-46 */ /* All commands are passed through the following entry array. */ dcl cmd_entry (46) entry (ptr, fixed bin, ptr, ptr) variable init ( db_fnp_env_$fnp_cmd, /* 1 */ db_fnp_env_$dump_cmd, /* 2 */ db_fnp_env_$image_cmd, /* 3 */ db_fnp_util_$print_module_table, /* 4 */ execute_command, /* 5 */ quit_command, /* 6 */ db_fnp_convert_address_, /* 7 */ db_fnp_disp_cmd_$display, /* 8 */ db_fnp_env_$line, /* 9 */ dot_command, /* 10 */ db_fnp_disp_cmd_$patch, /* 11 */ db_fnp_disp_cmd_$equal, /* 12 */ db_fnp_env_$what, /* 13 */ db_fnp_dumps_$why, /* 14 */ db_fnp_dumps_$regs, /* 15 */ db_fnp_disp_cmd_$buffer, /* 16 */ db_fnp_disp_cmd_$buffer_chain, /* 17 */ db_fnp_sym_util_$set_command, /* 18 */ db_fnp_break_$set, /* 19 */ db_fnp_break_$start, /* 20 */ db_fnp_break_$reset, /* 21 */ db_fnp_break_$list, /* 22 */ db_fnp_env_$dump_dir, /* 23 */ db_fnp_env_$dumps, /* 24 */ db_fnp_env_$last_dump, /* 25 */ db_fnp_env_$prev_dump, /* 26 */ db_fnp_trace_$mask, /* 27 */ db_fnp_trace_$start_trace, /* 28 */ db_fnp_trace_$stop_trace, /* 29 */ db_fnp_trace_$print_trace, /* 30 */ db_fnp_env_$select_fdump_fnp, /* 31 */ db_fnp_env_$next_dump, /* 32 */ db_fnp_disp_cmd_$block, /* 33 */ db_fnp_disp_cmd_$block_chain, /* 34 */ db_fnp_disp_cmd_$flags, /* 35 */ db_fnp_sym_util_$explain, /* 36 */ db_fnp_buffer_status_, /* 37 */ db_fnp_call_trace_, /* 38 */ db_fnp_disp_cmd_$set_flag, /* 39 */ db_fnp_disp_cmd_$clear_flag, /* 40 */ db_fnp_scheduler_$idle_time, /* 41 */ db_fnp_scheduler_$ic_sample, /* 42 */ db_fnp_scheduler_$sample_time, /* 43 */ db_fnp_scheduler_$mdisp_data, /* 44 */ db_fnp_sym_util_$apropos, /* 45 */ db_fnp_env_$when); /* 46 */ /* External stuff */ dcl com_err_ entry options (variable); dcl cu_$cp entry (ptr, fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl db_fnp_break_$list entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_break_$reset entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_break_$set entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_break_$start entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_buffer_status_ entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_call_trace_ entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_convert_address_ entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_disp_cmd_$flags entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_disp_cmd_$display entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_disp_cmd_$patch entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_disp_cmd_$equal entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_disp_cmd_$buffer entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_disp_cmd_$buffer_chain entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_disp_cmd_$block entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_disp_cmd_$block_chain entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_disp_cmd_$set_flag entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_disp_cmd_$clear_flag entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_dumps_$regs entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_dumps_$why entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$fnp_cmd entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$dump_cmd entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$image_cmd entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$dumps entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$last_dump entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$prev_dump entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$next_dump entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$select_fdump_fnp entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$dump_dir entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$what entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$when entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$line entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_env_$init entry (ptr); dcl db_fnp_env_$term entry (ptr); dcl db_fnp_reader_$get_command entry (ptr); dcl db_fnp_scheduler_$ic_sample entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_scheduler_$idle_time entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_scheduler_$mdisp_data entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_scheduler_$sample_time entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_sym_util_$apropos entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_sym_util_$set_command entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_sym_util_$explain entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_trace_$mask entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_trace_$print_trace entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_trace_$start_trace entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_trace_$stop_trace entry (ptr, fixed bin, ptr, ptr); dcl db_fnp_util_$print_module_table entry (ptr, fixed bin, ptr, ptr); dcl ioa_ entry options (variable); dcl (cleanup, program_interrupt) condition; dcl (addr, hbound, length, string) builtin; /* Initialization */ expr_infop = addr (auto_expr_info); cmd_infop = addr (auto_cmd_info); envp = addr (auto_env); cmd_info.flush = "1"b; cmd_info.envp = envp; expr_info.user_tablep = addr (user_symbol_table); user_symbol_table.cnt = 0; user_symbol_table.maxcnt = hbound (user_symbol_table.entry, 1); string (expr_info.flags) = "0"b; call db_fnp_env_$init (envp); /* Initalize environment */ fnp = env.fnp; corep = env.corep; on program_interrupt begin; cmd_info.flush = "1"b; go to next_cmd; end; on cleanup call db_fnp_env_$term (envp); call cu_$arg_count (i); if i > 0 then do; /* There is an arg */ call cu_$arg_ptr (1, arg_ptr, arg_len, code); cmd_info.inbuf = ";" || arg; cmd_info.commandp = addr (cmd_info.inbuf); cmd_info.commandl = arg_len + 1; cmd_info.flush, cmd_info.error, cmd_info.endline = "0"b; end; /* Command dispatcher */ next_cmd: /* Everyone returns here for next command */ call db_fnp_reader_$get_command (cmd_infop); do i = 1 to hbound (cmd_list, 1); /* Check against all known commands */ if operand = cmd_list (i) then do; if select_required (cmd_no (i)) then if ^(env.fnp_sw | env.dump_sw | env.image_sw) then do; call ioa_ ("No FNP, dump, or image selected."); cmd_info.flush = "1"b; go to next_cmd; end; call cmd_entry (cmd_no (i)) (corep, fnp, cmd_infop, expr_infop); fnp = env.fnp; /* In case changed */ corep = env.corep; go to next_cmd; end; end; call ioa_ ("Undefined command: ^a", operand); go to next_cmd; /* Come here to stop command completely */ done: call db_fnp_env_$term (envp); return; /* DOT COMMAND - Doesn't do much */ dot_command: proc; call ioa_ ("^a", name); return; end dot_command; /* QUIT COMMAND - Ends the program */ quit_command: proc; go to done; end quit_command; /* EXECUTE COMMAND - pass rest of command line to the current command processor */ execute_command: proc; call cu_$cp (addr (command), length (command), code); cmd_info.flush = "1"b; /* We dont look at rest of line */ return; end execute_command; %include debug_fnp_data; end debug_fnp; 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