bind_fnp.pl1 11/15/82 1821.5rew 11/15/82 1449.8 202590 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ bind_fnp: proc; /* This command produces a core image from FNP object segments. Written by S.E. Barr 5/76 Modified 1/9/78 by J. Stern to add -cross_ref control arg. Modified 3/15/78 by J. Stern to not require a trace module. Modified 1979 May 9 by Art Beattie to accept FNP memory size of 64. Modified 1981 Jan 22 by Robert Coren to accept "meter" keyword. Modified 1981 June by R Holmstedt to search only working dir for object. Modified 1982 April by Robert Coren to allow memory sizes up to 256K and to eliminate the -simulator control argument. */ dcl bind_info_ptr ptr; /* ptr to scratch area for bindfile information */ dcl bind_len fixed bin; /* number of characters in bindfile */ dcl bind_ptr ptr; /* ptr to bindfile */ dcl cleanup condition; dcl code fixed bin (35); /* standard Multics code */ dcl fatal_error bit (1) unal; /* ON if fatal error */ dcl get_search_rules bit (1) unal; /* ON if user supplied search rules */ dcl list_attach bit (1) unal; /* ON if iox_ attach was completed */ dcl list_open bit (1) unal; /* ON if iox_ open was completed */ dcl list_ptr ptr; dcl obj_acl_ptr ptr; /* acl information used for tssi_ cleanup */ dcl obj_ptr ptr; /* ptr to core image segment */ dcl arg_version char (4); /* version number supplied as arg */ /* based */ dcl 1 b aligned based (bind_info_ptr) like bind_fnp_info; dcl ptr_array (1) ptr based; dcl (addr, divide, hbound, index, length, verify, mod, null, reverse, search, substr, string, unspec) builtin; /* external */ dcl bind_fnp_load_ entry (ptr, bit (1) unal); dcl com_err_ entry options (variable); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl get_wdir_ entry () returns (char (168)); 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 ioa_$ioa_switch entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$error_output fixed bin (35) ext; dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)); dcl tssi_$clean_up_segment entry (ptr); dcl tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)); dcl tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)); %include bind_fnp_info; bind_info_ptr, bind_ptr, list_ptr, obj_ptr = null; arg_version = ""; num_unresolved = 0; /* to prevent error message at compile */ on cleanup call cleanup_proc ("1"b); call get_temp_segments_ ("bind_fnp", addr (bind_info_ptr) -> ptr_array, code); call parse_args; b.metering_enabled = "1"b; /* for now, at least, let's make metering the default */ call parse_bindfile; if ^fatal_error then do; if arg_version ^= "" then b.version = arg_version; b.list_ptr = list_ptr; b.obj_ptr = obj_ptr; call bind_fnp_load_ (bind_info_ptr, fatal_error); end; if ^fatal_error then do; call tssi_$finish_segment (obj_ptr, b.obj_len*36, "11"b, obj_acl_ptr, code); call cleanup_proc ("0"b); end; else call abort (0, "Binding unsuccessful"); RETURN: return; /* This procedure prints error messages on error_output and into the list segment. */ print: proc (message); dcl message char (*); if b.list then do; if ^b.error_header then do; b.error_header = "1"b; call ioa_$ioa_switch (list_ptr, "ERROR MESSAGES^/^/"); end; call ioa_$ioa_switch (list_ptr, "^a", message); end; call ioa_$ioa_switch (iox_$error_output, message); return; end print; abort: proc (code, message); dcl code fixed bin (35); dcl message char (*); call com_err_ (code, "bind_fnp", message); call cleanup_proc ("1"b); goto RETURN; end abort; cleanup_proc: proc (error); dcl error bit (1) unal; /* ON if called by cleanup condition */ dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); if bind_info_ptr ^= null then call release_temp_segments_ ("bind_fnp", addr (bind_info_ptr) -> ptr_array, code); if bind_ptr ^= null then call hcs_$terminate_noname (bind_ptr, code); if obj_ptr ^= null then if error then call tssi_$clean_up_segment (obj_acl_ptr); if list_ptr ^= null then do; if list_open then do; list_open = "0"b; call iox_$close (list_ptr, code); if code ^= 0 then call com_err_ (code, "Attempted to close .list segment."); end; if list_attach then do; list_attach = "0"b; call iox_$detach_iocb (list_ptr, code); if code ^= 0 then call com_err_ (code, "Attempted to detach .list segment."); end; end; end cleanup_proc; parse_args: proc ; dcl arg char (arg_len) based (arg_ptr); dcl path char (168); dcl dir_name char (168); dcl entry_name char (32); dcl arg_len fixed bin; dcl arg_ptr ptr; dcl bit_count fixed bin (24); dcl nargs fixed bin; dcl i fixed bin; dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$wrong_no_of_args fixed bin (35) ext; b.list, list_open, list_attach, get_search_rules = "0"b; path = ""; call cu_$arg_count (nargs); if nargs > 0 then do; do i = 1 to nargs; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then call abort (code, "Attempted to get argument."); if substr (arg, 1, 1) = "-" then do; if arg = "-list" | arg = "-ls" then b.list = "1"b; else if arg = "-search" | arg = "-se" then get_search_rules = "1"b; else if arg = "-version" | arg = "-vers" then do; i = i + 1; if i > nargs then call abort (error_table_$wrong_no_of_args, "Version not supplied"); call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then call abort (code, ""); arg_version = arg; end; else if arg = "-cross_ref" | arg = "-cref" then b.list, b.cross_ref = "1"b; else call abort (error_table_$badopt, arg); end; else do; if path = "" then do; if arg_len < 10 | substr (arg, arg_len - 8, 9) ^= ".bind_fnp" then path = arg || ".bind_fnp"; else path = arg; end; else call abort (error_table_$badopt, arg); end; end; end; else call abort (error_table_$wrong_no_of_args, "Usage: bind_fnp path {-list} {-search} {-simulator} {-version} {-cross_ref}"); if path = "" then call abort (error_table_$wrong_no_of_args, "Pathname missing"); /* get pointers to bindfile (bind_ptr), listing output (list_ptr), and core image segment (obj_ptr) */ i = length (path) + 1 - verify (reverse (path), " "); call expand_path_ (addr (path), i, addr (dir_name), addr (entry_name), code); if code = 0 then do; call hcs_$initiate_count (dir_name, entry_name, "", bit_count, 0, bind_ptr, code); if bind_ptr ^= null then do; bind_len = divide (bit_count, 9, 21, 0); dir_name = get_wdir_ (); i = length (entry_name) - index (reverse (entry_name), reverse (".bind_fnp")) - 8; b.obj_name, entry_name = substr (entry_name, 1, i); call tssi_$get_segment (dir_name, entry_name, obj_ptr, obj_acl_ptr, code); /* if list option, get segment and make vfile_ attachment */ if code = 0 & b.list then do; entry_name = substr (entry_name, 1, i) || ".list"; call iox_$attach_ioname ("bind_fnp_list", list_ptr, "vfile_ " || substr (entry_name, 1, i+5), code); if code = 0 then do; list_attach = "1"b; call iox_$open (list_ptr, 2, "0"b, code); if code = 0 then list_open = "1"b; end; end; end; if code = 0 then do; call set_search_directories (substr (entry_name, 1, i)); return; end; call abort (code, substr (dir_name, 1, length (dir_name) + 1 - verify (reverse (dir_name), " ")) || ">" || entry_name); end; else call abort (code, path); end parse_args; /* If the user specified a segment of search rules, it must be in the working directory and have the same name as the object segment with a suffix of ".search". Otherwise the working directory and the default directory will be used. */ set_search_directories: proc (name); dcl name char (*); dcl bit_count fixed bin (24); dcl seg_ptr ptr; dcl seg_end fixed bin; /* length of search rules segment */ dcl seg_start fixed bin; /* index to current directory */ /* constants */ dcl WHITE_SPACE char (3) int static options (constant) init (" "); /* tab blank new_line */ dcl seg char (seg_end) based (seg_ptr); if get_search_rules then do; call hcs_$initiate_count (get_wdir_ (), name || ".search", "", bit_count, 0, seg_ptr, code); if seg_ptr ^= null then do; seg_start = 1; seg_end = divide (bit_count, 9, 17, 0); b.num_directories = 0; do while (get_directory ()); end; if b.num_directories < 1 then call print ("No search rules were specified"); call hcs_$terminate_noname (seg_ptr, (0)); end; else call abort (code, name || ".search"); end; else do; b.num_directories = 1; /* we only do working dir by default.*/ call get_working_dir (b.directory (1)); end; return; get_working_dir: proc (dir); dcl dir char (*) var; dir = get_wdir_ (); dir = substr (dir, 1, length (dir) + 1 - verify (reverse (dir), " ")); end get_working_dir; get_directory: proc () returns (bit (1) unal); dcl i fixed bin; i = verify (substr (seg, seg_start), WHITE_SPACE) -1; if i > -1 then do; seg_start = seg_start + i; i = search (substr (seg, seg_start), WHITE_SPACE) -1; if i > -1 then do; b.num_directories = b.num_directories + 1; if b.num_directories <= hbound (b.directory, 1) then do; if substr (seg, seg_start, i) = "working_dir" then call get_working_dir (b.directory (b.num_directories)); else b.directory (b.num_directories) = substr (seg, seg_start, i); seg_start = seg_start + i; return ("1"b); end; else do; fatal_error = "1"b; call print ("Too many directories specified " || substr (seg, seg_start, i)); end; end; else call print ("Search file must end with a new line character"); end; return ("0"b); end get_directory; end set_search_directories; parse_bindfile: proc; dcl b_len fixed bin; dcl b_ptr ptr; dcl break fixed bin; dcl break_char char (break_len) based (break_ptr); dcl break_len fixed bin; dcl break_ptr ptr; dcl eof fixed bin; dcl found_console_man bit (1) init ("0"b); dcl module_name char (32); dcl module_size fixed bin; dcl module_type fixed bin; dcl token char (token_len) based (token_ptr); dcl token_len fixed bin; dcl token_ptr ptr; dcl (i, k) fixed bin; dcl 1 parse_flags aligned, 2 got_hsla bit (1) unal, 2 got_lsla bit (1) unal, 2 got_memory bit (1) unal, 2 got_console bit (1) unal, 2 got_printer bit (1) unal, 2 got_entry bit (1) unal, 2 got_order bit (1) unal, 2 got_mask bit (1) unal, 2 got_vers bit (1) unal, 2 got_meters bit (1) unal; dcl got_end bit (1) unal; /* constant */ dcl PRINT_TOKEN bit (1) unal int static options (constant) init ("1"b); dcl N_REQUIRED_KEYWORDS fixed bin int static options (constant) init (9); dcl default_size (3) fixed bin int static options (constant) init (92, 92, 256); dcl type_keyword (3) char (5) int static init ("lsla", "hsla", "trace"); dcl keyword (13) char (12) var int static init ("hsla", "lsla", "memory", "console", "printer", "entry", "order", "mask", "version", "meter", "module", "type", "size"); /* external */ dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl parse_file_$parse_file_init_ptr entry (ptr, fixed bin); dcl parse_file_$parse_file_unset_break entry (char (*)); dcl parse_file_$parse_file_ptr entry (ptr, fixed bin, fixed bin, fixed bin); dcl parse_file_$parse_file_line_no entry () returns (fixed bin); /* print header and bindfile if listing was requested */ if b.list then do; call ioa_$ioa_switch (list_ptr, "^-^-Bindfile for ^a^/^/", b.obj_name); call iox_$put_chars (list_ptr, bind_ptr, bind_len, code); call ioa_$ioa_switch (list_ptr, "^|"); end; b_ptr = bind_ptr; b_len = bind_len; call parse_file_$parse_file_init_ptr (b_ptr, b_len); call parse_file_$parse_file_unset_break (">_$.-+"); b.error_header, fatal_error, string (parse_flags), got_end = "0"b; module_name, b.module (*).name = ""; b.num_segs = 0; continue_parse: do while (get_token ()); /* get keyword followed by ':' */ if break_char = ":" then do; k = 0; do i = 1 to hbound (keyword, 1) while (k = 0); if keyword (i) = token then do; k = i; if k <= 10 then do; if ^substr (string (parse_flags), i, 1) then substr (string (parse_flags), i, 1) = "1"b; else call parse_error (PRINT_TOKEN, "statement already specified"); end; end; end; if k = 0 then call parse_error (PRINT_TOKEN, "unrecognized keyword"); call parse_statement (k); end; /* check for end statement */ else if token = "end" & break_char = ";" then do; got_end = "1"b; if get_token () then call parse_error (PRINT_TOKEN, "information follows end statement"); end; else call parse_error (PRINT_TOKEN, "syntax error in statement"); end; call set_module; /* finish module statement */ if b.module (3).name = "" then do; /* no trace module */ b.module (3).size = 0; parse_flags.got_mask = "1"b; b.mask = ""b; end; /* make sure all required keywords were present */ if ^substr (string (parse_flags), 1, N_REQUIRED_KEYWORDS) ^= ""b then do; do i = 1 to N_REQUIRED_KEYWORDS; if ^substr (string (parse_flags), i, 1) then call print (keyword (i) || " statement missing"); fatal_error = "1"b; end; end; if ^got_end then call print ("End statement is missing"); /* warning only */ /* make sure special module types were specified and were present in the order statement */ if got_order then do; do i = 1 to 3; if b.module (i).name ^= "" then do; do k = 1 to b.num_segs while (b.module (i).name ^= b.segs (k).seg_name); end; if k > b.num_segs then do; fatal_error = "1"b; call print ("Module missing from order statement """ || b.module (i).name || """"); end; end; end; end; /* console_man has to be in module list if a console is configured */ if b.console & ^found_console_man then do; fatal_error = "1"b; call print ("Console was configured without console_man module"); end; return; parse_statement: proc (k); dcl k fixed bin; if keyword (k) ^= "order" then do; if get_token () then do; if break_char ^= ";" then call parse_error (PRINT_TOKEN, "break character "";"" is missing "); end; else return; end; goto label (k); /* hsla */ label (1): b.num_hsla = cv_dec_check_ (token, code); if code = 0 then if b.num_hsla >= 0 & b.num_hsla <= 3 then return; call parse_error (PRINT_TOKEN, "illegal value"); /* lsla */ label (2): b.num_lsla = cv_dec_check_ (token, code); if code = 0 then if b.num_lsla >= 0 & b.num_lsla <= 6 then return; call parse_error (PRINT_TOKEN, "illegal value"); /* memory */ label (3): b.memory = cv_dec_check_ (token, code); if code = 0 then if b.memory <= 256 & b.memory > 0 & mod (b.memory, 32) = 0 then return; call parse_error (PRINT_TOKEN, "illegal value"); /* console */ label (4): if token = "yes" | token = "no" then do; b.console = (token = "yes"); return; end; call parse_error (PRINT_TOKEN, "yes or no expected"); /* printer */ label (5): if token = "yes" | token = "no" then do; b.printer = (token = "yes"); return; end; call parse_error (PRINT_TOKEN, "yes or no expected"); /* entry */ label (6): if token_len <= length (b.entry) then do; b.entry = token; return; end; call parse_error (PRINT_TOKEN, "entry name too long"); /* order */ label (7): do while (get_token ()); if token_len > 6 then if substr (token, token_len - 5, 6) = ".objdk" then token_len = token_len -6; if token_len <= 25 then do; /* source must be name.map355 */ do i = 1 to b.num_segs; if token = b.segs (i).seg_name then call parse_error (PRINT_TOKEN, "duplication in order statement"); end; b.num_segs = b.num_segs + 1; b.segs (b.num_segs).seg_name = token; if token = "console_man" then found_console_man = "1"b; end; else call parse_error (PRINT_TOKEN, "segment name too long"); if break_char = ";" then return; end; return; /* mask */ label (8): if module_name = "" then call parse_error (^PRINT_TOKEN, "module and type statements must precede mask"); if module_type = 0 then call parse_error (^PRINT_TOKEN, "type statement must precede mask"); if module_type ^= 3 then call parse_error (^PRINT_TOKEN, "mask statement invalid for modules not of type trace"); if token_len = 6 then do; i = cv_oct_check_ (token, code); b.mask = substr (unspec (i), 19, 18); if code = 0 then return; end; call parse_error (PRINT_TOKEN, "mask must be 6 octal digits"); /* version */ label (9): if token_len <= 4 then do; b.version = token; return; end; call parse_error (PRINT_TOKEN, "Invalid version number"); /* meter */ label (10): if token = "yes" | token = "no" then do; b.metering_enabled = (token = "yes"); return; end; call parse_error (PRINT_TOKEN, "yes or no expected"); /* module */ label (11): call set_module; /* store values from previous module */ if token_len <= length (module_name) then do; module_name = token; return; end; call parse_error (PRINT_TOKEN, "module name too long"); /* type */ label (12): if module_name ^= "" then do; if module_type = 0 then do; do i = 1 to 3 ; if token = type_keyword (i) then do; module_type = i; if b.module (module_type).name = "" then return; module_type = 0; call parse_error (PRINT_TOKEN, "type already specified"); end; end; call parse_error (PRINT_TOKEN, "illegal type specified"); end; call parse_error (^PRINT_TOKEN, "type already specified"); end; call parse_error (^PRINT_TOKEN, "module statement must precede type"); /* size */ label (13): if module_name ^= "" then do; if module_size = -1 then do; module_size = cv_dec_check_ (token, code); if code = 0 & module_size >= 0 then return; call parse_error (PRINT_TOKEN, "illegal value for size"); end; else call parse_error (PRINT_TOKEN, "size statement already specified"); end; else call parse_error (^PRINT_TOKEN, "module statement must precede size"); return; end parse_statement; set_module: proc; if module_name ^= "" then do; if module_type > 0 then do; b.module (module_type).name = module_name; if module_size = -1 then do; module_size = default_size (module_type); call print ("Using default size for " || module_name); end; b.module (module_type).size = module_size; end; else do; module_type = 0; module_size = -1; call print ("Type statement missing for "|| module_name); fatal_error = "1"b; end; end; module_type = 0; module_size = -1; return; end set_module; /* * This procedure finds the next token and break character. * * FOUND ACTION * * token + break return "1"b * end of file return "0"b * break + token error message non-local goto continue_parse * token + token error message non-local goto continue_parse */ get_token: proc () returns (bit (1) unal); call parse_file_$parse_file_ptr (b_ptr, b_len, break, eof); if eof ^= 0 then return ("0"b); token_ptr = b_ptr; token_len = b_len; if break = 0 then do; call parse_file_$parse_file_ptr (b_ptr, b_len, break, eof); if eof ^= 0 then return ("0"b); break_ptr = b_ptr; break_len = b_len; if break ^= 0 then return ("1"b); else call parse_error (PRINT_TOKEN, "break character is missing"); end; call parse_error (PRINT_TOKEN, "extra break character"); end get_token; /* This procedure prints error messages from parsing the bindfile. It skips to the end of the statement so there is only one error message per statement. It also sets fatal_error so binding will be terminated after all bindfile parsing is completed. */ parse_error: proc (print_token, message); dcl print_token bit (1) unal; /* ON if token should be printed */ dcl message char (*); /* error message */ dcl temp char (150); /* error message + line number */ dcl temp_len fixed bin; /* length of reformatted message */ /* print error message */ if print_token then call ioa_$rsnnl ("^a ""^a"" in line # ^d", temp, temp_len, message, token, parse_file_$parse_file_line_no ()); else call ioa_$rsnnl ("^a in line # ^d", temp, temp_len, message, parse_file_$parse_file_line_no ()); call print (substr (temp, 1, temp_len)); /* skip to end of statement */ fatal_error = "1"b; do while (break_char ^= ";"& eof = 0); call parse_file_$parse_file_ptr (break_ptr, break_len, break, eof); end; goto continue_parse; end parse_error; end parse_bindfile; end bind_fnp;  bind_fnp_load_.pl1 11/15/82 1821.5rew 11/15/82 1449.8 326052 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,^ifthendo */ bind_fnp_load_: proc (bind_fnp_ptr, fatal_error); /* Written by S. E. Barr 5/76. Modified 1/9/78 by J. Stern to produce symbol cross reference. Modified 3/15/78 by J. Stern to process trace macros identified by secondary defs. Modified 1979 May 27 by Art Beattie to add support for DN6670 paging mechanism and separate trace buffer from module chain. Modified 1981 Jan 22 by Robert Coren to process metering macros identified by secondary defs. Modified 1982 April 21 by Robert Coren to set up buffer page table entry pointer and to eliminate all references to 355 simulator. Modified 1982 July 29 by Robert Coren to check size of core image against maximum loadable. */ /* parameter */ dcl bind_fnp_ptr ptr; /* ptr to binder information */ dcl fatal_error bit (1) unal; /* ON if binding unsuccessful */ /* automatic */ dcl address fixed bin (17); /* core_image offset */ dcl card_id bit (12); dcl card_len fixed bin; dcl card_ptr ptr; /* ptr to card image from GCOS read */ dcl chain_links fixed bin; /* number of links in the module chain for a single segment */ dcl code fixed bin (35); dcl core_len fixed bin; /* index of last word loaded in core image */ dcl def_used bit (hbound (b.def, 1)) unal; /* one flag for each SYMDEF. ON if def was referenced */ dcl entry_offset fixed bin; /* offset of entry at which to begin execution */ dcl eof bit (1); /* ON if end of segment was reached */ dcl extra_len fixed bin; /* length of unused table space */ dcl input_attached bit (1) unal; /* ON is segment is attached for GCOS read */ dcl iseg fixed bin; /* index of segment being loaded */ dcl last_chain fixed bin; /* module name chain offset */ dcl load_offset fixed bin; /* offset in core image to segment being loaded */ dcl message char (300); /* error message printed by print */ dcl message_len fixed bin; /* error message length */ dcl module_nums_used (18) fixed bin; /* holds indices into b.segs, relates module numbers to segments */ dcl num_defs fixed bin; /* number of defs */ dcl num_refs fixed bin; /* number of refs for current segment */ dcl num_trace_defs fixed bin; /* number of secondary defs identifying trace macros */ dcl num_meter_defs fixed bin; /* number of secondary defs identifying metering macros */ dcl obj_date char (32); /* date core image segment was created */ dcl print_count fixed bin; /* number of items that have been printed */ dcl sym_field_len fixed bin; /* number of bits used for symbol reference field */ dcl text_size fixed bin; /* number of 18 bit words in segment to be loaded */ dcl reflist char (130) varying; dcl word fixed bin (35); dcl (i, j, k, cnt) fixed bin; dcl cleanup condition; dcl (addr, bit, divide, fixed, hbound, length, mod, rel, substr, unspec, bin) builtin; /* based */ dcl 1 b based (bind_fnp_ptr) aligned like bind_fnp_info; dcl 1 core aligned based (b.obj_ptr), 2 count fixed bin (35), 2 loc (0:32765) bit (18) unal; dcl 1 core_image unal based (b.obj_ptr), 2 count fixed bin (35), /* number of 36 bit words in rest of segment */ 2 header unal, 3 not_set (0:415) bit (18) unal, 3 date_time_loaded fixed bin (71), /* date of loading */ 3 date_time_boot bit (72) unal, /* not set */ 3 buffer bit (18) unal, /* not set */ 3 last_loc_memory fixed bin (17) unal, /* offset of last location in core image */ 3 num_buffers bit (18) unal, 3 iom_table fixed bin (17) unal, /* offset of iom table */ 3 num_hsla fixed bin (17) unal, /* number of hsla's configured */ 3 num_lsla fixed bin (17) unal, /* number of lsla's configured */ 3 console_enable bit (18) unal, /* console enabled flag */ 3 module_chain fixed bin (17) unal, /* starting address of module chain */ 3 next_buffer bit (18) unal, 3 trace_mask bit (18) unal, /* trace entry enable mask */ 3 trace_table fixed bin (17) unal, /* base address of trace table */ 3 next_trace fixed bin (17) unal, /* next avialable location in trace table */ 3 fault_data fixed bin (17) unal, /* pointer to fault data storage */ 3 tib_table_base fixed bin (17) unal, /* base of tib table */ 3 tib_table_end fixed bin (17) unal, /* end of tib table */ 3 first_delay_table bit (18) unal, /* not set */ 3 version char (4) unal, /* version number */ 3 breakpoint_addr bit (18) unal, /* not set */ 3 trace_sw bit (18) unal, /* not set */ 3 next_smal_space bit (18) unal, /* not set */ 3 num_small_buffers bit (18) unal, /* not set */ 3 cct_desc bit (18) unal, /* address of first cct descriptor */ 3 sked_data_blk bit (18) unal, /* address of scheduler data block */ 3 echo_tables fixed bin (17) unal, /* address of list of echo-negotiation bit tables */ 3 cpu_page_table fixed bin (17) unal, /* address of cpu page table */ 3 cpu_page_table_entry fixed bin (17) unal, /* address of variable cpu page table entry */ 3 trace_size fixed bin (17) unal, /* size of trace buffer */ 3 meter_flag fixed bin (17) unal, /* nonzero if metering enabled */ 3 tandd_tib_addr bit (18) unal, /* not set */ 3 buffer_time_meter_addr bit (18) unal, /* not set */ 3 next_high_memory_buffer bit (18) unal, /* not set */ 3 buffer_page_table_entry fixed bin (17) unal, /* address of page table entry for buffer addresses */ 3 pad (39) bit (18) unal, 3 copyright_notice char (28) unal, /* image copyright notice */ 3 crash_loc fixed bin (17) unal, /* offset used for unresolved REF's */ 3 crash_op bit (18) unal, /* crash instruction */ 3 hsla_com bit (512 * 18 * b.num_hsla) unal, 3 page_table bit (128 * 18 * fixed ((b.memory >= 64), 17)) unal, /* must start on mod 128 boundary */ 3 iom_channel (0:15) unal, 4 multiple_channel bit (1) unal, /* ON if multiple channel device */ 4 pad bit (2) unal, 4 device_number bit (3) unal, /* device number (for multiple channel devices) */ 4 pad_2 bit (3) unal, 4 device_type fixed bin (4) unal, /* code for type of device */ 4 device_speed bit (4) unal, 4 offset fixed bin (17) unal, /* offset ofchannel table */ 3 hsla_table bit (32 * 36 * b.num_hsla), 3 lsla_table bit (54 * 36 * b.num_lsla), 3 start_load fixed bin; dcl 1 core_fragment aligned based (b.obj_ptr), 2 count fixed bin (35), 2 loaded (0:load_offset) bit (18) unal, 2 extra (extra_len) bit (18) unal; /* external */ dcl clock_ entry () returns (fixed bin (71)); dcl date_time_ entry (fixed bin (71), char (*)); dcl error_table_$noentry fixed bin (35) ext; dcl ioa_$ioa_switch entry options (variable); dcl ioa_$ioa_switch_nnl entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl ios_$attach entry (char (*), char (*), char (*), char (*), bit (72)); dcl ios_$detach entry (char (*), char (*), char (*), bit (72)); dcl ios_$setsize entry (char (*), fixed bin, bit (72)); dcl iox_$error_output ptr ext; dcl com_err_ entry options (variable); dcl gcos_cv_gebcd_ascii_ entry (ptr, fixed bin, ptr); dcl gcos_gsr_read_$gsr_read_init entry (char (*), fixed bin (35)); dcl gcos_gsr_read_ entry (char (*), ptr, fixed bin, bit (12), bit (1), fixed bin (35)); dcl gcos_gsr_read_$gsr_read_close entry (char (*), fixed bin (35)); dcl get_group_id_ entry () returns (char (32)); dcl get_wdir_ entry () returns (char (168)); /* constants */ dcl INPUT char (8) int static options (constant) init ("bind_fnp"); dcl TRACE fixed bin int static options (constant) init (3);/* b.module (3) = trace type */ dcl LOAD_BASE fixed bin int static options (constant) init (512); dcl LOW_CORE_SIZE fixed bin int static options (constant) init (32768); %include bind_fnp_info; core_len = core_offset (addr (core_image.start_load)) - 1; last_chain = core_offset (addr (core_image.module_chain)); def_used, input_attached = "0"b; num_defs, num_unresolved = 0; module_nums_used (*) = 0; on cleanup call detach_segment; do iseg = 1 to b.num_segs; call get_segment (b.segs (iseg).seg_name); call preface_cards; call relocate_text; call detach_segment; end; core.loc (last_chain) = ""b; /* zero forward ptr in last link of module chain */ call set_load_info; /* Print warning messages for SYMDEF's that were not referenced. */ if b.list & substr (^def_used, 1, num_defs) then do; call ioa_$ioa_switch (b.list_ptr, "^/^/The following symbols were defined, but were not referenced:^/^/^1x^4(Symbol Module^19x^)"); j = 0; do i = 1 to num_defs; if ^substr (def_used, i, 1) & b.def (i).offset ^= 0 then call print_symbol (j, b.def (i).offset, b.def (i).name); end; end; /* Fill in unresolved references from table. There is only one error message for each symbol. After the error message has been printed, the offset in def is set to -1, so future references will not cause a message. */ cnt = 0; do i = 1 to num_unresolved; j = b.unresolved (i).core_loc; k = b.unresolved (i).index_def; address = b.def (k).offset; if address <= 0 then do; if b.list & address = 0 then do; if cnt = 0 then call ioa_$ioa_switch (b.list_ptr, "^/^/The following symbols were referenced, but were not defined:^/^/^1x^4(Symbol Module^19x^)" ); call print_symbol (cnt, j, b.def (k).name); b.def (k).offset = -1; end; address = core_offset (addr (core_image.crash_loc)); end; word = fixed (core.loc (j), 35) + address; core.loc (j) = substr (unspec (word), 19, 18); end; /* Print symbol table */ if b.list then do; call shell_sort (b.def, num_defs); call ioa_$ioa_switch (b.list_ptr, "^/^/^/^/The following symbols were defined:^/^/^6(Symbol Offset^3x^)"); print_count = 0; do i = 1 to num_defs; if b.def (i).offset > 0 then do; if mod (print_count, 6) = 0 then call ioa_$ioa_switch (b.list_ptr, ""); print_count = print_count + 1; call ioa_$ioa_switch_nnl (b.list_ptr, "^6a^8o^3x", ascii (b.def (i).name), b.def (i).offset); end; end; end; if b.list then do; call date_time_ ((core_image.date_time_loaded), obj_date); call ioa_$ioa_switch (b.list_ptr, "^|Bindmap for ^a>^a, Version ^a^/Created on ^a, by ^a", get_wdir_ (), b.obj_name, b.version, obj_date, get_group_id_ ()); call ioa_$ioa_switch (b.list_ptr, "^/Component^16x^[^6x^;Modnum^] Start Length Date Compiled Directory^/", unspec (module_nums_used) = ""b); do i = 1 to b.num_segs; call ioa_$ioa_switch (b.list_ptr, "^25a^[^s^6x^;^6d^]^7o^8o ^a ^a", b.segs (i).seg_name, b.segs (i).modnum = 0, b.segs (i).modnum, b.segs (i).offset, b.segs (i).length, b.segs (i).date, b.segs (i).dir_found); end; end; /* print symbol cross reference */ if b.cross_ref then do; call ioa_$ioa_switch (b.list_ptr, "^|Symbol cross reference by module:^/"); do i = 1 to num_defs; if b.def (i).offset > 0 then do; k = b.def (i).def_module; call ioa_$ioa_switch (b.list_ptr, "^/^6a^8o (^a|^o)", ascii (b.def (i).name), b.def (i).offset, b.segs (k).seg_name, b.def (i).offset - b.segs (k).offset); reflist = ""; do j = 1 to b.num_segs; if substr (b.def (i).ref_modules, j, 1) then do; if length (reflist) + length (b.segs (j).seg_name) + 2 > 130 then do; call ioa_$ioa_switch (b.list_ptr, "^a", reflist); reflist = ""; end; reflist = reflist || " " || b.segs (j).seg_name; end; end; if reflist ^= "" then call ioa_$ioa_switch (b.list_ptr, "^a", reflist); end; end; end; RETURN: return; /* This procedure converts a BCD bit string into an ASCII character string */ ascii: proc (bit_string) returns (char (80) var); dcl bit_string bit (*); dcl char_string char (80); dcl num_chars fixed bin; num_chars = divide (length (bit_string), 6, 17); call gcos_cv_gebcd_ascii_ (addr (bit_string), num_chars, addr (char_string)); return (substr (char_string, 1, num_chars)); end ascii; /* * This procedure sets up the next segment to be loaded. * 1. It locates the segment using the specified search rules. (the suffix .objdk is assumed) * 2. It makes the io attachment of the input stream to the segment and sets input_attached. * 3. It makes the initializing call to the GCOS read procedure. */ get_segment: proc (name); dcl name char (*) var; /* The segment name without .objdk */ /* automatic */ dcl i fixed bin; dcl status bit (72); dcl code fixed bin (35) based (addr (status)); do i = 1 to b.num_directories; call ios_$attach (INPUT, "file_", b.directory (i) || ">" || name || ".objdk", "r", status); if code = 0 then do; b.segs (iseg).dir_found = b.directory (i); input_attached = "1"b; call ios_$setsize (INPUT, 36, status); if code = 0 then do; call gcos_gsr_read_$gsr_read_init (INPUT, code); if code = 0 then return; end; end; else if code ^= error_table_$noentry then call abort (code, b.directory (i) || ">" || name || ".objdk"); end; call abort (error_table_$noentry, name || ".objdk"); end get_segment; /* * This procedure reads the preface cards for the object segment and fills in the ref table and def table * It sets: * load_offset Location to begin loading text. * text_size The length of the text. (It may be longer than the number of words to be loaded * if table space was reserved at the end of the text) * sym_field_len Number of bits in the symbol reference field */ preface_cards: proc; /* automatic */ dcl (i, j) fixed bin; dcl cnt fixed bin; dcl time fixed bin; dcl num_symbols fixed bin; /* based */ dcl 1 binary aligned based (card_ptr), 2 word_1 aligned, 3 id_1 bit (3) unal, /* must be '4' */ 3 sym_ref_field bit (6) unal, /* number of bits for symbol reference */ 3 id_2 bit (3) unal, /* must be '5' */ 3 preface_len bit (6) unal, /* number 18 bit words from word 3 */ 3 text_len bit (18) unal, /* number of words in text */ 2 checksum bit (36) aligned, 2 word_3 aligned, 3 blank_common_len bit (18) unal, /* not used */ 3 load_mod_code bit (3) unal, /* 0,1,2,3, = mod 2, 8, 16, 64 */ 3 num_symbols_2 bit (15) unal, /* 2 * number of SYMDEF's, SYMREF's and common */ 2 symbol (num_symbols) aligned, 3 name bit (36), 3 offset fixed bin (17) unal, 3 pad bit (15) unal, 3 symbol_code bit (3) unal; dcl 1 h aligned based (card_ptr), /* header card */ 2 pad (10) bit (36), 2 ten_hr fixed bin (5) unal, 2 one_hr fixed bin (5) unal, 2 decimal_pt bit (6) unal, 2 ten_min fixed bin (5) unal, 2 one_min fixed bin (5) unal, 2 pad_2 bit (6) unal, /* ignore last digit of time */ 2 month bit (12) unal, 2 day bit (12) unal, 2 year bit (12) unal; /* constant */ dcl BIN_CARD bit (3) int static options (constant) init ("100"b); dcl CHAIN_ID bit (12) int static options (constant) init ("3323"b3); /* BCD for .c */ dcl TRACE_ID bit (6) int static options (constant) init ("67"b3); /* BCD for x */ dcl METER_ID bit (6) int static options (constant) init ("44"b3); /* BCD for m */ dcl LOAD_MOD (0:4) fixed bin int static options (constant) init (2, 8, 16, 32, 64); call gcos_gsr_read_ (INPUT, card_ptr, card_len, card_id, eof, code); if b.list then do; time = ten_hr * 1000 + one_hr * 100 + divide (60 * (ten_min * 10 + one_min), 100, 17, 0); call ioa_$rsnnl ("^a/^a/^a ^4d", b.segs (iseg).date, i, ascii (h.month), ascii (h.day), ascii (h.year), time); end; load_offset, num_refs, cnt, chain_links, num_trace_defs, num_meter_defs = 0; do while ("1"b); call gcos_gsr_read_ (INPUT, card_ptr, card_len, card_id, eof, code); if code ^= 0 then do; call ioa_$rsnnl ("Attempting to read ^a>^a.objdk", message, message_len, b.segs (iseg).dir_found, b.segs (iseg).seg_name); call abort (code, message); end; if load_offset = 0 then do; i = fixed (binary.load_mod_code, 17); load_offset = core_len + LOAD_MOD (i) - mod (core_len, LOAD_MOD (i)); text_size = fixed (binary.text_len, 17); sym_field_len = fixed (binary.sym_ref_field, 17) + 1; call special_module (text_size); if b.list then do; b.segs (iseg).offset = load_offset; b.segs (iseg).length = text_size; end; end; if binary.id_1 = BIN_CARD then do; num_symbols = divide (fixed (binary.preface_len, 35) - 2, 4, 35); do i = 1 to num_symbols; /* The chain is specified by a secondary DEF for a symbol with a name that begins with ".c" */ if symbol (i).symbol_code = "001"b then do; if substr (symbol (i).name, 1, length (CHAIN_ID)) = CHAIN_ID then do; chain_links = chain_links + 1; if chain_links > 1 then do; call ioa_$rsnnl ("^d secondary DEFS found for module chain in ^a.objdk", message, message_len, chain_links, b.segs (iseg).seg_name); call print (); end; core.loc (last_chain) = bit (load_offset + symbol (i).offset, 18); last_chain = load_offset + symbol (i).offset; end; /* A trace macro is identified by a secondary DEF for a symbol with a name that begins with "x" */ else if substr (symbol (i).name, 1, length (TRACE_ID)) = TRACE_ID then do; num_trace_defs = num_trace_defs + 1; b.trace_offset (num_trace_defs) = load_offset + symbol (i).offset; end; /* A metering macro is identified by a secondary DEF for a symbol with a name that begins with "m" */ else if substr (symbol (i).name, 1, length (METER_ID)) = METER_ID then do; num_meter_defs = num_meter_defs + 1; b.meter_offset (num_meter_defs) = load_offset + symbol (i).offset; end; else do; call ioa_$rsnnl ("Unexpected secondary DEF ^a in ^a.objdk", message, message_len, ascii ((symbol (i).name)), b.segs (iseg).seg_name); call print (); end; end; else do; do j = 1 to num_defs while (symbol (i).name ^= b.def (j).name); end; if j > num_defs then do; num_defs = num_defs + 1; b.def (j).name = symbol (i).name; end; /* SYMREF: put index of symbol in DEF table into REF table */ if symbol (i).symbol_code = "101"b then do; num_refs = num_refs + 1; b.ref (num_refs) = j; end; /* Primary DEF: put actual offset into DEF table */ else if symbol (i).symbol_code = "000"b then do; if b.def (j).offset ^= 0 then do; /* already have a DEF with same name */ call ioa_$rsnnl ("DEF ^a in ^a.objdk previously defined in ^a.objdk", message, message_len, ascii (b.def (j).name), b.segs (iseg).seg_name, b.segs (b.def (j).def_module).seg_name); call print (); end; b.def (j).offset = load_offset + symbol (i).offset; b.def (j).def_module = iseg; if b.entry = ascii ((symbol (i).name)) then do; entry_offset = b.def (j).offset; substr (def_used, j, 1) = "1"b; end; end; else do; call ioa_$rsnnl ("Illegal symbol code while processing ^a>^a.objdk", message, message_len, b.segs (iseg).dir_found, b.segs (iseg).seg_name); call abort (0, message); end; end; end; cnt = cnt + num_symbols; if 2 * cnt = fixed (binary.num_symbols_2) then do; if chain_links = 0 then do; call ioa_$rsnnl ("Module chain link missing for ^a.objdk", message, message_len, b.segs (iseg).seg_name); call print (); end; return; end; end; else do; call ioa_$rsnnl ("Binary card expected while processing ^a>^a.objdk", message, message_len, b.segs (iseg).dir_found, b.segs (iseg).seg_name); call abort (0, message); end; end; end preface_cards; /* * This procedure special cases the lsla, hsla and trace type modules. * * lsla, hsla the length of the text is reduced by the amount of unused table space. * (size * number of LSLA's not used) */ special_module: proc (text_len); dcl text_len fixed bin; /* number of words of text to load */ dcl i fixed bin; /* constants */ dcl MAX_LSLA fixed bin int static options (constant) init (6); dcl MAX_HSLA fixed bin int static options (constant) init (3); do i = 1 to 3 while (b.module (i).name ^= b.segs (iseg).seg_name); end; if i = 1 then text_len = text_len - (MAX_LSLA - b.num_lsla) * b.module (1).size; else if i = 2 then text_len = text_len - (MAX_HSLA - b.num_hsla) * b.module (2).size; return; end special_module; /* * This procedure loads and modifies text using the relocation bits specified on the text cards. * Text cards may contain one or more blocks of 18 bit words to be loaded. If the word following a block that * has just been loaded contains a relocation id, then another block follows. The format of the first block * on the card is described by 'text'. The format of successive blocks is described by 'extra'. There are * a maximum of 39 words per card. */ relocate_text: proc; dcl i fixed bin; dcl num_instr fixed bin; /* number of instructions to load */ dcl p ptr; /* constant */ dcl REL_CARD bit (12) int static options (constant) init ("010000000101"b); /* '2005' */ /* based */ dcl 1 text unal based (card_ptr), 2 id bit (12) unal, /* must be '2005' */ 2 num bit (6) unal, /* number 18 bit words in this block to load */ 2 base_rel_offset fixed bin (17) unal, /* load offset */ 2 check_sum bit (36) unal, 2 reloc (39) bit (2) unal, 2 pad bit (12) unal, 2 instr (num_instr) bit (18) unal, /* words to be loaded */ 2 next_block bit (18) unal; dcl 1 extra unal based (p), 2 id bit (12) unal, 2 num bit (6) unal, 2 base_rel_offset fixed bin (17) unal, 2 instr (num_instr) bit (18) unal, 2 next_block bit (18) unal; do while (^eof); call gcos_gsr_read_ (INPUT, card_ptr, card_len, card_id, eof, code); if ^eof then do; if setup_block (0, card_ptr) then do; call load (0, addr (text.instr (1))); p = addr (text.next_block); i = num_instr; do while (setup_block (i, p)); call load (i, addr (extra.instr (1))); p = addr (extra.next_block); i = i + num_instr; end; end; end; end; call process_trace_defs (); call process_meter_defs (); load_offset = load_offset + text_size - 1; extra_len = core_len - load_offset; /* get length of unused table space */ if extra_len > 0 then unspec (core_fragment.extra) = ""b; core_len = load_offset; return; /* This procedure checks the next word on a text card. It it has a relocation id, it computes the new load offset and the number of words to be loaded. */ setup_block: proc (num_instr_loaded, p) returns (bit (1) unal); dcl num_instr_loaded fixed bin; /* number of instructions already loaded from this card */ dcl p ptr; dcl 1 extra unal based (p), 2 id bit (12) unal, 2 num bit (6) unal, 2 base_rel_offset fixed bin (17) unal, 2 instr (num_instr) bit (18) unal, 2 next_block bit (18) unal; if num_instr_loaded < 39 then if extra.id = REL_CARD then do; num_instr = fixed (extra.num, 17); core_len = load_offset + extra.base_rel_offset; return ("1"b); end; return ("0"b); end setup_block; /* * This procedure loads the words using the relocation code specified by text.reloc in the first block of the * text card. * * "00"b no relocation * "01"b address is relative to the load address of the module * "11"b symbol reference */ load: proc (index_rel, p); dcl index_rel fixed bin; /* index of last relocation bits */ dcl p ptr; /* ptr to instructions to be loaded */ dcl (i, j) fixed bin; dcl word fixed bin (35); /* based */ dcl instr (num_instr) bit (18) unal based (p); /* words to be loaded */ dcl 1 sym_ref based (addr (word)), /* word that contains a symbol reference */ 2 pad bit (18) unal, 2 tag bit (3) unal, 2 id bit (sym_field_len) unal, /* symbol reference number */ 2 address bit (18 - sym_field_len) unal; do i = 1 to num_instr; if text.reloc (index_rel + i) = "00"b then core.loc (core_len) = instr (i); else do; word = fixed (instr (i), 35); if text.reloc (index_rel + i) = "01"b then word = word + load_offset; /* SYMREF load relative to symbol reference and set flag to indicate SYMDEF was used. Check for overflow of the address field (all 1's) */ else if text.reloc (index_rel + i) = "11"b then do; j = fixed (sym_ref.id, 17, 0); sym_ref.id = "0"b; if j <= num_refs & j > 0 then do; if ^sym_ref.address = "0"b then do; call ioa_$rsnnl ("Indirection through external symbol is not supported in ^a.objdk", message, message_len, b.segs (iseg).seg_name); call print (); end; j = b.ref (j); /* get def index for reference */ /* add location to unresolved table if offset is zero */ if b.def (j).offset = 0 then do; num_unresolved = num_unresolved + 1; b.unresolved (num_unresolved).core_loc = core_len; b.unresolved (num_unresolved).index_def = j; end; else word = word + b.def (j).offset; substr (def_used, j, 1) = "1"b; substr (b.def (j).ref_modules, iseg, 1) = "1"b; end; else do; call ioa_$rsnnl ("Invalid reference to #^d in ^a.objdk", message, message_len, j, b.segs (iseg).seg_name); call print (); end; end; else do; call ioa_$rsnnl ("Invalid relocation code ^b in ^a.objdk", message, message_len, text.reloc (index_rel + i), b.segs (iseg).seg_name); call print (); end; core.loc (core_len) = substr (unspec (word), 19, 18); ; end; core_len = core_len + 1; end; return; end load; /* This procedure enables trace macros for a module if the trace mask indicates that they should be enabled. Otherwise, no action is taken which leaves the trace macros in their disabled state. */ process_trace_defs: proc; dcl i fixed bin; dcl module_num fixed bin; if chain_links ^= 1 /* module chain messed up for this module */ then return; module_num = bin (core.loc (last_chain), 18); if module_num < 0 | module_num > 18 then do; call ioa_$rsnnl ("Invalid module number ^d found for ^a.objdk", message, message_len, module_num, b.segs (iseg).seg_name); call print (); return; end; if module_num ^= 0 then do; if module_nums_used (module_num) ^= 0 then do; call ioa_$rsnnl ("Module number ^d in ^a.objdk previously used for ^a.objdk", message, message_len, module_num, b.segs (iseg).seg_name, b.segs (module_nums_used (module_num)).seg_name); call print (); return; end; b.segs (iseg).modnum = module_num; module_nums_used (module_num) = iseg; end; if num_trace_defs = 0 then return; if module_num = 0 then do; call ioa_$rsnnl ("Zero module number found for ^a.objdk which contains trace DEFs", message, message_len, b.segs (iseg).seg_name); call print (); end; if ^substr (b.mask, module_num, 1) /* want trace macros disabled */ then return; /* so leave them alone */ call patch_defs (num_trace_defs, b.trace_offset, "Trace"); end process_trace_defs; process_meter_defs: proc; /* This procedure enables metering macros for a module if the bindfile indicates that metering is to be enabled. Otherwise, they are left disabled. */ if num_meter_defs > 0 then if b.flags.metering_enabled then call patch_defs (num_meter_defs, b.meter_offset, "Metering"); return; end process_meter_defs; patch_defs: proc (p_num_defs, offset_array, type_name); /* Procedure used by process_meter_defs and process_trace_defs to patch TRAs marked by secondary symdefs to NOPs */ dcl p_num_defs fixed bin; dcl offset_array (*) fixed bin; dcl type_name char (*); dcl TRA_OPCODE bit (6) int static options (constant) init ("71"b3); dcl NOP bit (18) int static options (constant) init ("233100"b3); do i = 1 to p_num_defs; /* enable all the specified macros */ if substr (core.loc (offset_array (i)), 4, 6) ^= TRA_OPCODE then do; call ioa_$rsnnl ("^a macro at ^a.objdk|^o does not begin with TRA instruction", message, message_len, type_name, b.segs (iseg).seg_name, offset_array (i) - load_offset); call print (); end; else core.loc (offset_array (i)) = NOP; end; return; end patch_defs; end relocate_text; /* This procedure fills in the header and trailer for the core image */ set_load_info: proc; dcl i fixed bin (35); dcl 1 trailer unal based (addr (core.loc (core_len))), 2 start fixed bin (17) unal, /* start of core image */ 2 end fixed bin (17) unal, /* offset of end of core image */ 2 length fixed bin (17) unal, /* number of 18 bit words in core image */ 2 start_entry fixed bin (17) unal; /* offset to begin execution */ dcl MCS_BCD bit (36) int static init ("011011100100010011110010011011010000"b); /* BCD .mcs. octal 334423623320 */ dcl ( FIRST_HSLA_CH init (6), FIRST_LSLA_CH init (9) ) fixed bin int static options (constant); core_image.date_time_loaded = clock_ (); core_image.last_loc_memory = b.memory * 1024 - 1; /* memory starts at 0 */ if b.memory >= 64 then do; core_image.cpu_page_table = core_offset (addr (substr (core_image.page_table, 1))); core_image.cpu_page_table_entry = core_image.cpu_page_table + 127; core_image.buffer_page_table_entry = core_image.cpu_page_table + 126; end; core_image.iom_table = core_offset (addr (core_image.iom_channel (0))); core_image.num_hsla = b.num_hsla; core_image.num_lsla = b.num_lsla; core_image.trace_mask = b.mask; core_image.version = b.version; core_image.crash_loc = 0; core_image.crash_op = "000101001000000010"b; /* octal 051002 */ core_image.trace_size = b.module (TRACE).size; if b.flags.metering_enabled then core_image.meter_flag = 1; else core_image.meter_flag = 0; core_image.copyright_notice = "COPR. (C) H.I.S. INC. 1981"; /* Fill in iom channel table. Device type codes: * 0 not implemented 4 lsla * 1 clock 5 console * 2 dia 6 printer * 3 hsla */ if b.console then core_image.iom_channel (0).device_type = 5; /* console */ if b.printer then core_image.iom_channel (2).device_type = 6; /* printer */ core_image.iom_channel (4).device_type = 2; /* dia */ if b.memory >= 64 /* if modern core image */ then do; core_image.iom_channel (3).device_type, /* dia may be on any of 3, 4, 5, or 12 */ core_image.iom_channel (5).device_type, core_image.iom_channel (12).device_type = 2; end; core_image.iom_channel (15).device_type = 1; /* clock */ do i = 1 to b.num_hsla; core_image.iom_channel (FIRST_HSLA_CH + i - 1).multiple_channel = "1"b; core_image.iom_channel (FIRST_HSLA_CH + i - 1).device_type = 3; core_image.iom_channel (FIRST_HSLA_CH + i - 1).device_number = substr (unspec (i), 34, 3); core_image.iom_channel (FIRST_HSLA_CH + i - 1).offset = core_offset (addr (substr (core_image.hsla_table, 32 * 36 * (i - 1) + 1))); end; do i = 1 to b.num_lsla; core_image.iom_channel (FIRST_LSLA_CH + i - 1).multiple_channel = "1"b; core_image.iom_channel (FIRST_LSLA_CH + i - 1).device_type = 4; core_image.iom_channel (FIRST_LSLA_CH + i - 1).device_number = substr (unspec (i), 34, 3); core_image.iom_channel (FIRST_LSLA_CH + i - 1).device_speed = "0100"b; core_image.iom_channel (FIRST_LSLA_CH + i - 1).offset = core_offset (addr (substr (core_image.lsla_table, 54 * 36 * (i - 1) + 1))); end; /* Add 4 word block at end of core image for FNP loader */ core_len = core_len + 4 - mod (core_len, 4); trailer.start = 0; trailer.end, trailer.length = core_len + 4; trailer.start_entry = entry_offset; core_len = core_len + 4; /* Make sure core image will fit in 32K with gicb */ if core_len + LOAD_BASE > LOW_CORE_SIZE /* it won't */ then call abort (0, "Core image is too large to load in 32K."); b.obj_len = divide (core_len, 2, 17, 0) + 1; core_image.count = b.obj_len - 1; end set_load_info; /* The procedure is given an address within the core_image and it returns the index in loc that corresponds to that address. */ core_offset: proc (item_ptr) returns (fixed bin (17)); dcl item_ptr ptr; dcl offset fixed bin (17) unal; %include its; offset = fixed (rel (item_ptr), 18) - 1; offset = offset * 2; if addr (item_ptr) -> its.bit_offset then offset = offset + 1; return (offset); end core_offset; detach_segment: proc; dcl status bit (72); call gcos_gsr_read_$gsr_read_close (INPUT, code); call ios_$detach (INPUT, "", "", status); end detach_segment; print_symbol: proc (print_count, offset, name); dcl print_count fixed bin; dcl offset fixed bin; dcl name bit (36); dcl i fixed bin; do i = 1 to b.num_segs while (offset >= b.segs (i).offset); end; i = i - 1; if mod (print_count, 4) = 0 then call ioa_$ioa_switch_nnl (b.list_ptr, "^/ "); call ioa_$ioa_switch_nnl (b.list_ptr, "^6a ^25a", ascii (name), b.segs (i).seg_name); print_count = print_count + 1; end print_symbol; abort: proc (code, message); dcl code fixed bin (35); dcl message char (*); fatal_error = "1"b; call com_err_ (code, "bind_fnp", message); call detach_segment; goto RETURN; end abort; print: proc (); fatal_error = "1"b; if b.list then do; if ^b.error_header then do; b.error_header = "1"b; call ioa_$ioa_switch (b.list_ptr, "ERROR MESSAGES^/"); end; call ioa_$ioa_switch (b.list_ptr, substr (message, 1, message_len)); end; call ioa_$ioa_switch (iox_$error_output, "bind_fnp: ^a", substr (message, 1, message_len)); end print; /* This shell sort is taken from Knuth, The Art of Computer Probramming, Volume 3, "Sorting and Searching", via Tom Casey */ shell_sort: proc (array, len); dcl 1 array (*) aligned like bind_fnp_info.def; dcl len fixed bin; /* number of defs */ dcl (incr, next_incr) fixed bin; incr = 4; next_incr = 13; do while (next_incr < len); incr = next_incr; next_incr = 3 * next_incr + 1; end; do while (incr > 1); incr = divide (incr - 1, 3, 17, 0); call insertion_sort (array, len, incr); end; return; insertion_sort: proc (array, len, h); dcl 1 array (*) aligned like bind_fnp_info.def; dcl (len, h, i, j) fixed bin; dcl 1 temp aligned like bind_fnp_info.def; do j = h + 1 to len; temp = array (j); if fixed (temp.name, 36, 0) < fixed (array (j - h).name, 36, 0) then do; do i = j - h repeat i - h while (i > 0 & fixed (temp.name, 36, 0) < fixed (array (i).name, 36, 0)); array (i + h) = array (i); end; array (i + h) = temp; end; end; end insertion_sort; end shell_sort; end bind_fnp_load_;  coreload.pl1 11/15/82 1821.5rew 11/15/82 1504.3 50715 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ coreload: proc; /* coreload is a program to make an absolute object deck produced by map355 into a coreimage file. Coded by R.B.Snyder many moons ago. Re-written by Mike Grady 5/21/76 to make better. */ /* Automatic storage */ dcl (i, argl, code, reclen, loc, full_count) fixed bin; dcl (argp, hdrp, wdp, segp, bufp) pointer; dcl dir char (168); dcl ename char (32); dcl ascii_card char (80); dcl (in_name, out_name) char (32); dcl fname char (168); dcl eofsw bit (1); dcl rcrdhdr bit (12); dcl st bit (72); /* Based storage */ dcl err fixed bin based (addr (st)); dcl 1 card aligned based (bufp), 2 hdrw bit (36) unal, 2 cksum bit (36) unal, 2 words (44) bit (18) unal; dcl 1 header unaligned based (hdrp), /* model of text header word */ 2 type bit (12) unaligned, 2 count bit (6) unaligned, 2 reladdr bit (18) unaligned; dcl words (44) bit (18) unal based (wdp); dcl 1 seg aligned based (segp), 2 count fixed bin, 2 core (0:32768) bit (18) unal; dcl name char (argl) based (argp); /* builtins */ dcl null builtin; /* External Entries */ dcl gcos_gsr_read_ ext entry (char (*), pointer, fixed bin, bit (12), bit (1), fixed bin); dcl gcos_gsr_read_$gsr_read_init ext entry (char (*), fixed bin); dcl gcos_gsr_read_$gsr_read_close entry (char(*), fixed bin); dcl ios_$attach ext entry (char (*), char (*), char (*), char (*), bit (72)); dcl ios_$setsize ext entry (char (*), fixed bin, bit (72)); dcl (ioa_, com_err_) ext entry options (variable); dcl cu_$arg_count ext entry returns (fixed bin); dcl cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin); dcl gcos_cv_gebcd_ascii_ ext entry (pointer, fixed bin, pointer, fixed bin); dcl expand_path_ ext entry (pointer, fixed bin, pointer, pointer, fixed bin); dcl ios_$detach ext entry (char (*), char (*), char (*), bit (72)); dcl hcs_$make_seg ext entry (char (*) aligned, char (*), char (*), fixed bin (5), pointer, fixed bin); dcl hcs_$set_bc_seg ext entry (ptr, fixed bin, fixed bin); dcl get_wdir_ ext entry returns (char (168) aligned); if cu_$arg_count () = 0 then do; /* tell user how to use command */ call com_err_ (0, "coreload", "Usage: coreload {name - objdk from map355}"); return; end; call cu_$arg_ptr (1, argp, argl, code); /* get input file name */ call expand_path_ (argp, argl, addr (dir), addr (ename), code); /* get entry name */ if code ^= 0 then go to error; if index (ename, ".objdk") > 0 then do; in_name = ename; out_name = substr (ename, 1, index (ename, ".") -1); end; else do; in_name = substr (ename, 1, index (ename, " ") -1) || ".objdk"; out_name = ename; end; fname = substr (dir, 1, index (dir, " ") -1) || ">" || in_name; call ios_$attach ("in", "file_", fname, "r", st); /* attach name "in" to file */ if err ^= 0 then go to ios_err; call ios_$setsize ("in", 36, st); /* set el size to 1 word */ call hcs_$make_seg (get_wdir_ (), out_name, "", 01010b, segp, code); /* make new seg */ if segp = null then go to error; call gcos_gsr_read_$gsr_read_init ("in", code); /* init reading */ if code ^= 0 then go to gc_error; loop: call gcos_gsr_read_ ("in", bufp, reclen, rcrdhdr, eofsw, code); /* get a record */ if code ^= 0 then go to gc_error; if eofsw then go to finis; if substr (rcrdhdr, 5, 2) = "10"b then do; /* hollerith card image */ call gcos_cv_gebcd_ascii_ (bufp, reclen*6, addr (ascii_card), 0); /* convert to ascii */ call ioa_ ("^a", ascii_card); /* let's see it */ go to loop; end; if substr (rcrdhdr, 5, 2) ^= "01"b then do; /* non-binary card image */ call com_err_ (0, "coreload", "illegal card type, not hollerith or binary"); go to det; end; full_count = 0; hdrp = addr (card.hdrw); if header.type = "000000000101"b then go to finis; /* transfer card, end of deck */ if header.type ^= "001000000101"b then do; call com_err_ (0, "coreload", "Illegal card type. Not abs text."); return; end; loc = fixed (header.reladdr); wdp = addr (card.words); do while (setup_block()); do i = 1 to fixed (header.count); seg.core (loc) = words (i); loc = loc + 1; end; full_count = full_count + fixed (header.count); end; go to loop; finis: seg.count = divide (loc + 1, 2, 17, 0); call hcs_$set_bc_seg (segp, seg.count*36, code); if code ^= 0 then go to error; det: call gcos_gsr_read_$gsr_read_close("in", code); call ios_$detach ("in", "", "", st); return; ios_err: call com_err_ (err, "coreload", "^a", in_name); go to det; error: call com_err_ (code, "coreload", "^a", name); go to det; gc_error: call com_err_ (code, "coreload", "From gcos_gsr_read_"); go to det; setup_block: proc returns (bit (1) aligned); dcl nhdr fixed bin; if full_count = 0 then return ("1"b); if full_count > 42 then return ("0"b); nhdr = fixed (header.count) + 1; hdrp = addr (words (nhdr)); if header.type ^= "001000000101"b then return ("0"b); wdp = addr (words (nhdr + 2)); full_count = full_count + 2; loc = fixed (header.reladdr); return ("1"b); end; end coreload;  fnp_data_summary.pl1 08/05/87 0757.0r 08/04/87 1540.8 171315 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* FNP_DATA_SUMMARY: Command to summarize fnp data from the syserr log collected by poll_fnp */ /* Written July 1981 by Robert Coren */ /* Most of this program was borrowed from the mpc_data_summary command. */ /* format: style4,delnl,insnl,^ifthendo */ fnp_data_summary: proc; dcl i fixed bin; dcl name char (17) int static options (constant) init ("fnp_data_summary"); /* Name of procedure */ dcl check_fnp fixed bin; dcl code fixed bin (35); /* Standard system status code */ dcl open_status bit (36) aligned; /* Code from syserr_log_util_$open */ dcl ptr_array (2) ptr; /* An array of pointers as required by get_temp_segment_ */ dcl tab_cnt fixed bin init (0); /* Number of seperate status found */ dcl mask bit (36) aligned init ("0"b); /* Mask of significant bits in status word */ dcl arg_ptr ptr; /* Pointer to an argument */ dcl arg_len fixed bin; /* Length of an argument */ dcl arg char (arg_len) based (arg_ptr); /* A command argument */ dcl arg_count fixed bin; /* The number of arguments */ dcl arg_list_ptr ptr; /* Pointer to commands argument list */ dcl for_ptr ptr; /* Saved pointer to the -for argument */ dcl for_len fixed bin; /* Saved length of -for argument */ dcl for_arg char (for_len) based (for_ptr); /* This is the -for argument */ dcl from_sw bit (1) init ("0"b); /* Set if -from used */ dcl to_sw bit (1) init ("0"b); /* Set if -to used */ dcl for_sw bit (1) init ("0"b); /* Set if -for used */ dcl more_args bit (1); /* Set while there are more arguments to scan */ dcl short_display_sw bit (1) init ("1"b); dcl short_arg bit (1) init ("0"b); dcl top_of_page_req bit (1) init ("0"b); dcl fnp_only bit (1) init ("0"b); dcl bf_sw bit (1) init ("0"b); dcl all_fnps bit (1) init ("0"b); /* all fnp's that we find will be summarized if no fnp name are in put this will set set */ dcl (output_file, of_file_att, of_file_open) bit (1) init ("0"b); /* output file to be used and if it is attached and open */ dcl ext_file bit (1) init ("0"b); /* set if the output file is to be extended */ dcl expand_sw bit (1) init ("0"b); /* set if each entry found is the syserr_log is to also be printed */ dcl segs_allocated bit (1) init ("0"b); /* Set after work segments created */ dcl from_time fixed bin (71); /* Time specified on -from */ dcl to_time fixed bin (71); /* Time specified on -to */ dcl for_time fixed bin (71); /* Time specified on -for */ dcl count_limit fixed bin init (0); /* Results for -limit arg */ dcl day_limit fixed bin init (0); /* Results for -day_limit arg */ dcl workp ptr; /* Pointer to work segment */ dcl arg_no fixed bin init (1); /* For scanning argument list */ dcl msg_time fixed bin (71); /* Time of syserrmessage */ dcl msg_seq fixed bin (35); /* Sequence number */ dcl fnp_cnt fixed bin init (0); /* Number of FNPs requested */ dcl temp fixed bin; dcl output_iocbp ptr; /* pointer to the output iocb */ dcl of_path char (168); /* path name used for output file */ dcl attach_desc char (180); /* variable used to build description used for output file when attached */ dcl (F_TIME, L_TIME) char (24); dcl fnp_statp ptr; dcl fnp_chan_statp ptr; /* BASED */ dcl 1 work aligned based (workp), /* Declaration of work segment */ 2 fnpreq (8) char (4), /* Table of requested FNPs */ 2 buffer (500) bit (36) aligned, /* Syserr messages are read here */ 2 entries_found fixed bin, /* number of syserr_log entries */ 2 first_time fixed bin (71), /* time fo the first syserr_log entry found fo this fnp */ 2 last_time fixed bin (71); /* time of the last syserr_log entry found for this fnp */ dcl 1 fnp_stats aligned based (fnp_statp), 2 n_channels fixed bin, 2 chan_stats (100) like fnp_chan_stats; dcl 1 fnp_chan_stats aligned based (fnp_chan_statp), 2 chan_name char (6) unal, 2 line_type fixed bin (17) unaligned, 2 stats (9) fixed bin (35); /* entries for syserr_log */ dcl syserr_log_util_$open entry (bit (36) aligned, fixed bin (35)); dcl print_syserr_msg_$open_err entry (bit (36) aligned, char (*), fixed bin (35)); dcl syserr_log_util_$read entry (ptr, fixed bin, fixed bin, fixed bin (35)); dcl syserr_log_util_$close entry (fixed bin (35)); dcl syserr_log_util_$search entry (fixed bin (71), fixed bin (71), fixed bin (35), fixed bin (35)); /* io type entries */ dcl ( ioa_, ioa_$ioa_switch ) entry options (variable); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$user_output ext ptr; /* misc entries */ dcl com_err_ entry options (variable); dcl get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35)); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl sys_info_$time_delta ext fixed bin (35); dcl parse_tty_name_ entry (char (*), fixed bin, bit (1), fixed bin, fixed bin); dcl meter_format_$picture entry (fixed bin (35), fixed bin) returns (char (15) var); /* error_table_ */ dcl error_table_$end_of_info ext fixed bin (35); dcl error_table_$badopt ext fixed bin (35); dcl error_table_$inconsistent ext fixed bin (35); dcl (cleanup, conversion) condition; dcl (addr, bin, divide, hbound, index, substr) builtin; /* Initialization */ on cleanup call clean_up; output_iocbp = iox_$user_output; call get_temp_segments_ (name, ptr_array, code); /* Get a work segment */ if code ^= 0 then do; call com_err_ (code, name, "Can't get temp segment"); go to done; end; segs_allocated = "1"b; /* Remember that they are allocated */ workp = ptr_array (1); /* Copy pointer to my segment */ fnp_statp = ptr_array (2); fnp_stats.n_channels = 0; call cu_$arg_list_ptr (arg_list_ptr); /* Need pointer to argument list */ call cu_$arg_count (arg_count, code); /* And the length */ if code ^= 0 then do; call com_err_ (code, name); return; end; more_args = (arg_count > 0); /* Set if args to scan */ call scan_args; /* Scan the argument list */ if fnp_cnt = 0 then all_fnps = "1"b; if output_file then do; if short_arg then short_display_sw = "1"b; else short_display_sw = "0"b; attach_desc = "vfile_ " || rtrim (of_path); if ext_file then attach_desc = rtrim (attach_desc) || " -extend"; call iox_$attach_ioname ("fnp_sum_sw", output_iocbp, attach_desc, code); if code ^= 0 then do; call com_err_ (code, name, "attaching ^a", rtrim (of_path)); goto done; end; of_file_att = "1"b; call iox_$open (output_iocbp, 2, "0"b, code);/* open for stream output */ if code ^= 0 then do; call com_err_ (code, name, "opening ^a", rtrim (of_path)); goto done; end; of_file_open = "1"b; end; temp = get_line_length_$switch (output_iocbp, code); if ^short_arg then do; if code ^= 0 | temp > 80 then short_display_sw = "0"b; else short_display_sw = "1"b; end; else short_display_sw = "1"b; if code ^= 0 | output_file then top_of_page_req = "1"b; else top_of_page_req = "0"b; call syserr_log_util_$open (open_status, code); /* Open the syserr log */ if code ^= 0 | substr (open_status, 1, 2) ^= "11"b then do; /* If error */ call print_syserr_msg_$open_err (open_status, name, code); if code ^= 0 then go to done; /* Not recoverable */ end; if ^from_sw then do; /* No -from, so start at beginning */ call syserr_log_util_$search (0, msg_time, msg_seq, code); if code ^= 0 then do; call com_err_ (code, name, "Can't find firstmessage in log."); go to done; end; from_time = msg_time; /* Official starting time */ end; else do; /* -from used, find rightmessage */ call syserr_log_util_$search (from_time, msg_time, msg_seq, code); if code ^= 0 then do; call com_err_ (code, name, "Locating firstmessage requested."); go to done; end; end; if for_sw then do; /* Now can compute -for limit */ call convert_date_to_binary_$relative (for_arg, to_time, from_time, code); if code ^= 0 then do; call com_err_ (code, name, "-for ^a", for_arg); go to done; end; to_sw = "1"b; /* Now, just as if -to was specified */ end; if ^to_sw then to_time = from_time; /* Initialize lastmessage time */ syserr_msgp = addr (work.buffer); /* Read here */ /* Loop thru the file */ loop: call syserr_log_util_$read (syserr_msgp, hbound (buffer, 1), (0), code); if code ^= 0 then do; if code = error_table_$end_of_info then go to print; call com_err_ (code, name, "Reading syserr log"); go to done; end; if to_sw then do; /* If time limit */ if syserr_msg.time > to_time then go to print; end; else to_time = syserr_msg.time; /* Save lastmessage time */ if syserr_msg.data_code = SB_fnp_poll & syserr_msg.data_size > 0 then do; poll_fnp_datap = addr (syserr_msg.data); if look_for (poll_fnp_data.name) then call count_it; end; go to loop; /* End of log reached */ print: call print_it; /* Print results */ /* End of command */ done: call clean_up; return; count_it: proc; /* This proc will take the syserr entry in poll_fnp_data format and interpret it so as to record the maximum value of every statistic for each channel in the fnp_stats array. */ dcl i fixed bin; dcl statx fixed bin; dcl chanx fixed bin; dcl found bit (1); dcl stat_type fixed bin; if work.entries_found = 0 then work.first_time = syserr_msg.time; work.entries_found = work.entries_found + 1; work.last_time = syserr_msg.time; if expand_sw then call expand_syserr_entry; /* user wants each entry expanded */ do statx = 1 to poll_fnp_data.n_stats; chanx = poll_fnp_data.stat_info (statx).chan_index; stat_type = poll_fnp_data.stat_info (statx).stat_index; found = "0"b; do i = 1 to fnp_stats.n_channels; fnp_chan_statp = addr (fnp_stats.chan_stats (i)); if fnp_chan_stats.chan_name = poll_fnp_data (chanx).chan_name then do; found = "1"b; if poll_fnp_data.stat_info (statx).value > fnp_chan_stats.stats (stat_type) then fnp_chan_stats.stats (stat_type) = poll_fnp_data.stat_info (statx).value; end; end; if ^found /* first message for this channel */ then do; fnp_stats.n_channels = fnp_stats.n_channels + 1; fnp_chan_statp = addr (fnp_stats.chan_stats (fnp_stats.n_channels)); fnp_chan_stats.chan_name = poll_fnp_data (chanx).chan_name; fnp_chan_stats.line_type = poll_fnp_data (chanx).line_type; fnp_chan_stats.stats (*) = 0; fnp_chan_stats.stats (stat_type) = poll_fnp_data.stat_info (statx).value; end; end; end count_it; look_for: proc (fnp_name) returns (bit (1)); /* This proc will return a bit = "1"b then we want to count this data */ dcl fnp_name char (4) aligned; dcl i fixed bin; if poll_fnp_data.n_stats = 0 then return ("0"b); do i = 1 to fnp_cnt; if fnp_name = work.fnpreq (i) then return ("1"b); end; if all_fnps then do; /* count all we find */ fnp_cnt = fnp_cnt + 1; work.fnpreq (fnp_cnt) = fnp_name; return ("1"b); end; return ("0"b); end look_for; /* Procedure to print results */ print_it: proc; dcl i fixed bin; dcl chanx fixed bin; dcl fnp_no fixed bin; dcl hsla_flag bit (1); dcl la_no fixed bin; dcl subchan fixed bin; if fnp_stats.n_channels > 0 then do; call date_time_ (work.first_time, F_TIME); call date_time_ (work.last_time, L_TIME); if top_of_page_req then call ioa_$ioa_switch (output_iocbp, "^|"); else call ioa_$ioa_switch (output_iocbp, "^2/"); call ioa_$ioa_switch (output_iocbp, "^10x^d syserr log entries^/^10xfrom: ^a^/^12xto: ^a", work.entries_found, F_TIME, L_TIME); do chanx = 1 to fnp_stats.n_channels; fnp_chan_statp = addr (fnp_stats.chan_stats (chanx)); call parse_tty_name_ (fnp_chan_stats.chan_name, fnp_no, hsla_flag, la_no, subchan); call ioa_$ioa_switch (output_iocbp, "^/Channel ^a (FNP ^a, ^[H^;L^]SLA ^d, subchannel ^2d), line type ^a", fnp_chan_stats.chan_name, substr ("ABCDEFGH", fnp_no, 1), hsla_flag, la_no, subchan, line_types (fnp_chan_stats.line_type)) ; if fnp_chan_stats.stats (9) > 0 then call ioa_$ioa_switch (output_iocbp, "^10xParity errors: ^a", meter_format_$picture (fnp_chan_stats.stats (9), 11)); do i = 1 to 8; if fnp_chan_stats.stats (i) > 0 then call ioa_$ioa_switch (output_iocbp, "^10xCounter (^d):^2x^a", i, meter_format_$picture (fnp_chan_stats.stats (i), 11)); end; end; end; else do; call date_time_ (from_time, F_TIME); call date_time_ (to_time, L_TIME); call ioa_$ioa_switch (output_iocbp, "No syserr_log entries found for specified FNP(s)^/from: ^a^/^2xto: ^a", F_TIME, L_TIME); end; end print_it; /* expand each entry */ expand_syserr_entry: proc; dcl last_chanx fixed bin; dcl chanx fixed bin; dcl statx fixed bin; call date_time_ (work.last_time, F_TIME); call ioa_$ioa_switch (output_iocbp, "^Entry number ^d at ^a", work.entries_found, F_TIME); if poll_fnp_data.n_stats = 0 then call ioa_$ioa_switch (output_iocbp, "No statistics."); else do; last_chanx = 0; do statx = 1 to poll_fnp_data.n_stats; chanx = poll_fnp_data.stat_info (statx).chan_index; if chanx ^= last_chanx /* new channel */ then do; call ioa_$ioa_switch (output_iocbp, "Channel ^a:", poll_fnp_data.chan_info (chanx).chan_name); last_chanx = chanx; end; call ioa_$ioa_switch (output_iocbp, "^5x^[Parity^s^;Counter (^d)^]: ^a", poll_fnp_data.stat_info (statx).stat_index = 9, poll_fnp_data.stat_info (statx).stat_index, meter_format_$picture (poll_fnp_data.stat_info (statx).value, 11)); end; end; end expand_syserr_entry; /* Cleanup handler */ clean_up: proc; call syserr_log_util_$close (code); if output_file then do; if of_file_open then call iox_$close (output_iocbp, code); if of_file_att then call iox_$detach_iocb (output_iocbp, code); end; if segs_allocated then do; segs_allocated = "0"b; call release_temp_segments_ (name, ptr_array, code); end; return; end clean_up; /* Procedure to scan the argument list */ scan_args: proc; dcl fnp_no fixed bin; dcl parse_fnp_name_ entry (char (*), fixed bin); do while (more_args); /* Do while thins to look at */ call get_arg; if arg = "-from" | arg = "-fm" then do; /* Start time */ from_sw = "1"b; call time_arg (from_time); end; else if arg = "-to" then do; /* Ending time */ to_sw = "1"b; call time_arg (to_time); end; else if arg = "-for" then do; /* Time limit */ for_sw = "1"b; call time_arg (for_time); /* For syntax checking only */ for_len = arg_len; /* Save pointer to this argument */ for_ptr = arg_ptr; end; else if arg = "-expand" then expand_sw = "1"b; else if arg = "-of" | arg = "output_file" then do; if more_args then do; call get_arg; if index (arg, "-") ^= 1 then of_path = arg; else do; of_path = rtrim (name) || ".output"; call put_arg; end; end; else of_path = rtrim (name) || ".output"; short_display_sw = "0"b; output_file = "1"b; end; else if arg = "-ext" | arg = "-extend" then ext_file = "1"b; else if index (arg, "-") ^= 1 then do; call parse_fnp_name_ (arg, fnp_no); if fnp_no < 0 then do; call com_err_ (0, name, "Invalid FNP name: ^a", arg); go to done; end; do check_fnp = 1 to fnp_cnt; if arg = work.fnpreq (check_fnp) then goto skip; end; if fnp_cnt = hbound (work.fnpreq, 1) then do; call com_err_ (0, name, "There were more than ^d FNPs specified.", hbound (work.fnpreq, 1)); go to done; end; fnp_cnt = fnp_cnt + 1; /* Count FNP found */ all_fnps = "0"b; work.fnpreq (fnp_cnt) = arg; /* Save name */ skip: end; else do; /* Bad arg */ call com_err_ (error_table_$badopt, name, "^a", arg); go to done; end; end; if to_sw & for_sw then do; /* Conflict */ call com_err_ (error_table_$inconsistent, name, "-to and -for"); go to done; end; if ext_file & ^output_file then do; call com_err_ (error_table_$inconsistent, name, "-extend without -output_file"); go to done; end; return; end scan_args; /* Procedure to return the next argument from command line */ get_arg: proc; call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then do; /* Should never happen */ call com_err_ (code, name, "Arg ^d", arg_no); go to done; end; arg_no = arg_no + 1; /* For next call */ more_args = (arg_no <= arg_count); return; put_arg: entry; /* Entry to return argument after scanning too far */ arg_no = arg_no - 1; more_args = (arg_no <= arg_count); return; end get_arg; /* Procedure to convert a time argument */ time_arg: proc (t); dcl t fixed bin (71); /* The time to ouput */ dcl arg_copy char (10) var; /* Save copy of arg here */ arg_copy = arg; if ^more_args then do; /* Must be more */ call com_err_ (0, name, "Argument required after ^a.", arg_copy); go to done; end; call get_arg; call convert_date_to_binary_ (arg, t, code); if code ^= 0 then do; call com_err_ (code, name, "^a ^a", arg_copy, arg); go to done; end; return; end time_arg; %include syserr_message; %include poll_fnp_data; %include line_types; %include syserr_binary_def; end fnp_data_summary;  manipulate_pathname_.pl1 11/15/82 1821.5rew 11/15/82 1504.5 84303 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1974 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ manipulate_pathname_: procedure (); /* "manipulate_pathname_" -- procedure that contains */ /* several routines to manipulate pathnames (as opposed to */ /* dirnames and enames). Such manipulations include getting */ /* the equivalent pathname which is of the shortest character */ /* length, the equivalent pathname which contains only */ /* primary enames, etc. It is a feature of the routines that */ /* the caller may use the same string for input and output */ /* pathnames. Also note that the concept of directory links */ /* is ignored by these routines. */ /* Originally coded by D. M. Wells in Spring, 1973. */ /* Last modified by D. M. Wells to February, 1974 to prepare */ /* for installation. */ /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (bv_err_code bit (36) aligned, bv_input_pathname character (*), bv_output_pathname character (*)) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare ((indx, output_ename_indx) fixed binary (17), (cur_loc, name_len, next_loc, output_ename_len) fixed binary (24), desired_type character (8), name character (32), (in_name, out_name) character (168) varying, (area_ptr, link_ptr, names_ptr) pointer) automatic; declare 1 entry_branch unaligned automatic, 2 type bit (2) unaligned, 2 nnames bit (16) unaligned, 2 nrp bit (18) unaligned, 2 dtm bit (36) unaligned, 2 dtu bit (36) unaligned, 2 mode bit (5) unaligned, 2 padding bit (13) unaligned, 2 records bit (18) unaligned; /* * * * * DEFINED DECLARATIONS * * * * * * * * */ declare 1 link_branch unaligned defined (entry_branch), 2 type bit (2) unaligned, 2 nnames bit (16) unaligned, 2 nrp bit (18) unaligned, 2 dtem bit (36) unaligned, 2 dtd bit (36) unaligned, 2 pnl bit (18) unaligned, 2 pnrp bit (18) unaligned; /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare (based_names (1 : 1) character (32) aligned, based_link_pathname character (binary (link_branch.pnl, 18)) aligned, based_area area) based; /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare error_table_$bad_segment bit (36) aligned external static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare establish_cleanup_proc_ constant entry (entry), get_system_free_area_ constant entry () returns (ptr), hcs_$status_ constant entry (char (*), char (*), fixed bin (1), ptr, ptr, bit (36) aligned); declare (addr, binary, index, length, max, pointer, reverse, substr, verify) builtin; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Entry point to prepare the shortest equivalent */ /* pathname (as measured in characters). */ get_shortest_pathname_: entry (bv_input_pathname, bv_output_pathname, bv_err_code); desired_type = "shortest"; goto common_code; /* * * * * * * * * * * * * * * * * * * * * * * * */ /* Entry point to prepare the longest equivalent */ /* pathname (as measured in characters). */ get_longest_pathname_: entry (bv_input_pathname, bv_output_pathname, bv_err_code); desired_type = "longest "; goto common_code; /* * * * * * * * * * * * * * * * * * * * * * * * */ /* Entry point to prepare the equivalent pathname */ /* using only primary entry names. */ get_primary_pathname_: entry (bv_input_pathname, bv_output_pathname, bv_err_code); desired_type = "primary "; goto common_code; /* * * * * * * * * * * * * * * * * * * * * * * * */ common_code: name_len = length (bv_input_pathname) - verify (reverse (bv_input_pathname), " ") + 1; in_name = substr (bv_input_pathname, 1, name_len) || ">"; cur_loc = 1; out_name = ""; area_ptr = get_system_free_area_ (); names_ptr = null (); link_ptr = null (); entry_branch.nrp = ""b; link_branch.pnrp = ""b; call establish_cleanup_proc_ (cleanup); do while ("1"b); next_loc = index (substr (in_name, cur_loc + 1), ">"); if next_loc = 0 then goto almost_done; next_loc = cur_loc + next_loc; call hcs_$status_ (substr (in_name, 1, max (cur_loc - 1, 1)), substr (in_name, cur_loc + 1, next_loc - cur_loc - 1), 0b, addr (entry_branch), area_ptr, bv_err_code); if bv_err_code ^= ""b then return; names_ptr = pointer (area_ptr, entry_branch.nrp); entry_branch.nrp = ""b; if entry_branch.type = "00"b then link_ptr = pointer (area_ptr, link_branch.pnrp); else link_ptr = null (); link_branch.pnrp = ""b; if desired_type = "primary " then do; output_ename_indx = 1; output_ename_len = length (names_ptr -> based_names (1)) - verify (reverse (names_ptr -> based_names (1)), " ") + 1; out_name = out_name || ">" || substr (names_ptr -> based_names (output_ename_indx), 1, output_ename_len); end; else if desired_type = "shortest" then do; output_ename_len = 33; output_ename_indx = 0; do indx = 1 by 1 to binary (entry_branch.nnames, 16); name = names_ptr -> based_names (indx); name_len = length (name) - verify (reverse (name), " ") + 1; if name_len < output_ename_len then do; output_ename_indx = indx; output_ename_len = name_len; end; end; out_name = out_name || ">" || substr (names_ptr -> based_names (output_ename_indx), 1, output_ename_len); end; else if desired_type = "longest " then do; output_ename_len = -1; output_ename_indx = 0; do indx = 1 by 1 to binary (entry_branch.nnames, 16); name = names_ptr -> based_names (indx); name_len = length (name) - verify (reverse (name), " ") + 1; if name_len > output_ename_len then do; output_ename_indx = indx; output_ename_len = name_len; end; end; out_name = out_name || ">" || substr (names_ptr -> based_names (output_ename_indx), 1, output_ename_len); end; else goto something_got_messed_up_in_here; call cleanup (); cur_loc = next_loc; end; /* * * * * * * * * * * * * * * * * * * */ almost_done: bv_output_pathname = out_name; bv_err_code = ""b; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ something_got_messed_up_in_here: bv_err_code = error_table_$bad_segment; /* only this time, its us that's bad */ return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ cleanup: procedure (); /* * * * * * * * * * * * * * * * * * * * * * * * */ if names_ptr ^= null () then free names_ptr -> based_names in (area_ptr -> based_area); if link_ptr ^= null () then free link_ptr -> based_link_pathname in (area_ptr -> based_area); else if (entry_branch.type = "00"b) & (link_branch.pnrp ^= ""b) then free pointer (area_ptr, link_branch.pnrp) -> based_link_pathname in (area_ptr -> based_area); return; end cleanup; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end manipulate_pathname_;  map355.pl1 11/15/82 1821.5rew 11/15/82 1504.6 214155 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ map355: procedure (); /* "map355" -- command to assemble a Macro Assembly for */ /* the DataNet-355 computer. This assembly process is */ /* currently performed by invoking the GCOS simulator. This */ /* particular method has the drawbacks that 1) it tends to use */ /* features of the Honeywell/6180 which Multics does not use */ /* (and thus are more unlikely to work properly) and 2) it */ /* uses the GCOS simulator which is actually designed for use */ /* by the GCOS Daemon. It is this particular problem which */ /* causes this program to do such things as link to things */ /* in the process directory (to get temporary segments). */ /* Originally coded by D. M. Wells in Spring, 1973. */ /* Modified by D. M. Wells in February, 1974, to prepare */ /* for installation. */ /* Modified by T. Casey, May 1974, for compatibility with new */ /* gcos simulator. */ /* Modified by M. Grady, May, 1976, to fix core size and */ /* cleanup code. */ /* Modified by Robert coren, April, 1978, to supply severity value */ /* * * * * PARAMETER DECLARATIONS * * * * * * * */ /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare ((num_args, pddl) fixed binary (17), (arg_length, bit_count, string_len) fixed binary (24), err_code bit (36) aligned, NP character (1), /* cant put this in a canonicalized file */ ename character (32), dirname character (168), (base_name, job_name, map355_options) character (32) varying, (gcos_list_pathname, list_pathname, macro_file_pathname, jobdeck_pathname, process_dir, source_dir, working_dir, pdd) character (168) varying, argsw bit (1) aligned init ("0"b), args char (200) varying init ("-brief"), var_line char (300) varying init (""), command_line char (300) init (""), (acl_info_ptr, arg_ptr, object_seg_ptr) pointer) automatic; declare 1 options unaligned automatic, 2 only_check bit (1), 2 from_comdk bit (1), 2 make_comdk bit (1), 2 make_list bit (1), 2 make_gcos_list bit (1); declare 1 status aligned automatic, 2 error_code bit (36) aligned, 2 detail_info unaligned, 3 successful_logical_initiation bit (1), 3 successful_logical_completion bit (1), 3 successful_physical_initiation bit (1), 3 successful_physical_completion bit (1), 3 transaction_terminated bit (1), 3 unassigned_bits_42_to_45 (42 : 45) bit (1), 3 end_of_logical_data_indicator bit (1), 3 end_of_physical_data_indicator bit (1), 3 unassigned_bits_48_to_51 (48 : 51) bit (1), 3 stream_name_detached bit (1), 3 unassigned_bit_53 bit (1), 3 transaction_aborted bit (1), 3 transaction_index bit (18); /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare NL initial (" ") character (1) internal static; declare (comdk_suffix character (6) initial (".comdk"), source_suffix character (7) initial (".map355"), job_deck_stream character (16) initial ("map355_job_deck_")) internal static; /* * * * * BASED & TEMPLATE DECLARATIONS * * * * */ declare based_argument character (arg_length) based; /* * * * * EXTERNAL STATIC DECLARATIONS * * * * */ declare error_table_$badopt bit (36) aligned external static; declare map355_severity_ fixed bin (35) ext static; /* * * * * ENTRY & PROCEDURE DECLARATIONS * * * */ declare adjust_bit_count_ entry (char (168), char (32), bit (1) aligned, fixed bin (24), bit (36) aligned), com_err_ entry options (variable), cu_$arg_count entry (fixed bin (17)), cu_$arg_list_ptr entry () returns (ptr), cu_$arg_ptr_rel entry (fixed bin (17), ptr, fixed bin (24), bit (36) aligned, ptr), cu_$cp ext entry (ptr, fixed bin, bit (36) aligned), delete_$path entry (char (*), char (*), bit (6), char (*), bit (36) aligned), expand_path_ entry (ptr, fixed bin (24), ptr, ptr, bit (36) aligned), get_pdir_ entry () returns (char (168) aligned), get_shortest_pathname_ entry (char (*), char (*), bit (36) aligned), get_wdir_ entry () returns (char (168) aligned), hcs_$append_link entry (char (*), char (*), char (*), bit (36) aligned), hcs_$delentry_file entry (char (*), char (*), bit (36) aligned), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, bit (36) aligned), hcs_$set_bc entry (char (*), char (*), fixed bin (24), bit (36) aligned), hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), bit (36) aligned), hcs_$terminate_noname entry (ptr, bit (36) aligned), ioa_ entry options (variable), ioa_$ioa_stream entry options (variable), ios_$attach entry (char (*), char (*), char (*), char (*), 1 aligned like status), ios_$detach entry (char (*), char (*), char (*), 1 aligned like status), ios_$seek entry (char (*), char (*), char (*), fixed bin (24), 1 aligned like status), ios_$write_ptr entry (ptr, fixed bin (24), fixed bin (24)), tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, bit (36) aligned), tssi_$get_segment entry (char (*), char (*), ptr, ptr, bit (36) aligned); declare (addr, divide, index, length, null, reverse, substr, unspec, verify) builtin; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ map355_severity_ = 0; /* initially */ unspec (NP) = "000001100"b; dirname = get_pdir_ (); string_len = length (dirname) - verify (reverse (dirname), " ") + 1; process_dir = substr (dirname, 1, string_len); dirname = get_wdir_ (); string_len = length (dirname) - verify (reverse (dirname), " ") + 1; working_dir = substr (dirname, 1, string_len); call ioa_ ("MAP355"); call cu_$arg_count (num_args); if num_args = 0 then do; call ioa_ ("Usage is:^/^10xmap355 source -options-"); call ioa_ ("Current options are: -list, -comdk, -check, -noconvert, -gcos_list, -macro_file -ag "); map355_severity_ = 2; return; end; call process_options (cu_$arg_list_ptr (), num_args); pddl = length (process_dir) - index (reverse (process_dir), ">"); /* get length of pdd */ pdd = substr (process_dir, 1, pddl); /* get process dir dir name */ call reduce_path_name (pdd); /* reduce pdd name */ process_dir = pdd || substr (process_dir, pddl + 1); /* reconstruct name */ call reduce_path_name (working_dir); call reduce_path_name (source_dir); call reduce_path_name (macro_file_pathname); jobdeck_pathname = process_dir || ">" || job_name || ".jobdk_"; call ios_$attach ((job_deck_stream), "file_", (jobdeck_pathname), "w", status); if status.error_code ^= ""b then do; err_code = status.error_code; goto print_err_code; end; call ios_$seek ((job_deck_stream), "write", "first", 0, status); call ioa_$ioa_stream ((job_deck_stream), "$ snumb assm"); call ioa_$ioa_stream ((job_deck_stream), "$ ident 1234,ident"); map355_options = ""; if options.only_check then map355_options = map355_options || "ndeck,"; else map355_options = map355_options || "deck,"; if options.make_comdk then map355_options = map355_options || "comdk,"; else map355_options = map355_options || "ncomdk,"; map355_options = substr (map355_options, 1, length (map355_options) - 1); call ioa_$ioa_stream ((job_deck_stream), "$ 355map ^a", map355_options); call ioa_$ioa_stream ((job_deck_stream), "$ limits 20,128k 0.20 = 12 minutes"); if options.from_comdk then call ioa_$ioa_stream ((job_deck_stream), "$ prmfl g*,r,l,^a>^a.comdk", source_dir, base_name); else do; call ioa_$ioa_stream ((job_deck_stream), "$ data g*"); call ioa_$ioa_stream ((job_deck_stream), "$ select ^a>^a^x-ascii", (source_dir), base_name || source_suffix); end; call ioa_$ioa_stream ((job_deck_stream), "$ prmfl **,r,r,^a", macro_file_pathname); if options.make_gcos_list then gcos_list_pathname = working_dir || ">" || base_name || ".glist"; else gcos_list_pathname = process_dir || ">" || base_name || ".glist_"; call ioa_$ioa_stream ((job_deck_stream), "$ prmfl p*,r/w,l,^a", gcos_list_pathname); if ^ options.only_check then call ioa_$ioa_stream ((job_deck_stream), "$ prmfl c*,r/w,l,^a>^a.objdk", working_dir, base_name); if options.make_comdk then call ioa_$ioa_stream ((job_deck_stream), "$ prmfl k*,r/w,l,^a>^a.comdk", working_dir, base_name); call ioa_$ioa_stream ((job_deck_stream), "$ endjob"); call ios_$seek ((job_deck_stream), "bound", "write", 0, status); call ios_$detach ((job_deck_stream), "", "", status); if ^ options.only_check then do; call tssi_$get_segment ((working_dir), base_name || ".objdk", object_seg_ptr, acl_info_ptr, err_code); if err_code ^= ""b then do; call com_err_ (err_code, "map355", "Attempting to create object segment."); map355_severity_ = 2; return; end; end; call hcs_$append_link ((working_dir), (job_name || ".jobdk_.job_deck"), (jobdeck_pathname || ".job_deck"), err_code); var_line = "gcos " || jobdeck_pathname || " -hd -tnc " || args; command_line = var_line; call cu_$cp (addr (command_line), length (var_line), err_code); if options.make_list then list_pathname = working_dir || ">" || base_name || ".list"; else list_pathname = process_dir || ">" || base_name || ".list_"; var_line = "gcos_sysprint " || gcos_list_pathname || " " || list_pathname || " -lower_case"; command_line = var_line; call cu_$cp (addr (command_line), length (var_line), err_code); call check_error_messages ((list_pathname)); if ^ options.only_check then do; call adjust_bit_count_ ((working_dir), base_name || ".objdk", "0"b, bit_count, err_code); call tssi_$finish_segment (object_seg_ptr, bit_count, "1000"b, acl_info_ptr, err_code); if err_code ^= ""b then do; call com_err_ (err_code, "map355", "Calling tssi_$finish_segment."); map355_severity_ = 2; return; end; end; if options.make_comdk then call abc_new_comdk (); dirname = process_dir; /* copy process dir name for calls to hardcore */ if ^ options.make_list then call delete_$path (dirname, base_name || ".list_", "100110"b, "map355", err_code); if ^ options.from_comdk then call delete_$path (dirname, base_name || ".comdk_", "100110"b, "map355", err_code); call hcs_$delentry_file (dirname, job_name || ".jobdk_", err_code); call hcs_$delentry_file (dirname, job_name || ".jobdk_.job_deck", err_code); if ^ options.make_gcos_list then call delete_$path (dirname, base_name || ".glist_", "100110"b, "map355", err_code); dirname = working_dir; call hcs_$delentry_file (dirname, job_name || ".jobdk_.sysprint", err_code); call hcs_$delentry_file (dirname, job_name || ".jobdk_.job_deck", err_code); return; /* * * * * * * * * * * * * * * * * * * * * * * * */ print_err_code: unexpected_error: call com_err_ (err_code, "map355", ""); map355_severity_ = 2; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ path_name_error: call com_err_ ((36)"0"b, "map355", "path_name_error"); return_to_caller: map355_severity_ = 2; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ reduce_path_name: procedure (bv_path_name); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare bv_path_name character (168) varying parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare string_len fixed binary (24) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ dirname = bv_path_name; call get_shortest_pathname_ (dirname, dirname, err_code); if err_code ^= ""b then goto print_err_code; string_len = length (dirname) - verify (reverse (dirname), " ") + 1; bv_path_name = substr (dirname, 1, string_len); return; end reduce_path_name; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ abc_new_comdk: procedure (); /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare bit_count fixed binary (24) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ call hcs_$status_minf ((working_dir), base_name || ".comdk", 1b, (0), bit_count, err_code); if err_code ^= ""b then do; call com_err_ (err_code, "map355", "unable to set bit count on new comdk"); map355_severity_ = 2; return; end; bit_count = divide (bit_count, 36, 24, 0); bit_count = divide (bit_count, 320, 24, 0); bit_count = bit_count * 320; bit_count = bit_count + 320; bit_count = bit_count * 36; call hcs_$set_bc ((working_dir), base_name || ".comdk", bit_count, err_code); if err_code ^= ""b then do; call com_err_ (err_code, "map355", "unable to set bit count (^d) on new comdk", bit_count); map355_severity_ = 2; return; end; return; end abc_new_comdk; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_error_messages: procedure (bv_list_pathname); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare bv_list_pathname character (*) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (seg_type fixed binary (2), (message_seg, seg_indx) fixed binary (12), (bit_count, cur_position, last_char, newline_pos, temp_pos, the_end_pos) fixed binary (24), seg_length (0 : 9) fixed binary (24), temp_char character (1), entry_name character (32), dir_name character (168), seg_pointer (0 : 9) pointer) automatic; /* * * * * TEXT SECTION REFERENCES * * * * * * * */ declare number (0 : 9) character (1) initial ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9") internal static; /* * * * * BASED & TEMPLATE REFERENCES * * * * * */ declare based_seg character (last_char) based; /* * * * * STACK REFERENCES * * * * * * * * * * */ declare program_interrupt condition; /* * * * * * * * * * * * * * * * * * * * * * * * */ call expand_path_ (addr (bv_list_pathname), length (bv_list_pathname), addr (dir_name), addr (entry_name), err_code); if err_code ^= ""b then goto err; call hcs_$status_minf (dir_name, entry_name, 1b, seg_type, bit_count, err_code); /* see if this is a multisegment file */ if err_code ^= ""b then goto err; if seg_type = 2 then do; /* this is a directory (read: multi-segment file) */ call expand_path_ (addr (bv_list_pathname), length (bv_list_pathname), addr (dir_name), null (), err_code); do seg_indx = 0 to bit_count - 1; call hcs_$initiate_count (dir_name, (number (seg_indx)), "", seg_length (seg_indx), 0, seg_pointer (seg_indx), err_code); if seg_pointer (seg_indx) = null () then goto err; end; /* seg_pointer and seg_length arrays now hold addresses and */ /* bit_counts of each of N segs from 0 to N - 1 */ end; else do; bit_count = 1; call hcs_$initiate_count (dir_name, entry_name, "", seg_length (0), 0, seg_pointer (0), err_code); if seg_pointer (0) = null () then goto err; end; seg_indx = bit_count; cur_position = 0; do while (cur_position = 0); seg_indx = seg_indx - 1; if seg_indx < 0 then do; call com_err_ ((36)"0"b, "map355", "can't find assembly error count message"); goto terminate; end; last_char = divide (seg_length (seg_indx), 9, 24, 0); /* get char lenth of a seg */ cur_position, the_end_pos = index (seg_pointer (seg_indx) -> based_seg, "warning flags in the above assembly"); /* look for assembly total error count */ end; /* Now, character cur_position in segment seg_indx */ /* points to the middle of the error count line, if this */ /* count is non-zero, we also want to print the error lines */ message_seg = seg_indx; call ios_$write_ptr (seg_pointer (message_seg), cur_position - 19, 54); if substr (seg_pointer (message_seg) -> based_seg, cur_position - 4, 2) ^= "no" then do; /* if there are any errors, print messages */ map355_severity_ = 1; /* and remember the fact */ on program_interrupt /* if user doesn't want to see these lines, */ goto terminate; /* let him suppress the printing of them */ do seg_indx = 0 by 1 to message_seg; /* loop to print errors */ last_char = divide (seg_length (seg_indx), 9, 24, 0); /* get char length of a seg */ if seg_indx = 0 then do; cur_position = index (substr (seg_pointer (0) -> based_seg, 1, last_char), "program break"); /* don't print alter listing */ if cur_position = 0 then do; call com_err_ ((36)"0"b, "map355", "can't find ""program break""."); cur_position = 1; end; end; else cur_position = 1; do while (cur_position < last_char); if (seg_indx = message_seg) & (cur_position >= the_end_pos) then goto terminate; /* no need to look further */ newline_pos = index (substr (seg_pointer (seg_indx) -> based_seg, cur_position, last_char + 1 - cur_position), NL); if newline_pos = 0 then goto done; /* done with this segment */ temp_char = substr (seg_pointer (seg_indx) -> based_seg, cur_position + newline_pos, 1); if (temp_char ^= " ") & (temp_char ^= NP) & (index ("0123456789", temp_char) = 0) & (temp_char ^= NL) then do; temp_pos = index (substr (seg_pointer (seg_indx) -> based_seg, cur_position + newline_pos, last_char - cur_position - newline_pos + 1), NL); /* look for next newline */ if temp_pos = 0 then temp_pos = last_char - cur_position - newline_pos + 1; /* this indicates */ /* error in last line in seg -- NP */ call ioa_ (substr (seg_pointer (seg_indx) -> based_seg, cur_position + newline_pos, temp_pos - 1)); /* print line in error */ end; cur_position = cur_position + newline_pos; end; done: end; end; terminate: revert program_interrupt; do seg_indx = 0 to bit_count - 1; call hcs_$terminate_noname (seg_pointer (seg_indx), err_code); end; return; /* * * * * * * * * * * * * * * * * * * * * * * * */ err: call com_err_ (err_code, "map355", "checking for error messages in listing file."); map355_severity_ = 2; /* couldn't find error message, something must be wrong */ return; end check_error_messages; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_options: procedure (bv_arg_list_ptr, bv_num_args); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare (bv_num_args fixed binary (17), bv_arg_list_ptr pointer) parameter; /* * * * * AUTOMATIC STORAGE DECLARATIONS * * * */ declare (indx fixed binary (17), string_len fixed binary (24)) automatic; /* * * * * * * * * * * * * * * * * * * * * * * * */ call cu_$arg_ptr_rel (1, arg_ptr, arg_length, err_code, bv_arg_list_ptr); if err_code ^= ""b then goto unexpected_error; call expand_path_ (arg_ptr, arg_length, addr (dirname), addr (ename), err_code); if err_code ^= ""b then goto print_err_code; string_len = length (dirname) - verify (reverse (dirname), " ") + 1; source_dir = substr (dirname, 1, string_len); string_len = length (ename) - verify (reverse (ename), " ") + 1; if options.from_comdk then do; if string_len > length (comdk_suffix) then if substr (ename, string_len + 1 - length (comdk_suffix), length (comdk_suffix)) = comdk_suffix then string_len = string_len - length (comdk_suffix); end; else do; if string_len > length (source_suffix) then if substr (ename, string_len + 1 - length (source_suffix), length (source_suffix)) = source_suffix then string_len = string_len - length (source_suffix); end; base_name = substr (ename, 1, string_len); if length (base_name) > 11 then job_name = substr (base_name, 1, 11); else job_name = base_name; macro_file_pathname = ">ldd>mcs>info>355_macros"; options.only_check = "0"b; options.make_comdk = "0"b; options.from_comdk = "0"b; options.make_list = "0"b; options.make_gcos_list = "0"b; do indx = 2 by 1 to bv_num_args; call cu_$arg_ptr_rel (indx, arg_ptr, arg_length, err_code, bv_arg_list_ptr); if err_code ^= ""b then goto unexpected_error; call process_control_argument (arg_ptr -> based_argument); end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_control_argument: procedure (bv_control_argument); /* * * * * PARAMETER DECLARATIONS * * * * * * * */ declare bv_control_argument character (*) parameter; /* * * * * * * * * * * * * * * * * * * * * * * * */ if argsw then do; args = args || " " || bv_control_argument; return; end; if (bv_control_argument = "-ag" | bv_control_argument = "-arguments") then do; argsw = "1"b; args = ""; /* clear the default of -brief */ return; end; if bv_control_argument = "-noconvert" then do; options.from_comdk = "1"b; return; end; if (bv_control_argument = "-list") | (bv_control_argument = "-ls") then do; options.make_list = "1"b; return; end; if bv_control_argument = "-comdk" then do; options.make_comdk = "1"b; return; end; if bv_control_argument = "-check" then do; options.only_check = "1"b; return; end; if (bv_control_argument = "-gcos_list") | (bv_control_argument = "-gcls") then do; options.make_gcos_list = "1"b; return; end; if (bv_control_argument = "-macro_file") then do; indx = indx + 1; call cu_$arg_ptr_rel (indx, arg_ptr, arg_length, err_code, bv_arg_list_ptr); if err_code ^= ""b then do; call com_err_ (err_code, "map355", "getting pathname of macros"); goto return_to_caller; end; call expand_path_ (arg_ptr, arg_length, addr (dirname), null (), err_code); if err_code ^= ""b then do; call com_err_ (err_code, "map355", "Expanding pathname of macro file."); goto return_to_caller; end; macro_file_pathname = dirname; return; end; call com_err_ (error_table_$badopt, "map355", bv_control_argument); goto return_to_caller; end process_control_argument; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end process_options; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end map355;  poll_fnp.pl1 07/20/88 1258.3r w 07/19/88 1537.0 182592 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* POLL_FNP - Command to periodically log the statistics for FNPs */ /* Written July 1981 by Robert Coren, in imitation of poll_mpc */ /* Modified October 1982 by C. Hornig for new config tools. */ /* Modified 83-12-15 BIM for prph fnp cards */ /* format: style4,delnl,insnl,^ifthendo */ poll_fnp: proc; /* Parameters */ dcl arg_event_call_info_ptr ptr; /* Automatic */ dcl code fixed bin (35); dcl argp ptr; dcl argl fixed bin; dcl log_fnp_entryp ptr; dcl log_fnp_data_n_fnps fixed bin; dcl time_sw bit (1); dcl output_file_sw bit (1); dcl log_sw bit (1); dcl off_sw bit (1); dcl on_sw bit (1); dcl finish_sw bit (1); dcl debug_sw bit (1); dcl fnp_cnt fixed bin; dcl time_int fixed bin; dcl fnp_list (8) char (4); dcl argno fixed bin; dcl n_args fixed bin; dcl more_args bit (1); dcl arg_list_ptr ptr; dcl output_file char (201); dcl log_fnp_datap ptr; dcl (i, j) fixed bin; dcl char8 char (8) aligned; dcl event_message fixed bin (71); dcl fnp_x fixed bin; dcl fnp_name char (4); dcl starname (1) char (32); dcl meter_areap ptr; dcl orig_chan_meterp ptr; dcl meterp ptr; dcl n_channels fixed bin; dcl chanx fixed bin; dcl n_stats fixed bin; /* Constants */ dcl name char (8) int static options (constant) init ("poll_fnp"); /* Static */ dcl static_log_fnp_datap ptr int static init (null); /* Based */ dcl arg char (argl) based (argp); dcl 1 log_fnp_data aligned based (log_fnp_datap), 2 n_fnps fixed bin, /* Number of fnps configured */ 2 overrun_count fixed bin, /* Consecutive polling cycles missed because previous one slow */ 2 timer_event fixed bin (71), /* Event channel for driving polling */ 2 next_cycle_sched fixed bin (71), /* Time of next scheduled run */ 2 interval fixed bin (71), /* Time (in microseconds) between scheduled runs */ 2 iocbp ptr, 2 flags unal, 3 debug bit (1), 3 log bit (1), 3 output_file bit (1), 3 finish bit (1), 3 pad bit (32), 2 attach_desc char (256) varying, 2 fnp_entry (log_fnp_data_n_fnps refer (log_fnp_data.n_fnps)) like log_fnp_entry; dcl 1 log_fnp_entry aligned based (log_fnp_entryp), 2 fnp_name char (4), 2 model fixed bin, 2 times_dumped fixed bin (35), 2 times_failed fixed bin (35), 2 on bit (1); /* External */ dcl config_$find_2 entry (character (4) aligned, character (4) aligned, pointer); dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl get_process_id_ entry () returns (bit (36)); dcl get_system_free_area_ entry (ptr); dcl get_fnp_name_ entry (fixed bin) returns (char (32)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$wakeup entry (bit (*), fixed bin (71), fixed bin (71), fixed bin (35)); dcl ( ioa_, ioa_$nnl ) entry options (variable); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$decl_ev_call_chn entry (fixed bin (71), ptr, ptr, fixed bin, fixed bin (35)); dcl timer_manager_$reset_alarm_wakeup entry (fixed bin (71)); dcl ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); dcl timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl hphcs_$syserr_binary entry options (variable); dcl comm_meters_ entry ((*) char (*), fixed bin, ptr, fixed bin, ptr, fixed bin (35)); dcl comm_meters_$free entry (ptr, ptr, fixed bin (35)); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl error_table_$too_many_args ext fixed bin (35); dcl error_table_$noarg ext fixed bin (35); dcl error_table_$badopt ext fixed bin (35); dcl error_table_$inconsistent ext fixed bin (35); /* Internal static */ dcl SYS_CONTROL_DIR char (17) internal static options (constant) init (">system_control_1"); /* Conditions & builtins */ dcl (cleanup, conversion, sub_error_) condition; dcl (addr, bin, clock, codeptr, currentsize, hbound, index, null, rtrim, sum, unspec) builtin; %page; /* Command entry to setup the command */ call cu_$arg_count (n_args, code); if code ^= 0 then do; call com_err_ (code, name); return; end; call cu_$arg_list_ptr (arg_list_ptr); argno = 1; more_args = (argno <= n_args); time_sw = "0"b; output_file_sw = "0"b; log_sw = "0"b; off_sw = "0"b; on_sw = "0"b; finish_sw = "0"b; debug_sw = "0"b; fnp_cnt = 0; log_fnp_datap = null (); do while (more_args); call get_arg; if index (arg, "-") ^= 1 then do; /* Must be fnp name */ if fnp_cnt >= hbound (fnp_list, 1) then do; call com_err_ (error_table_$too_many_args, name, "More than ^d FNPs listed.", hbound (fnp_list, 1)); go to error_return; end; fnp_cnt = fnp_cnt + 1; fnp_list (fnp_cnt) = arg; end; else if arg = "-time" | arg = "-tm" then do; if ^more_args then do; missing: call com_err_ (error_table_$noarg, name, "After ^a.", arg); go to error_return; end; call get_arg; on conversion go to bad_time; time_int = bin (arg); revert conversion; if time_int <= 0 then do; bad_time: call com_err_ (0, name, "Invalid time specified: ^a", arg); go to error_return; end; time_sw = "1"b; end; else if arg = "-output_file" | arg = "-of" then do; if ^more_args then go to missing; call get_arg; call absolute_pathname_ (arg, output_file, code); if code ^= 0 then do; call com_err_ (code, name, "^a", arg); go to error_return; end; output_file_sw = "1"b; end; else if arg = "-log" then log_sw = "1"b; else if arg = "-stop" | arg = "-sp" then do; off_sw = "1"b; on_sw = "0"b; end; else if arg = "-start" | arg = "-sr" then do; on_sw = "1"b; off_sw = "0"b; end; else if arg = "-finish" then finish_sw = "1"b; else if arg = "-debug" | arg = "-db" then debug_sw = "1"b; else do; call com_err_ (error_table_$badopt, name, "^a", arg); go to error_return; end; end; /* This code handles modifications to running polling */ if static_log_fnp_datap ^= null () then do; log_fnp_datap = static_log_fnp_datap; if log_fnp_data.finish then do; call com_err_ (0, name, "Finish operation in progress. Requests not accepted until it completes."); go to error_return; end; if n_args = 0 then do; /* Some argument required to adjust polling */ call com_err_ (error_table_$noarg, name, "Polling already in progress."); go to error_return; end; if time_sw then log_fnp_data.interval = 60 * 1000000 * time_int; if debug_sw then log_fnp_data.debug = "1"b; if output_file_sw then do; log_fnp_data.attach_desc = "vfile_ " || rtrim (output_file) || " -extend"; log_fnp_data.output_file = "1"b; end; if log_sw then log_fnp_data.log = "1"b; if on_sw | off_sw | (fnp_cnt > 0) then do; if fnp_cnt > 0 then call validate_fnp_list; if ^(on_sw | off_sw) then on_sw = "1"b; do i = 1 to log_fnp_data.n_fnps; log_fnp_entryp = addr (log_fnp_data.fnp_entry (i)); if listed_fnp () then log_fnp_entry.on = on_sw; end; end; if finish_sw then do; call timer_manager_$reset_alarm_wakeup (log_fnp_data.timer_event); call ipc_$drain_chn (log_fnp_data.timer_event, code); char8 = "finish"; unspec (event_message) = unspec (char8); call hcs_$wakeup (get_process_id_ (), log_fnp_data.timer_event, event_message, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to send finish wakeup."); end; log_fnp_data.finish = "1"b; end; go to done; end; /* This code handles starting polling for the first time */ if on_sw | off_sw | finish_sw then do; call com_err_ (error_table_$inconsistent, name, "Args -on, -off, -finish not permitted before polling started."); go to error_return; end; if ^(log_sw | output_file_sw) then log_sw = "1"b; on cleanup call command_cleanup; call setup_static_data; log_fnp_data.iocbp = null (); log_fnp_data.debug = debug_sw; if fnp_cnt > 0 then call validate_fnp_list; do i = 1 to log_fnp_data.n_fnps; log_fnp_entryp = addr (log_fnp_data.fnp_entry (i)); if listed_fnp () then log_fnp_entry.on = "1"b; end; log_fnp_data.log = log_sw; if output_file_sw then do; log_fnp_data.attach_desc = "vfile_ " || rtrim (output_file) || " -extend"; log_fnp_data.output_file = "1"b; end; if ^time_sw then time_int = 15; log_fnp_data.interval = time_int * 60 * 1000000; call ipc_$create_ev_chn (log_fnp_data.timer_event, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to create event channel."); go to error_return; end; call ipc_$decl_ev_call_chn (log_fnp_data.timer_event, codeptr (timer_wakeup), log_fnp_datap, 30, code); /* Priority = 30 appropriate in Initializer */ if code ^= 0 then do; call com_err_ (code, name, "Unable to setup event call channel."); go to error_return; end; char8 = "start"; unspec (event_message) = unspec (char8); log_fnp_data.next_cycle_sched = clock (); call hcs_$wakeup (get_process_id_ (), log_fnp_data.timer_event, event_message, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to send first wakeup."); go to error_return; end; static_log_fnp_datap = log_fnp_datap; done: return; error_return: call command_cleanup; return; %page; /* Timer wakeup to start polling operation */ timer_wakeup: entry (arg_event_call_info_ptr); event_call_info_ptr = arg_event_call_info_ptr; log_fnp_datap = event_call_info.data_ptr; if log_fnp_datap ^= static_log_fnp_datap then return; /* Spurious */ if event_call_info.channel_id ^= log_fnp_data.timer_event then return; /* Likewise */ unspec (char8) = unspec (event_call_info.message); if log_fnp_data.debug then do; call ioa_$nnl ("Timer wakeup: ^a. Processing:", char8); do i = 1 to log_fnp_data.n_fnps; log_fnp_entryp = addr (log_fnp_data.fnp_entry (i)); if log_fnp_entry.on then call ioa_$nnl (" ^a", log_fnp_entry.fnp_name); end; call ioa_ (""); end; if ^log_fnp_data.finish then do; log_fnp_data.next_cycle_sched = log_fnp_data.next_cycle_sched + log_fnp_data.interval; if log_fnp_data.next_cycle_sched <= clock () then do; call com_err_ (0, name, "Polling overrun. Previous cycle still in progress."); log_fnp_data.overrun_count = log_fnp_data.overrun_count + 1; if log_fnp_data.overrun_count >= 3 then do; log_fnp_data.finish = "1"b; call com_err_ (0, name, "Polling abandoned. Too many polling overruns occured."); end; else do while (log_fnp_data.next_cycle_sched <= clock ()); log_fnp_data.next_cycle_sched = log_fnp_data.next_cycle_sched + log_fnp_data.interval; end; end; else log_fnp_data.overrun_count = 0; /* Keeping up ok */ if ^log_fnp_data.finish then call timer_manager_$alarm_wakeup (log_fnp_data.next_cycle_sched, "00"b, log_fnp_data.timer_event); end; /* Attach output file if specified */ if log_fnp_data.output_file then do; call iox_$attach_name ("poll_fnp", log_fnp_data.iocbp, (log_fnp_data.attach_desc), null (), code); if code ^= 0 then do; call com_err_ (code, name, "Unable to attach output file."); log_fnp_data.iocbp = null (); go to wrapup; end; call iox_$open (log_fnp_data.iocbp, Stream_output, "0"b, code); if code ^= 0 then do; call com_err_ (code, name, "Unable to open output file."); call iox_$detach_iocb (log_fnp_data.iocbp, code); log_fnp_data.iocbp = null (); end; end; on sub_error_ begin; dcl code fixed bin (35); dcl pass_on bit (1); dcl 1 auto_cond_info aligned like condition_info; pass_on = "0"b; condition_info_ptr = addr (auto_cond_info); call find_condition_info_ (null (), condition_info_ptr, code); if code ^= 0 /* rather unlikely */ then pass_on = "1"b; /* but we'll let someone else worry about it */ else if condition_info.info_ptr = null () | condition_info.condition_name ^= "sub_error_" /* we're not about to deal with this */ then pass_on = "1"b; else do; sub_error_info_ptr = condition_info.info_ptr; if sub_error_info.name ^= "comm_meters_" /* not someone we know */ then pass_on = "1"b; end; if pass_on then call continue_to_signal_ (code); end; call get_system_free_area_ (meter_areap); do fnp_x = 1 to log_fnp_data.n_fnps; log_fnp_entryp = addr (log_fnp_data.fnp_entry (fnp_x)); if log_fnp_entry.on then do; fnp_name = log_fnp_entry.fnp_name; starname (1) = rtrim (fnp_name) || ".*";/* all immediate subchannels of this FNP */ log_fnp_entry.times_dumped = log_fnp_entry.times_dumped + 1; call comm_meters_ (starname, CHANNEL_METERS_VERSION_1, meter_areap, n_channels, orig_chan_meterp, code); if code ^= 0 then do; log_fnp_entry.times_failed = log_fnp_entry.times_failed + 1; call com_err_ (code, name, "Unable to get statistics for FNP ^a", fnp_name); go to next_fnp; end; chan_meterp = orig_chan_meterp; poll_fnp_data_n_channels = n_channels; poll_fnp_data_n_stats = 9 * n_channels; /* we'll allocate space for all of them and fre unneeded ones later */ allocate poll_fnp_data; chanx = 0; n_stats = 0; poll_fnp_data.version = poll_fnp_data_version_1; poll_fnp_data.name = log_fnp_entry.fnp_name; poll_fnp_data.model = log_fnp_entry.model; do while (chan_meterp ^= null ()); fnp_chan_meterp = channel_meters.parent_meterp; meterp = addr (fnp_chan_meter_struc.current_meters); if meterp -> fnp_channel_meters.parity_errors ^= 0 | fnp_chan_meter_struc.synchronous & sum (meterp -> fnp_sync_meters.counters) ^= 0 then do; chanx = chanx + 1; poll_fnp_data.chan_info (chanx).chan_name = channel_meters.channel_name; poll_fnp_data.chan_info (chanx).line_type = channel_meters.line_type; if fnp_chan_meter_struc.synchronous then do i = 1 to hbound (meterp -> fnp_sync_meters.counters, 1); if meterp -> fnp_sync_meters.counters (i) > 0 then do; n_stats = n_stats + 1; poll_fnp_data.stat_info (n_stats).chan_index = chanx; poll_fnp_data.stat_info (n_stats).stat_index = i; poll_fnp_data.stat_info (n_stats).value = meterp -> fnp_sync_meters.counters (i); end; end; if meterp -> fnp_channel_meters.parity_errors > 0 then do; n_stats = n_stats + 1; poll_fnp_data.stat_info (n_stats).chan_index = chanx; poll_fnp_data.stat_info (n_stats).stat_index = 9; poll_fnp_data.stat_info (n_stats).value = meterp -> fnp_channel_meters.parity_errors; end; end; chan_meterp = channel_meters.next_channelp; end; poll_fnp_data.n_stats = n_stats; poll_fnp_data.n_channels = n_channels; if log_fnp_data.log then call hphcs_$syserr_binary (5, poll_fnp_datap, SB_fnp_poll, currentsize (poll_fnp_data), "poll_fnp: polled ^a", log_fnp_entry.fnp_name); else if log_fnp_data.iocbp ^= null () then call iox_$put_chars (log_fnp_data.iocbp, poll_fnp_datap, 4 * currentsize (poll_fnp_data), code); poll_fnp_data.n_stats = poll_fnp_data_n_stats; free poll_fnp_data; call comm_meters_$free (meter_areap, orig_chan_meterp, code); end; next_fnp: end; /* Finished with this cycle */ wrapup: if log_fnp_data.iocbp ^= null () then do; call iox_$close (log_fnp_data.iocbp, code); call iox_$detach_iocb (log_fnp_data.iocbp, code); log_fnp_data.iocbp = null (); end; if log_fnp_data.finish then do; /* This is last cycle */ call ioa_ ("^a: Finished.", name); call ipc_$delete_ev_chn (log_fnp_data.timer_event, code); static_log_fnp_datap = null (); log_fnp_data_n_fnps = log_fnp_data.n_fnps; free log_fnp_data; end; return; %page; get_arg: proc; call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr); if code ^= 0 then do; call com_err_ (code, name, "Can't happen."); go to error_return; end; argno = argno + 1; more_args = (argno <= n_args); return; put_arg: entry; argno = argno - 1; more_args = (argno <= n_args); return; end get_arg; %page; /* Routine to setup static data-base */ setup_static_data: proc; dcl i fixed bin; dcl fnpx fixed bin; /* First, count fnp's */ log_fnp_data_n_fnps = 0; do i = 1 to 8; prph_fnp_cardp = null (); call config_$find_2 ("prph", "fnp" || get_fnp_name_ (i), prph_fnp_cardp); log_fnp_data_n_fnps = log_fnp_data_n_fnps + bin (prph_fnp_cardp ^= null (), 1); end; if log_fnp_data_n_fnps = 0 then do; call com_err_ (0, name, "No FNPs configured. Polling not initiated."); go to error_return; end; allocate log_fnp_data; unspec (log_fnp_data) = ""b; log_fnp_data.n_fnps = log_fnp_data_n_fnps; call hcs_$initiate (SYS_CONTROL_DIR, "cdt", "", 0, 1, cdtp, code); if cdtp = null () then call com_err_ (code, name, "Could not initiate CDT. Models of FNPs will not be recorded."); prph_fnp_cardp = null (); fnpx = 1; do i = 1 to 8; /* loop through all the possibilities */ prph_fnp_cardp = null (); call config_$find_2 ("prph", "fnp" || get_fnp_name_ (i), prph_fnp_cardp); if prph_fnp_cardp ^= null () then do; log_fnp_entryp = addr (log_fnp_data.fnp_entry (fnpx)); log_fnp_entry.fnp_name = get_fnp_name_ (i); if cdtp ^= null () then do; fnpep = addr (cdt.fnp_entry (fnpx)); if fnpe.mpxe.state ^= FNP_FREE then log_fnp_entry.model = fnpe.type; end; fnpx = fnpx + 1; end; end; return; end setup_static_data; %page; /* Be sure all fnp's given on comnmand line are configured. */ validate_fnp_list: proc; dcl (i, j) fixed bin; do i = 1 to fnp_cnt; do j = 1 to log_fnp_data.n_fnps; log_fnp_entryp = addr (log_fnp_data.fnp_entry (j)); if fnp_list (i) = log_fnp_entry.fnp_name then go to fnp_ok; end; call com_err_ (0, name, "FNP ^a is not configured.", fnp_list (i)); go to error_return; fnp_ok: end; return; end validate_fnp_list; /* Function to return 1 if fnp was listed in command line. If none were listed, 1 is returned for all fnp's */ listed_fnp: proc returns (bit (1)); dcl i fixed bin; if fnp_cnt = 0 then return ("1"b); do i = 1 to fnp_cnt; if log_fnp_entry.fnp_name = fnp_list (i) then return ("1"b); end; return ("0"b); end listed_fnp; /* Cleanup handler for command interface */ command_cleanup: proc; if static_log_fnp_datap = null () & log_fnp_datap ^= null () then free log_fnp_data; return; end command_cleanup; %page; %include event_call_info; %include iox_modes; %include poll_fnp_data; %include syserr_binary_def; %include config_prph_fnp_card; %include channel_meters; %include fnp_channel_meters; %include cdt; %include author_dcl; %include condition_info; %include condition_info_header; %include sub_error_info; end poll_fnp;  test_fnp.pl1 07/20/88 1258.3r w 07/19/88 1537.0 225819 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ test_fnp: proc options (variable); /* test_fnp - T & D that runs the offline FNP T & D tests (tst3bt) on an FNP that is offline (not known to the answering service). The tests that are run on the fnp, are located in the general T & D repository >system_library_tandd>tandd_deck_file. They are put there by the load_tandd_library command using a "-fnp_tape" control argument when loading an FNP Binary Deck Tape (this tape is available from you're friendly FER). The documentation for the tests that are run on the FNP, can be found in "T & D Microfiche Documentation" box (also available from you're friendly FER) in the front of the program listing. Originally written by B. S. Greenberg 1/80 Modified by J. A. Bush 8/81 for release with MR9.0 */ dcl program_interrupt condition; dcl tandd_$fnp_tandd_setup entry (fixed bin, fixed bin (71), fixed bin (35)); dcl tandd_$fnp_tandd_detach entry (fixed bin, fixed bin (35)); dcl tandd_$fnp_tandd_mask entry (fixed bin, fixed bin (35)); dcl tandd_$fnp_tandd_send_int entry (fixed bin, fixed bin (3), fixed bin (35)); dcl tandd_$fnp_tandd_get_ints entry (fixed bin, bit (2) aligned, fixed bin (35)); dcl (tandd_$fnp_tandd_read, tandd_$fnp_tandd_write) entry (fixed bin, ptr, fixed bin (18), fixed bin (15), fixed bin, fixed bin (35)); dcl timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)); dcl ask_$ask_clr entry; dcl ask_ entry options (variable); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl com_err_ entry options (variable); dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl tolts_util_$search entry (ptr, char (32), ptr, fixed bin, fixed bin (35)); dcl tolts_util_$bci_to_ascii entry (bit (*), char (*) varying, fixed bin); dcl tolts_alm_util_$ascii_to_bci_ entry (char (*), bit (*)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (5), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl hcs_$wakeup entry (bit (*), fixed bin (71), fixed bin (71), fixed bin (35)); dcl get_process_id_ entry () returns (bit (36)); dcl get_temp_segment_ entry (char (*), pointer, fixed bin (35)); dcl release_temp_segment_ entry (char (*), pointer, fixed bin (35)); /* AUTOMATIC */ dcl (allow_pi, piflag) bit (1); dcl ask_ans char (32); dcl ascvar char (200) varying; dcl damage_85_86_flag bit (1); dcl save_pgmname char (6); dcl (printer_switch, message_switch, input_switch) ptr; dcl rx fixed bin init (1); dcl (exec_in_fnp, loader_loaded) bit (1); dcl (loadsegptr, moduleptr) ptr; dcl modullen fixed bin (15); dcl deck_iocbp ptr init (null); dcl module_listp ptr; dcl cata_key char (32); dcl bcdbuf bit (6*6*64) unaligned; dcl chars_gotten fixed bin (21); dcl ascbuf char (200); dcl argno fixed bin; dcl arglen fixed bin; dcl code fixed bin (35); dcl fnp_no fixed bin; dcl fnp_type_str char (4); dcl fnp_type fixed bin; dcl argp ptr; dcl execname char (6); dcl temp_ptr ptr; dcl temp_arg char (32); dcl fnp_tag char (1); /* CONSTANT */ dcl myname char (32) options (constant) static init ("test_fnp"); dcl fnp_interrupt_vector_word bit (36) static options (constant) init ("000334000777"b3); dcl bcd_dkend bit (72) int static options (constant) init ("532020202020202442254524"b3); /* "$ dkend" in bcd */ dcl NL char (1) int static options (constant) init (" "); /* BASED */ dcl arg char (arglen) based (argp); dcl bcd_array (0 : 6*64 - 1) bit (6) unaligned based (addr (bcdbuf)); dcl three_words bit (36) aligned dim (3) based; /* EXTERNAL STATIC */ dcl error_table_$timeout fixed bin (35) ext static; dcl error_table_$moderr fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$too_many_args fixed bin (35) ext static; dcl (iox_$user_output, iox_$user_input) ptr external static; /* STRUCTURES */ dcl 1 idb, 2 pad1 bit (21) unaligned, 2 fnp_address fixed bin (15) unsigned unaligned, 2 tally fixed bin (18) unsigned unaligned, 2 pad2 bit (15) unaligned, 2 request_code fixed bin (3) unsigned unaligned; dcl 1 module_list aligned based (module_listp), 2 n fixed bin, 2 name (0 refer (module_list.n)) char (24) unal; dcl wait_list (10) fixed bin; /* BUILTIN */ dcl (addr, addrel, before, bin, bit, currentsize, clock, divide, fixed, index, length, ltrim, min, mod, null, ptr, reverse, rtrim, substr, unspec) builtin; dcl (linkage_error, cleanup, finish) condition; %page; input_switch, message_switch, printer_switch = null (); fnp_no = -1; execname = "bos"; do argno = 1 by 1; call cu_$arg_ptr (argno, argp, arglen, code); if code ^= 0 then go to end_arg_processing; if substr (arg, 1, 1) ^= "-" then do; if fnp_no ^= -1 then do; call com_err_ (error_table_$too_many_args, myname, "FNP tag multiply specified"); return; end; fnp_no = index ("abcdefghABCDEFGH", arg); if length (arg) = 1 & fnp_no ^= 0 then do; if fnp_no > 8 then fnp_no = fnp_no - 8; fnp_tag = substr ("ABCDEFGH", fnp_no); end; else do; call com_err_ (error_table_$bad_arg, myname, "Bad FNP tag: ^a.", arg); return; end; end; else if arg = "-exec" then do; argno = argno + 1; call cu_$arg_ptr (argno, argp, arglen, code); if code ^= 0 then do; call com_err_ (code, myname, "Exec name (ios or bos) missing."); return; end; if arg = "bos" then execname = "bos"; else if arg = "BOS" then execname = "bos"; else if arg = "ios" then execname = "ios"; else if arg = "IOS" then execname = "ios"; else do; call com_err_ (error_table_$bad_arg, myname, "Bad exec name. Must be IOS or BOS."); return; end; end; else if arg = "-osw" | arg = "-output_switch" | arg = "-msw" | arg = "-message_switch" | arg = "-isw" | arg = "-input_switch" then do; temp_arg = arg; argno = argno + 1; call cu_$arg_ptr (argno, argp, arglen, code); if code ^= 0 then do; call com_err_ (code, myname, "Missing switch name after ^a.", temp_arg); return; end; call iox_$look_iocb (arg, temp_ptr, code); if code ^= 0 then do; call com_err_ (code, myname, "^a", arg); return; end; if temp_arg = "-msw" | temp_arg = "-message_switch" then message_switch = temp_ptr; else if temp_arg = "-isw" | temp_arg = "-input_switch" then input_switch = temp_ptr; else if temp_arg = "-osw" | temp_arg = "-output_switch" then printer_switch = temp_ptr; end; else do; call com_err_ (error_table_$badopt, myname, "^a", arg); return; end; end; end_arg_processing: if fnp_no = -1 then do; call com_err_ (error_table_$noarg, myname, "A FNP tag must be provided."); return; end; if message_switch = null then message_switch = iox_$user_output; if printer_switch = null then printer_switch = iox_$user_output; if input_switch = null then input_switch = iox_$user_input; event_wait_list_n_channels = 1; event_wait_list_ptr = addr (wait_list); event_wait_list.channel_id (1) = 0; event_wait_list.n_channels = 1; loadsegptr = null; on cleanup call clean_up; on finish call clean_up; call ipc_$create_ev_chn (event_wait_list.channel_id (1), code); if code ^= 0 then do; call com_err_ (0, myname, "Could not create IPC channel"); return; end; call get_temp_segment_ (myname, loadsegptr, code); if code ^= 0 then do; call com_err_ (code, myname, "Getting FNP core load segment."); call clean_up; return; end; call hcs_$initiate (">system_control_1", "cdt", "", 0b, 0, cdtp, code); if cdtp ^= null then do; /* if user has access to the cdt */ fnpep = addr (cdt.fnp_entry (fnp_no)); /* get ptr to fnp entry */ fnp_type = fnpe.type; fnp_type_str = substr (fnp_types (fnp_type), 3); if fnp_type_str = "355" then fnp_type_str = "6600"; /* these are the same */ end; else do; /* user does not have access to cdt, we must ask him what kind of FNP he is trying to test */ call ask_$ask_clr; call com_err_ (0, myname, "What is the FNP type of FNP ^a?", fnp_tag); ask_ans = ""; do while (ask_ans = ""); call ask_ ("Answer DN6600, DN6670, DN355, or quit. ", ask_ans); if ask_ans = "quit" then do; /* user wants to forget it all */ call clean_up; return; end; ask_ans = substr (ask_ans, 3); /* forget about case of prefix, don't care */ if ask_ans = "355" then do; fnp_type_str = "6600"; fnp_type = DN355; end; else if ask_ans = "6600" then do; fnp_type_str = "6600"; fnp_type = DN6600; end; else if ask_ans = "6670" then do; fnp_type_str = "6670"; fnp_type = DN6670; end; else ask_ans = ""; end; end; /* Now find the fnp test catalog record in the tandd_deck_file */ cata_key = "cata.fnp.pol." || fnp_type_str; call tolts_util_$search (deck_iocbp, cata_key, module_listp, (0), code); if code ^= 0 then do; call com_err_ (code, myname, "Unable to find catalog for ^a. Deckfile may be damaged.", cata_key); call clean_up; return; end; on linkage_error begin; call com_err_ (error_table_$moderr, myname, "Access to the gate >sl1>tandd_ is required to use this program."); call clean_up; go to nlret; end; call tandd_$fnp_tandd_setup (fnp_no, event_wait_list.channel_id (1), code); revert linkage_error; if code ^= 0 then do; call com_err_ (code, myname, "Setting up T & D on FNP ^a.", fnp_tag); call clean_up; return; end; %page; /* Start the actual testing */ damage_85_86_flag = "0"b; call tandd_$fnp_tandd_mask (fnp_no, code); if code ^= 0 then do; call com_err_ (code, myname, "Issuing mask PCW to FNP ^a DIA.", fnp_tag); call clean_up; return; end; call find_and_send_required_module ("Interrupt and fault vectors", "95", "00000"b3); call find_and_send_required_module ("Primitive function test 1", "96", "04000"b3); call exchange_terminate_interrupts (code); if code ^= 0 then call perm_fail ("Cannot start primitive function test 1"); call find_and_send_required_module ("Primitive function test 2", "97", "01000"b3); call exchange_terminate_interrupts (code); if code ^= 0 then call perm_fail ("Cannot start primitive function test 2"); ldrs: exec_in_fnp = "0"b; call load_fnp_interrupt_vectors; call load_required_module ("I/O package", "99"); if execname = "bos" then call load_required_module ("FNP BOS", "20"); else call load_required_module ("FNP IOS", "io"); /* Wait for FNP to request service */ allow_pi = "0"b; on program_interrupt begin; piflag = "1"b; if allow_pi then call hcs_$wakeup (get_process_id_ (), event_wait_list.channel_id (1), 0, (0)); end; fnp_service_loop: exec_in_fnp = "1"b; /* Says where to shove card buffers */ allow_pi = "0"b; /* No PI's yet */ call wait (7, 0, (0)); /* Wait for a level 7 */ call read_idb; /* See what he wants */ if idb.request_code = 1 | idb.request_code = 3 then do; /* Write */ bcd_array (*) = "17"b3; /* Ignore */ call read_fnp ((idb.fnp_address), (idb.tally), addr (bcd_array)); /* Read message */ call tolts_util_$bci_to_ascii (bcdbuf, ascvar, idb.tally * 3); if idb.request_code = 1 then temp_ptr = message_switch; else do; temp_ptr = printer_switch; ascvar = ascvar || NL; end; call iox_$put_chars (temp_ptr, addrel (addr (ascvar), 1), length (ascvar), code); if code ^= 0 then do; call com_err_ (code, myname, "Could not output msg to ^[message^;printer^] switch", idb.request_code = 1); end; call tandd_$fnp_tandd_send_int (fnp_no, 3, code); if code ^= 0 then call com_err_ (code, myname, "Attempting to send level 3 after console/printer write."); end; else if idb.request_code = 2 then do; /* Console read */ call iox_$get_line (input_switch, addr (ascbuf), length (ascbuf), chars_gotten, code); if code ^= 0 then do; call com_err_ (code, myname, "Error reading input switch."); go to fnp_service_loop; end; if chars_gotten > 0 then if substr (ascbuf, chars_gotten, 1) = NL then chars_gotten = chars_gotten - 1; ascvar = ltrim (substr (ascbuf, 1, chars_gotten)); if rtrim (ascvar) = "QUIT" | rtrim (ascvar) = "quit" then call perm_fail ("Program aborted by user."); call tolts_alm_util_$ascii_to_bci_ ((ascvar), bcdbuf); if mod (idb.tally, 2) = 1 then substr (bcdbuf, 1 + 18 * idb.tally, 18) = "171717"b3; call write_fnp ((idb.fnp_address), (idb.tally), addr (bcdbuf)); call tandd_$fnp_tandd_send_int (fnp_no, 3, code); if code ^= 0 then call com_err_ (code, myname, "Attempting to send level 3 after console read"); end; else if idb.request_code = 4 then do; /* Load pgm */ substr (bcdbuf, 1, 18) = bit (fixed (idb.tally, 18), 18); call tolts_util_$bci_to_ascii (substr (bcdbuf, 1, 12), ascvar, 2); if ascvar = "00" then ascvar = next_program (); if ascvar = "io" then do; execname = "ios"; go to ldrs; end; else if ascvar = "20" then do; execname = "bos"; go to ldrs; end; if ascvar = "85" | ascvar = "86" then do; save_pgmname = ascvar; exec_in_fnp = "0"b; call load_fnp_interrupt_vectors; damage_85_86_flag = "1"b; ascvar = rtrim (save_pgmname); end; call load_program ((ascvar), code); if code ^= 0 then call com_err_ (code, myname, "Error loading ^a", ascvar); end; else call com_err_ (0, myname, "Unrecognized idb request code: ^d.^/IDB: ^w ^w ^w", idb.request_code, addr (idb) -> three_words); go to fnp_service_loop; pi_person: allow_pi = "0"b; if damage_85_86_flag then do; call ask_$ask_clr; call com_err_ (0, myname, "Exec has been destroyed."); ask_ans = ""; do while (ask_ans = ""); call ask_ ("Which exec (IOS or BOS) do you want? ", ask_ans); if ask_ans = "QUIT" | ask_ans = "quit" then call perm_fail ("Program aborted by user."); else if ask_ans = "IOS" then ask_ans = "ios"; else if ask_ans = "BOS" then ask_ans = "bos"; else ask_ans = ""; end; execname = ask_ans; damage_85_86_flag = "0"b; go to ldrs; end; call tandd_$fnp_tandd_send_int (fnp_no, 7, code); if code ^= 0 then call com_err_ (code, myname, "Attempting to send level 7 for request."); go to fnp_service_loop; nlret: return; /* taget of non-local gotos */ %page; /* Necessary subroutines that do all the work */ find_and_send_required_module: proc (a_description, a_testid, a_fnp_address); dcl a_description char (*); dcl a_testid char (2); dcl a_fnp_address bit (15); dcl moduleptr ptr; dcl modullen fixed bin (15); call get_and_load_module (a_testid, moduleptr, modullen, code); if code ^= 0 then do; call com_err_ (code, myname, "Cannot locate or load ^a", a_description); call perm_fail ("Cannot send " || a_description); end; call write_fnp (fixed (a_fnp_address, 15), modullen, moduleptr); end find_and_send_required_module; /* Send a level 3 to the FNP, and wait for one back. */ exchange_terminate_interrupts: proc (a_code); dcl a_code fixed bin (35); call tandd_$fnp_tandd_send_int (fnp_no, 3, a_code); if a_code ^= 0 then call com_err_ (a_code, myname, "Could not send level 3 to FNP ^a.", fnp_tag); else call wait (3, 5, a_code); end exchange_terminate_interrupts; /* Load FNP Interrupt vectors and loader */ load_fnp_interrupt_vectors: proc; call write_fnp (bin ("62"b3, 15), 1, addr (fnp_interrupt_vector_word)); loader_loaded = "0"b; call get_and_load_module ("98", moduleptr, modullen, code); /* Get loader */ if code ^= 0 then do; call com_err_ (code, myname, "Cannot get module 98 (FNP loader)"); call perm_fail (""); end; call write_fnp (bin ("01000"b3, 15), modullen, moduleptr); call tandd_$fnp_tandd_send_int (fnp_no, 3, code); if code ^= 0 then call perm_fail ("Could not send interrupt after loading interrupt vectors"); loader_loaded = "1"b; end load_fnp_interrupt_vectors; load_required_module: proc (exp, a_progname); dcl exp char (*), a_progname char (2); call load_program (a_progname, code); if code ^= 0 then do; call com_err_ (code, myname, "Cannot load ^a (^a), aborting", exp, a_progname); go to nlret; end; end load_required_module; %page; load_program: proc (a_progname, a_code); dcl count fixed bin (15); dcl a_code fixed bin (35); dcl a_progname char (2); dcl fnp_address fixed bin (15); dcl deck_ptr ptr; dcl nextc fixed bin, nextcx fixed bin; call get_deck_ptr (a_progname, deck_ptr, a_code); if a_code ^= 0 then return; call core_load (deck_ptr, nextc, "1"b); /* put deck +rcws in buffer */ if exec_in_fnp then fnp_address = idb.fnp_address; else fnp_address = bin ("01500"b3, 15); do nextcx = 0 to nextc - 1 by 308; count = min (308, nextc - nextcx); call write_fnp (fnp_address, 2*count, ptr (loadsegptr, nextcx)); call exchange_terminate_interrupts (a_code); if a_code ^= 0 then do; call com_err_ (a_code, myname, "FNP loader missed interrupt for ^a; aborting load.", a_progname); return; end; end; a_code = 0; return; end load_program; %page; core_load: proc (a_deck_ptr, a_len, rcw_sw); dcl a_deck_ptr ptr; dcl (a_len, nwds, ccl) fixed bin; dcl (eof, rcw_sw) bit (1); dcl cc (ccl) bit (36) aligned based; call hcs_$truncate_seg (loadsegptr, 0, (0)); a_len = 0; eof = "0"b; prptr = a_deck_ptr; /* iterate through entire a_deck */ do while (^eof); /* and copy bin card images into temp seg */ lrptr = addr (gc_phy_rec.gc_phy_rec_data (1)); /* get pointer to first logical record */ nwds = 0; do while (nwds < bcw.blk_size & ^eof); /* iterate through all logical records */ if rcw.media_code = 2 then /* bcd card image */ if substr (gc_log_rec_bits, 1, 72) = bcd_dkend then /* dkend card */ eof = "1"b; /* thats it folks */ else; else if rcw.media_code = 1 then do; /* binary card image */ if rcw_sw then do; /* if copying entire log rec.. */ ccl = rcw.rsize + 1; /* add in rcw also */ ptr (loadsegptr, a_len) -> cc = lrptr -> cc; /* copy bin card image */ a_len = a_len + ccl; end; else if gc_log_rec_data (1) ^= "000500000000"b3 then do; /* unless xfer card, copy core image */ ccl = rcw.rsize - 1; /* don't want sequence number */ ptr (loadsegptr, a_len) -> cc = addr (gc_log_rec_data) -> cc; a_len = a_len + ccl; end; end; nwds = nwds + rcw.rsize + 1; /* increment number of words */ lrptr = addrel (lrptr, currentsize (gc_log_rec)); /* set next logical record */ end; prptr = addrel (prptr, currentsize (gc_phy_rec)); /* append next block */ end; if ^rcw_sw then a_len = a_len * 2; /* if core image only... */ end core_load; %page; read_fnp: proc (a_fnpaddr, a_fnpcount, a_dataptr); dcl a_fnpaddr fixed bin (15); dcl a_fnpcount fixed bin (15); dcl a_dataptr ptr; dcl probe entry; if a_fnpcount > divide (length (unspec (bcdbuf)), 18, 18, 0) then do; call com_err_ (0, myname, "Garbage fnp read count: ^d: calling probe.", a_fnpcount); call probe; return; end; call tandd_$fnp_tandd_read (fnp_no, a_dataptr, divide (1+ a_fnpcount, 2, 17, 0), a_fnpaddr, fnp_type, code); if code ^= 0 then do; call com_err_ (code, myname, "Cannot read FNP ^a loc. ^o", fnp_tag, a_fnpaddr); call perm_fail (""); end; end read_fnp; write_fnp: proc (a_fnpaddr, a_fnpcount, a_dataptr); dcl a_fnpaddr fixed bin (15); dcl a_fnpcount fixed bin (15); dcl a_dataptr ptr; call tandd_$fnp_tandd_write (fnp_no, a_dataptr, divide (1+ a_fnpcount, 2, 17, 0), a_fnpaddr, fnp_type, code); if code ^= 0 then do; call com_err_ (code, myname, "Cannot write FNP ^a loc. ^o", fnp_tag, a_fnpaddr); call perm_fail (""); end; end write_fnp; read_idb: proc (); call read_fnp (bin ("04004"b3, 15), 4, addr (idb)); end read_idb; %page; wait: proc (ilevel, interval, a_code); dcl ilevel fixed bin, interval fixed bin, a_code fixed bin (35); dcl crap (8) fixed bin; dcl start fixed bin (71); dcl (l3_happened, l7_happened) bit (1); call get_int_status; if a_code ^= 0 then return; allow_pi = "1"b; piflag = "0"b; do while (^(needed_int () | piflag)); start = clock (); if interval ^= 0 then call timer_manager_$alarm_wakeup ((interval), "11"b, event_wait_list.channel_id (1)); call ipc_$block (addr (event_wait_list), addr (crap), a_code); if a_code ^= 0 then return; call get_int_status; if a_code ^= 0 then return; if interval ^= 0 & ^piflag & ^needed_int () & (clock () - start) > 1000000 * interval then do; a_code = error_table_$timeout; return; end; if piflag then go to pi_person; end; allow_pi = "0"b; a_code = 0; return; get_int_status: proc; dcl temp_ints bit (2) aligned; call tandd_$fnp_tandd_get_ints (fnp_no, temp_ints, a_code); if a_code ^= 0 then return; l3_happened = substr (temp_ints, 1, 1); l7_happened = substr (temp_ints, 2, 1); end get_int_status; needed_int: proc returns (bit (1) aligned); return ((l3_happened & (ilevel = 3)) | (l7_happened & (ilevel = 7))); end needed_int; end wait; %page; get_and_load_module: proc (a_modulename, a_moduleptr, a_modullen, a_code); dcl a_modulename char (2); dcl a_moduleptr ptr; dcl a_modullen fixed bin (15); dcl modullen fixed bin; dcl a_code fixed bin (35); dcl deck_ptr ptr; call get_deck_ptr (a_modulename, deck_ptr, a_code); if a_code ^= 0 then return; call core_load (deck_ptr, modullen, "0"b); /* go core load module */ a_moduleptr = loadsegptr; a_modullen = modullen; end get_and_load_module; next_program: proc returns (char (2)); rx = rx + 1; /* increment roving index */ return (substr (reverse (before (reverse (module_list.name (rx)), ".")), 1, 2)); end next_program; get_deck_ptr: proc (a_modulename, a_deckptr, a_code); dcl a_modulename char (*); dcl a_deckptr ptr; dcl a_code fixed bin (35); dcl (i, j) fixed bin; if rx = module_list.n then /* if we are at the top */ j = 1; else j = rx; /* start from rx and go forward */ retry_search: do i = j to module_list.n; /* go through entire catalog */ if a_modulename = substr (reverse (before (reverse (module_list.name (i)), ".")), 1, 2) then do; rx = i; /* set roving index */ call tolts_util_$search (deck_iocbp, (module_list.name (i)), a_deckptr, (0), a_code); return; /* we found it return */ end; end; if rx < module_list.n & rx ^= 1 then do; /* if we started in middle, try again */ rx, j = 1; go to retry_search; end; a_code = error_table_$noentry; /* we didn't find it */ a_deckptr = null; /* return null ptr */ end get_deck_ptr; %page; clean_up: proc; on linkage_error go to cleanup_ret; call tandd_$fnp_tandd_detach (fnp_no, (0)); revert linkage_error; cleanup_ret: if loadsegptr ^= null then call release_temp_segment_ (myname, loadsegptr, (0)); if event_wait_list.channel_id (1) ^= 0 then call ipc_$delete_ev_chn (event_wait_list.channel_id (1), (0)); if deck_iocbp ^= null then do; /* if we have opened deckfile... */ call iox_$close (deck_iocbp, (0)); /* close and detach it */ call iox_$detach_iocb (deck_iocbp, (0)); deck_iocbp = null; end; end clean_up; perm_fail: proc (excuse); dcl excuse char (*); call com_err_ (0, myname, "^a", excuse); call clean_up; go to nlret; end perm_fail; %page; %include cdt; %include author_dcl; %include event_wait_list; %include event_wait_info; %include gcos_ssf_records; end test_fnp;  trace_mcs.pl1 01/02/85 2134.6r w 01/02/85 1519.1 254574 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ trace_mcs: mcm_trace: procedure () options (variable); /* MCS Tracing command procedure: */ /* This procedure is used to control MCS tracing, and print the results */ /* Derived from an earlier version by C. Hornig */ /* Completely rewritten 10 March 82, W. Olin Sibert Modified: 1984-09-19 to stop using decimal_date_time...JAFalksen Modified: October 1984 by Greg Texada to change the calling sequence for copy_erf_seg_. */ declare arg_count fixed bin; declare arg_index fixed bin; declare arg_lth fixed bin (21); declare arg_ptr pointer; declare arg char (arg_lth) based (arg_ptr); declare code fixed bin (35); declare operation char (32) varying; declare brief_sw bit (1) aligned; declare reset_sw bit (1) aligned; declare all_sw bit (1) aligned; declare reverse_sw bit (1) aligned; declare on_sw bit (1) aligned; declare off_sw bit (1) aligned; declare force_sw bit (1) aligned; declare print_sw bit (1) aligned; declare last_count fixed bin; declare table_size fixed bin; declare new_modes char (120); declare erf_name char (32); declare n_excludes fixed bin; declare exclude (20) char (40) varying; declare n_matches fixed bin; declare match (20) char (40) varying; declare n_channels fixed bin; declare channel (20) char (32) varying; declare temp_segs (2) pointer; declare areap pointer; declare trace_mode_bits bit (18) unaligned; declare trace_mode_string char (120) varying; declare trace_idx fixed bin; declare last_trace_time fixed binary (71) internal static initial (0); declare last_trace_idx fixed binary internal static initial (0); declare error_table_$noarg fixed bin (35) external static; declare error_table_$badopt fixed bin (35) external static; declare error_table_$too_many_args fixed bin (35) external static; declare error_table_$bad_conversion fixed bin (35) external static; declare error_table_$bad_mode fixed bin (35) external static; declare error_table_$inconsistent fixed bin (35) external static; declare error_table_$bigarg fixed bin (35) external static; declare check_star_name_$entry entry (char (*), fixed bin (35)); declare command_query_$yes_no entry options (variable); declare com_err_ entry options (variable); declare copy_erf_seg_$name entry (char (*), char (*), pointer, fixed bin (19), fixed bin (35)); declare cu_$arg_count entry (fixed bin, fixed bin (35)); declare cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); declare cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); declare date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); declare get_temp_segments_ entry (char (*), (*) pointer, fixed bin (35)); declare ioa_ entry options (variable); declare ioa_$rsnnl entry options (variable); declare match_star_name_ entry (char (*), char (*), fixed bin (35)); declare mode_string_$parse entry (char (*), pointer, pointer, fixed bin (35)); declare release_temp_segments_ entry (char (*), (*) pointer, fixed bin (35)); declare hphcs_$set_mcm_trace_table_size entry (fixed bin, fixed bin (35)); declare hphcs_$set_mcm_global_trace entry (bit (*), fixed bin (35)); declare hphcs_$set_mcm_channel_trace entry (fixed bin, bit (2) aligned, fixed bin (35)); declare WHOAMI char (32) internal static options (constant) init ("trace_mcs"); declare (linkage_error, cleanup) condition; declare (addr, binary, empty, float, hbound, index, length) builtin; declare (maxlength, mod, null, pointer, rel, rtrim, size) builtin; declare (string, substr, unspec) builtin; /* */ temp_segs (*) = null (); brief_sw = "0"b; reset_sw = "0"b; all_sw = "0"b; reverse_sw = "0"b; on_sw = "0"b; off_sw = "0"b; print_sw = "0"b; force_sw = "0"b; erf_name = ""; table_size = -1; new_modes = ""; n_channels = 0; n_excludes = 0; n_matches = 0; last_count = -1; on condition (cleanup) call cleanup_procedure (); call cu_$arg_count (arg_count, code); if (code ^= 0) then do; call com_err_ (code, WHOAMI); goto MAIN_RETURN; end; if (arg_count < 1) then do; call com_err_ (error_table_$noarg, WHOAMI, "^/Usage:^-^a modes|chn|table_size|print {-control_args}", WHOAMI); goto MAIN_RETURN; end; arg_index = 1; call cu_$arg_ptr (arg_index, arg_ptr, arg_lth, (0)); if (arg = "table_size") | (arg = "ts") then goto PROCESS_TABLE_SIZE; else if (arg = "channel") | (arg = "chan") | (arg = "chn") then goto PROCESS_CHANNEL; else if (arg = "modes") then goto PROCESS_MODES; else if (arg = "print") | (arg = "pr") | (arg = "p") then goto PROCESS_PRINT; else if (arg = "reset") | (arg = "rs") then goto PROCESS_RESET; else do; call com_err_ (0, WHOAMI, "Unknown function: ^a", arg); goto MAIN_RETURN; end; BADOPT_ERROR: call com_err_ (error_table_$badopt, WHOAMI, "^a", arg); goto MAIN_RETURN; inconsistent: procedure (P_error); declare P_error char (*) parameter; call com_err_ (error_table_$inconsistent, WHOAMI, P_error); goto MAIN_RETURN; end inconsistent; MAIN_RETURN: call cleanup_procedure (); return; /* */ PROCESS_TABLE_SIZE: operation = "set trace table size"; do arg_index = 2 to arg_count; call cu_$arg_ptr (arg_index, arg_ptr, arg_lth, (0)); if (arg = "-erf") then call get_erf_argument; else if (index (arg, "-") = 1) then goto BADOPT_ERROR; else do; /* Anything else is supposed to be a table size */ if (table_size >= 0) then do; call com_err_ (error_table_$too_many_args, WHOAMI, "Extra table size ^a", arg); goto MAIN_RETURN; end; table_size = cv_dec_check_ (arg, code); if (code ^= 0) | (table_size < 0) then do; call com_err_ (error_table_$bad_conversion, WHOAMI, "Table size must be a positive decimal integer, (0 for off), not ""^a"".", arg); goto MAIN_RETURN; end; end; end; if (table_size < 0) then do; /* Print the current value */ call get_tty_segs (); if (trace_array_ptr = null ()) then call ioa_ ("MCS Tracing is not enabled^[ in ERF ^a^;^s^].", (erf_name ^= ""), erf_name); else call ioa_ ("MCS Trace table size is ^d^[ in ERF ^a^;^s^].", trace_array.num_entries, (erf_name ^= ""), erf_name); end; else call set_table_size (); goto MAIN_RETURN; /* All done for table_size */ /* */ PROCESS_MODES: operation = "set trace modes"; do arg_index = 2 to arg_count; call cu_$arg_ptr (arg_index, arg_ptr, arg_lth, (0)); if (arg = "-erf") then call get_erf_argument; else if (arg = "-brief") | (arg = "-bf") then brief_sw = "1"b; else if (arg = "-long") | (arg = "-lg") then brief_sw = "1"b; else if (index (arg, "-") = 1) then goto BADOPT_ERROR; else do; /* Anything else is supposed to be a mode string */ if (new_modes ^= "") then do; call com_err_ (error_table_$too_many_args, WHOAMI, "Extra mode string ^a", arg); goto MAIN_RETURN; end; new_modes = arg; end; end; call get_tty_segs (); trace_mode_bits = string (tty_buf.trace.flags); /* Get the current bit string value */ if (new_modes = "") then do; /* Print the current value */ call get_trace_modes (); call ioa_ ("MCS Trace modes^[ in ERF ^a^;^s^]: ^a", (erf_name ^= ""), erf_name, trace_mode_string); end; else do; call check_if_update_allowed (); call set_trace_modes (new_modes); call hphcs_$set_mcm_global_trace (trace_mode_bits, code); if code ^= 0 then call com_err_ (code, WHOAMI, "Cannot change trace modes to ^a", new_modes); else if ^brief_sw then do; call get_trace_modes (); call ioa_ ("New MCS trace modes: ^a", trace_mode_string); end; end; goto MAIN_RETURN; /* All done for mode setting */ /* */ PROCESS_CHANNEL: operation = "set channel tracing"; do arg_index = 2 to arg_count; call cu_$arg_ptr (arg_index, arg_ptr, arg_lth, (0)); if (arg = "-erf") then call get_erf_argument; else if (arg = "-print") | (arg = "-pr") then print_sw = "1"b; else if (arg = "-force") | (arg = "-fc") then force_sw = "1"b; else if (arg = "-on") then on_sw = "1"b; else if (arg = "-off") then off_sw = "1"b; else if (index (arg, "-") = 1) then goto BADOPT_ERROR; else call add_to_array /* Anything else is supposed to be a channel name */ (arg, channel, n_channels, "channel name", "1"b); end; /* Of argument loop */ if (on_sw & off_sw) then call inconsistent ("-on and -off"); if (force_sw & ^(on_sw | off_sw)) then call inconsistent ("-force and not -on"); if ^(on_sw | off_sw | print_sw) then do; call com_err_ (error_table_$noarg, WHOAMI, "At least one of -on, -off, or -print must be specified to ^a", operation); goto MAIN_RETURN; end; if (n_channels = 0) then do; call com_err_ (error_table_$noarg, WHOAMI, "At least one channel name must be specified to ^a", operation); goto MAIN_RETURN; end; if (on_sw | off_sw) then call check_if_update_allowed (); call get_tty_segs (); call set_channel_tracing (); goto MAIN_RETURN; /* All done for setting per- channel tracing */ /* */ PROCESS_RESET: operation = "reset MCS tracing"; if (arg_count > 2) then do; call com_err_ (error_table_$too_many_args, WHOAMI, "No additional arguments are permitted."); goto MAIN_RETURN; end; call check_if_update_allowed (); call get_tty_segs (); call set_trace_modes ("off,^default,none"); /* Everything off */ call hphcs_$set_mcm_global_trace (trace_mode_bits, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot set tracing modes to reset state."); goto MAIN_RETURN; end; call hphcs_$set_mcm_trace_table_size (0, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot set trace table size to zero."); goto MAIN_RETURN; end; begin; declare chan_idx fixed bin; declare chan_name char (32); do chan_idx = 1 to lct.max_no_lctes; lctep = addr (lct.lcte_array (chan_idx)); if (lcte.trace | lcte.trace_force) then do; chan_name = lcnt.names (chan_idx); if (unspec (chan_name) = ""b) then chan_name = ""; call hphcs_$set_mcm_channel_trace (chan_idx, "00"b, code); if code ^= 0 then call com_err_ (code, WHOAMI, "Cannot reset channel tracing for devx ^d.^[ (^a)^]", chan_idx, (chan_name ^= ""), chan_name); end; end; /* Of loop through LCTEs */ end; /* Begin block */ goto MAIN_RETURN; /* */ PROCESS_PRINT: operation = "print trace entries"; do arg_index = 2 to arg_count; call cu_$arg_ptr (arg_index, arg_ptr, arg_lth, (0)); if (arg = "-erf") then call get_erf_argument; else if (arg = "-reset") | (arg = "-rs") then reset_sw = "1"b; else if (arg = "-all") | (arg = "-a") then all_sw = "1"b; else if (arg = "-reverse") | (arg = "-rev") | (arg = "-rv") then reverse_sw = "1"b; else if (arg = "-last") | (arg = "-lt") then do; if (last_count > 0) then do; call com_err_ (error_table_$too_many_args, WHOAMI, "Extra -last count ^a", arg); goto MAIN_RETURN; end; call get_next_argument ("Count for -last"); last_count = cv_dec_check_ (arg, code); if (code ^= 0) | (last_count <= 0) then do; call com_err_ (error_table_$bad_conversion, WHOAMI, "Count for -last must be a number greater than zero, not ""^a"".", arg); goto MAIN_RETURN; end; end; else if (arg = "-channel") | (arg = "-chan") | (arg = "-chn") then do; call get_next_argument ("Channel name"); call add_to_array (arg, channel, n_channels, "channel name", "1"b); end; else if (arg = "-match") | (arg = "-mh") then do; call get_next_argument ("Match string"); call add_to_array (arg, match, n_matches, "match string", "0"b); end; else if (arg = "-exclude") | (arg = "-ex") then do; call get_next_argument ("Exclude string"); call add_to_array (arg, exclude, n_excludes, "exclude string", "0"b); end; else if (index (arg, "-") = 1) then goto BADOPT_ERROR; else call add_to_array /* Anything else is supposed to be a channel name */ (arg, channel, n_channels, "channel name", "1"b); end; /* Of argument loop */ if reverse_sw & ^(all_sw | (last_count > 0)) then call inconsistent ("-reverse without -last or -all"); call get_tty_segs (); if (trace_array_ptr = null ()) then call ioa_ ("^a: There is no MCS trace array defined^[ in ERF ^a^;^s^].", WHOAMI, (erf_name ^= ""), erf_name); else if (binary (trace_array.idx, 36) <= 1) then call ioa_ ("^a: The MCS trace array is empty^[ in ERF ^a^;^s^]", WHOAMI, (erf_name ^= ""), erf_name); else call print_trace_entries (); goto MAIN_RETURN; /* All done for printing trace entries */ /* */ get_tty_segs: procedure (); declare erf_number char (32); call get_temp_segments_ (WHOAMI, temp_segs, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Getting termporary segments."); goto MAIN_RETURN; end; ttybp = temp_segs (1); areap = temp_segs (2); if (erf_name = "") then erf_number = "-1"; else do; erf_number = erf_name; last_trace_time, last_trace_idx = 0; end; call copy_erf_seg_$name (erf_number, "tty_buf", ttybp, (0), code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot copy tty_buf."); goto MAIN_RETURN; end; call copy_erf_seg_$name (erf_number, "tty_area", areap, (0), code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot copy tty_area."); goto MAIN_RETURN; end; lctp = pointer (ttybp, rel (tty_buf.lct_ptr)); lcntp = pointer (areap, rel (lct.lcnt_ptr)); if (tty_buf.trace.data_offset = ""b) then trace_array_ptr = null (); else do; trace_array_ptr = pointer (ttybp, tty_buf.trace.data_offset); if last_trace_idx = 0 then last_trace_idx = trace_array.num_entries; if trace_array.entry (last_trace_idx).time = last_trace_time then trace_idx = mod (last_trace_idx, trace_array.num_entries) + 1; else trace_idx = mod (binary (trace_array.idx, 18), trace_array.num_entries) + 1; end; return; end get_tty_segs; /* */ check_if_update_allowed: procedure (); declare temp_entry entry variable; if (erf_name ^= "") then do; call com_err_ (0, WHOAMI, "MCS Tracing parameters may not be altered in an FDUMP. Cannot ^a.", operation); goto MAIN_RETURN; end; on condition (linkage_error) begin; call com_err_ (0, WHOAMI, "This operation requires access to hphcs_. Cannot ^a.", operation); goto MAIN_RETURN; end; temp_entry = hphcs_$set_mcm_trace_table_size; revert condition (linkage_error); return; end check_if_update_allowed; /* */ set_table_size: procedure (); declare yes_sw bit (1) aligned; declare new_size fixed bin (18); declare new_free fixed bin (18); declare percent_used float bin; call check_if_update_allowed (); call get_tty_segs (); new_size = size (trace_entry) * table_size; if (trace_array_ptr ^= null ()) then new_free = tty_buf.bleft + (size (trace_entry) * trace_array.num_entries); else new_free = tty_buf.bleft; percent_used = 100.0e0 * (float (new_size) / float (new_free)); if (percent_used > 50.0e0) then do; call command_query_$yes_no (yes_sw, 0, WHOAMI, "", "The new table will use ^.1f percent of the free space in tty_buf.^/Do you still wish to set table size to ^d?", percent_used, table_size); if ^yes_sw then goto MAIN_RETURN; end; if (trace_array_ptr ^= null ()) then do; /* Just clear out the old one first */ call hphcs_$set_mcm_trace_table_size (0, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot remove old trace table."); goto MAIN_RETURN; end; end; call hphcs_$set_mcm_trace_table_size (table_size, code); if code ^= 0 then call com_err_ (code, WHOAMI, "Setting trace table size to ^d", table_size); return; end set_table_size; /* */ set_trace_modes: procedure (P_new_modes); declare P_new_modes char (*) parameter; declare modes_area area (1000); declare idx fixed bin; call mode_string_$parse (P_new_modes, addr (modes_area), mode_string_info_ptr, code); if (code ^= 0) then do; call com_err_ (code, WHOAMI, "Mode string ^a", P_new_modes); goto MAIN_RETURN; end; do idx = 1 to mode_string_info.number; mode_value_ptr = addr (mode_string_info.modes (idx)); if (^mode_value.boolean_valuep) then do; call com_err_ (error_table_$bad_mode, WHOAMI, "The value for the ^a mode must be boolean^[, not character^]^[, not numeric^].", mode_value.mode_name, mode_value.char_valuep, mode_value.numeric_valuep); goto MAIN_RETURN; end; call set_single_mode (mode_value.mode_name, mode_value.boolean_value); end; return; end set_trace_modes; /* */ /* This procedure is used both for setting modes and building the mode string. The reason for its hirsute flow of control is to allow all the correspondence between mode names and mode bit names to be centralized in a single place: the list of calls to process_mode. To add new modes, just put in a new call to process_mode in the right place in the list (either before or after the assignment to set_all_modes, depending on whether the mode should be affected by use of the "all" or "none" mode names. */ process_modes: procedure (); declare P_new_mode_value bit (1) unaligned parameter; declare P_set_mode_name char (*) parameter; declare 1 trace_modes unaligned like tty_buf.trace.flags; declare function char (16) varying; declare all_mode_sw bit (1) aligned; /* Means we are processing "all" or "none" */ declare all_mode_value bit (1) aligned; /* Value for above */ declare set_all_modes bit (1) aligned; /* Set to indicate start of modes in "all" set */ get_trace_modes: entry (); function = "add"; trace_mode_string = ""; goto PROCESS_MODES_COMMON; set_single_mode: entry (P_set_mode_name, P_new_mode_value); function = "set"; set_all_modes = "0"b; if (P_set_mode_name = "all") then do; if P_new_mode_value = "0"b then goto BAD_MODE_VALUE; all_mode_sw = "1"b; all_mode_value = "1"b; end; else if (P_set_mode_name = "none") then do; if P_new_mode_value = "0"b then goto BAD_MODE_VALUE; all_mode_sw = "1"b; all_mode_value = "0"b; end; else all_mode_sw = "0"b; if (P_set_mode_name = "off") then do; P_set_mode_name = "on"; P_new_mode_value = ^P_new_mode_value; end; PROCESS_MODES_COMMON: string (trace_modes) = trace_mode_bits; /* Get the current values */ call process_mode (trace_modes.enable, "on"); call process_mode (trace_modes.default_mode, "default"); set_all_modes = all_mode_sw; call process_mode (trace_modes.read, "read"); call process_mode (trace_modes.write, "write"); call process_mode (trace_modes.data, "data"); call process_mode (trace_modes.control, "control"); call process_mode (trace_modes.modes, "modes"); call process_mode (trace_modes.interrupt, "interrupt"); call process_mode (trace_modes.init, "init_mpx"); call process_mode (trace_modes.start, "start_mpx"); call process_mode (trace_modes.shutdown, "stop_mpx"); call process_mode (trace_modes.space_man, "space_man"); if (function = "set") & (^all_mode_sw) then do; /* We fell through to here without finding the mode */ BAD_MODE_VALUE: call com_err_ (error_table_$bad_mode, WHOAMI, "^[^^^]^a", P_new_mode_value, P_set_mode_name); goto MAIN_RETURN; end; FINISHED_SETTING_MODE: if (function = "set") then /* Update the bit string */ string (trace_mode_bits) = string (trace_modes); return; /* */ /* Procedure to either add a single mode to the string, or, if the mode name matches, set the mode value for a single mode. */ process_mode: procedure (P_mode_bit, P_mode_name); declare P_mode_bit bit (1) unaligned parameter; declare P_mode_name char (16) varying; if function = "add" then do; if (length (trace_mode_string) > 0) then trace_mode_string = trace_mode_string || ","; if P_mode_bit then trace_mode_string = trace_mode_string || P_mode_name; else trace_mode_string = trace_mode_string || "^" || P_mode_name; end; else if function = "set" then do; if set_all_modes then do; P_mode_bit = all_mode_value; return; end; if P_set_mode_name ^= P_mode_name then return; /* Not the right one */ P_mode_bit = P_new_mode_value; goto FINISHED_SETTING_MODE; end; end process_mode; end process_modes; /* */ /* This procedure sets tracing for specified channels, and/or prints the state o tracing */ set_channel_tracing: procedure (); declare chan_idx fixed bin; declare name_idx fixed bin; declare channel_name char (32); declare trace_flags bit (2) aligned; declare matching_channels fixed bin; declare old_state char (16) varying; declare new_state char (16) varying; trace_flags = ""b; substr (trace_flags, 1, 1) = on_sw; substr (trace_flags, 2, 1) = force_sw; call ioa_$rsnnl ("^[on^;off^]^[, default^]", new_state, (0), on_sw, force_sw); matching_channels = 0; do chan_idx = 1 to lct.max_no_lctes; lctep = addr (lct.lcte_array (chan_idx)); channel_name = lcnt.names (chan_idx); if unspec (channel_name) = ""b then goto NEXT_CHANNEL; if channel_name = "" then goto NEXT_CHANNEL; do name_idx = 1 to n_channels; call match_star_name_ (channel_name, (channel (name_idx)), code); if code = 0 then goto THIS_CHANNEL; end; goto NEXT_CHANNEL; /* Matched none of the possibilities */ THIS_CHANNEL: matching_channels = matching_channels + 1; if (matching_channels = 1) & print_sw then /* Print header */ call ioa_ ("Devx^2xName^36tState (default is ^[on^;off^])", tty_buf.trace.flags.default_mode); call ioa_$rsnnl ("^[on^;off^]^[, force^]", old_state, (0), lcte.trace, lcte.trace_force); if (on_sw | off_sw) then do; call hphcs_$set_mcm_channel_trace (chan_idx, trace_flags, code); if code ^= 0 then call com_err_ (code, WHOAMI, "Cannot set tracing on ^a to ^a.", channel_name, new_state); if print_sw then call ioa_ ("^4d^2x^a^36t^a (was ^a)", chan_idx, channel_name, new_state, old_state); end; else if print_sw then call ioa_ ("^4d^2x^a^36t^a", chan_idx, channel_name, old_state); NEXT_CHANNEL: end; if (matching_channels = 0) then call ioa_ ("^a: No channels matched supplied names.", WHOAMI); else if print_sw then call ioa_ (""); return; end set_channel_tracing; /* */ print_trace_entries: procedure (); declare channel_name char (32); declare first_idx fixed bin; declare last_idx fixed bin; declare increment fixed bin; declare entry_idx fixed bin; declare real_entry_idx fixed bin; if all_sw then last_count = trace_array.num_entries; /* Fake up printin them all */ if (last_count > 0) then do; if (last_count > trace_array.num_entries) then do; call ioa_ ("Cannot print last ^d entries; maximum will be ^d", last_count, trace_array.num_entries); last_count = trace_array.num_entries; end; if reverse_sw then do; increment = -1; first_idx = binary (trace_array.idx) - 1; last_idx = (first_idx - last_count) + 1; end; else do; increment = 1; last_idx = binary (trace_array.idx) - 1; first_idx = (last_idx - last_count) + 1; end; do entry_idx = first_idx to last_idx by increment; real_entry_idx = 1 + mod ((entry_idx - 1), trace_array.num_entries); trace_entry_ptr = addr (trace_array.entry (real_entry_idx)); channel_name = lcnt.names (trace_entry.devx); if (trace_entry.time > 0) then if entry_matches () then call print_single_entry (); end; /* Of loop through trace entries */ return; /* All done here */ end; /* Of case for -last */ do while ((trace_array.entry (trace_idx).time + 10000 > last_trace_time) & (trace_array.entry (trace_idx).time > 0)); trace_entry_ptr = addr (trace_array.entry (trace_idx)); channel_name = lcnt.names (trace_entry.devx); if entry_matches () then call print_single_entry (); NEXT_TRACE_ENTRY: last_trace_idx = trace_idx; last_trace_time = trace_entry.time; trace_idx = mod (trace_idx, trace_array.num_entries) + 1; end; return; /* */ entry_matches: procedure () returns (bit (1) aligned); declare name_idx fixed bin; do name_idx = 1 to n_channels; call match_star_name_ (channel_name, (channel (name_idx)), code); if code = 0 then goto CHECK_FOR_STRINGS; end; if (n_channels > 0) then return ("0"b); /* No channels matched */ CHECK_FOR_STRINGS: do name_idx = 1 to n_excludes; if index (rtrim (trace_entry.message), exclude (name_idx)) ^= 0 then return ("0"b); /* Exclude strig matches */ end; do name_idx = 1 to n_matches; if index (rtrim (trace_entry.message), match (name_idx)) ^= 0 then return ("1"b); /* Match string matches */ end; if (n_matches > 0) then return ("0"b); /* If none matched, and there were some, just go on */ return ("1"b); end entry_matches; /* */ print_single_entry: procedure (); declare time_form char (22) int static options (constant) init ("^Hd:^MH:^99v.999999SM"); if (channel_name = "") | (unspec (channel_name) = ""b) then call ioa_$rsnnl ("^o", channel_name, (0), trace_entry.devx); call ioa_ ("^16a ^a: ^a", date_time_$format (time_form, trace_entry.time, "", ""), channel_name, trace_entry.message); return; end print_single_entry; end print_trace_entries; /* */ get_erf_argument: procedure (); call get_next_argument ("ERF name"); if (erf_name ^= "") then do; call com_err_ (error_table_$too_many_args, WHOAMI, "Extra ERF name ^a", arg); goto MAIN_RETURN; end; erf_name = arg; return; end; get_next_argument: procedure (P_name); declare P_name char (*) parameter; if (arg_index >= arg_count) then do; call com_err_ (error_table_$noarg, WHOAMI, "^a after ^a", P_name, arg); goto MAIN_RETURN; end; arg_index = arg_index + 1; call cu_$arg_ptr (arg_index, arg_ptr, arg_lth, (0)); return; end get_next_argument; /* */ add_to_array: procedure (P_name, P_array, P_array_size, P_description, P_check_starname); declare P_name char (*) parameter; declare P_array (*) char (*) varying parameter; declare P_array_size fixed bin; declare P_description char (*); declare P_check_starname bit (1) aligned; if P_check_starname then do; call check_star_name_$entry (P_name, code); if (code ^= 0) & (code ^= 1) & (code ^= 2) then do; call com_err_ (code, WHOAMI, "Invalid ^a: ^a", P_description, P_name); goto MAIN_RETURN; end; end; if (P_array_size >= hbound (P_array, 1)) then do; call com_err_ (error_table_$too_many_args, WHOAMI, "Too many ^as. Max is ^d.", P_description, hbound (P_array, 1)); goto MAIN_RETURN; end; if (length (P_name) > maxlength (P_array (1))) then do; call com_err_ (error_table_$bigarg, WHOAMI, "The ^a may only be ^d characters long. ^a", P_description, maxlength (P_array (1)), P_name); goto MAIN_RETURN; end; P_array_size = P_array_size + 1; P_array (P_array_size) = P_name; return; end add_to_array; /* */ cleanup_procedure: procedure (); if (temp_segs (1) ^= null ()) then call release_temp_segments_ (WHOAMI, temp_segs, (0)); return; end cleanup_procedure; %page; %include mode_string_info; %page; %include tty_buf; %page; %include lct; %page; %include mcs_trace_data; end trace_mcs; 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