



		    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 <path> -ag <gcos args>");
	     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
