



		    isolts_.pl1                     10/14/88  1324.3r w 10/14/88  1311.0      455607



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
isolts_: proc;

/* isolts_ - the I_S_olated O_nL_ine T_est S_ystem (ISOLTS) driver
   initially coded by James A. Bush 6/78
   Modified 09/80 by R. Fakoury to make the operator message more understandable,
   to correct a bug when displaying the last error, to request input after invalid responce,
   to add a delay between operator request reconfig messages and to force the end pass message to the terminal.
   Modified 8102 by R. Fakoury to allow margin/nomargin options and to add the display_error in the initial request.
   Modified 8112 by R. Fakoury to correct an oversight in the operator message sequence,
   to add new numbers to inv_tst_ids.
   Modified 02/04/83 by R. Fakoury to add new test ids to the invalid test list.
   Modified 03/83 by R. Fakoury to allow -type option to the display request and the type option to a pas option request.
   Also put temp cludge to increase the timeout time for prg892/893.
   Modified 03/83 by Rick Fakoury to add call to tolts_util_$get_ttl_date, and
   tolts_util_$opr_msg.
   Modified 03/83 by Rick Fakoury to remove the (non_quick) option from interpret_action and run_pas.
   Modified 08/17/83 by Rick Fakoury to allow partial config printing & correct an error in display error of one.
   Modified 09/21/83 by R. Fakoury to check for a config card with no cpu type and to modify dps8 reconfig instructions.
   Modified 10/83 by R.Fakoury to implement auditor suggested changes.
   Modified 11/84 by R. Fakoury to changes the call from tolts_pcd_$config to tolts_util_$find_card, make tst893 invalid,
   and to use the system includes files for cpu.
*/

/* External entries */

dcl  tolts_util_$get_ttl_date entry (entry, char (6));
dcl  tandd_$check_isolts_resources entry (fixed bin (5), fixed bin (5), fixed bin (5), fixed bin (35));
dcl  tandd_$create_cpu_test_env entry (fixed bin (5), fixed bin (5), (4) bit (36), ptr, fixed bin (35));
dcl  tandd_$destroy_cpu_test_env entry;
dcl  tandd_$interrupt_test_cpu entry (fixed bin (35));
dcl  tolts_pcd_ entry (char (6), char (*));
dcl  tolts_util_$find_card entry (char (4), ptr);
dcl  tolts_util_$query entry (char (*), char (132) aligned, fixed bin, (32) char (28) varying, fixed bin);
dcl  tolts_util_$config entry (char (4), ptr, char (*) varying);
dcl  tolts_util_$bci_to_ascii entry (bit (*), char (*) varying, fixed bin);
dcl  tolts_util_$search entry (ptr, char (32), ptr, fixed bin, fixed bin (35));
dcl  tolts_util_$on_off entry (char (6), char (3), char (6));
dcl  tolts_util_$opr_msg entry;
dcl  isolts_err_log_$init entry (fixed bin (35));
dcl  isolts_err_log_$write entry (ptr, fixed bin, fixed bin, fixed bin (5), fixed bin (5));
dcl  isolts_err_log_$display entry (fixed bin, fixed bin, bit (1));
dcl  isolts_err_log_$dump entry (char (5), ptr, fixed bin (18), fixed bin, fixed bin (5), fixed bin (5));
dcl  dump_segment_ entry (ptr, ptr, fixed bin, fixed bin (18), fixed bin (18), bit (*));
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
dcl  gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
dcl  bcd_to_ascii_ entry (bit (*), char (*));
dcl  tolts_alm_util_$ascii_to_bci_ entry (char (*) aligned, bit (*));
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  (ioa_, signal, com_err_, ioa_$rsnnl, ioa_$nnl, opr_query_) entry options (variable);
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));

/* Automatic */

dcl  code fixed bin (35);				/* standard system error code */
dcl  (cpu_tag, scu_tag, cpu_port) fixed bin (5);		/* cpu and scu tags */
dcl  switches (4) bit (36);				/* read switch descrepency data */
dcl  bf_sw bit (1) init ("0"b);			/* brief option switch */
dcl  (nxt_tst, new_tst) char (3);			/* next test id for search */
dcl  cpu_type char (4);
dcl  (term, trm, trm1, pas_sw, mess_in_prog, ntype, run, option, trace_sw,
     dump_in_prog, idump, car_nz) bit (1) init ("0"b);
dcl  out_str char (136) varying;
dcl  com_string char (132) aligned;
dcl  add_opt char (6);
dcl  tim char (12);
dcl  delay_iter fixed bin init (300);
dcl  ttl_date char (6);
dcl  d_type char (5);
dcl  args (32) char (28) varying;
dcl  (pgm_offset, first, last) fixed bin (18);
dcl  (cmd_cnt, delay, i, j, k, c_len, bcd_chars, mtype, mlen, count, limit) fixed bin;
dcl  (pip, wseg_p, t_ptr, awcp, mptr, hdr_p) ptr;

/* Constants */

dcl  (quit, cleanup, finish) condition;
dcl  pname char (6) static options (constant) init ("isolts");
dcl  tags (0:7) char (1) static options (constant) init
      ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  first_pft char (3) static options (constant) init ("01c");
dcl  pas_exec char (3) static options (constant) init ("061");
dcl  inv_tst_ids (22) char (3) static options (constant) init
      ("781", "782", "783", "784", "891", "894", "895", "897", "899", "908", "920", "921", "922", "923",
      "924", "927", "928", "929", "930", "975", "980", "990");
dcl  illegal_pas_opt (2) char (8) varying static options (constant) init
      ("cardin", "i/o");
dcl  NL char (1) int static options (constant) init ("
");
dcl  pas_delay fixed bin static options (constant) init (2);
dcl  pft_delay fixed bin static options (constant) init (2);
dcl  p_err bit (1) int static init ("1"b);		/* print error flag */
dcl  df_iocbp ptr int static init (null);		/* deck file iocb ptr */
dcl  isolate_cpu bit (1) int static;			/* cleanup flag */
dcl  (cont_pas, restart, end_pas, eopt) label;		/* target of non_local gotos */
dcl  iox_$user_output ptr ext;
dcl  (addr, addrel, fixed, hbound, index, length, ltrim, mod, null, ptr, rel,
     rtrim, search, string, substr, time) builtin;

/* Structures and based variables */

dcl  1 wseg based (wseg_p) aligned,			/* structure definition of PAS2 layout */
       2 int_vectors (0:31) bit (72),			/* 0 - 77 interrupt vectors */
       2 flt_vectors (0:31) bit (72),			/* 100 - 177 fault vectors */
       2 pad1 (32) bit (72),
       2 COW bit (36),				/* 300 Connect operand word */
       2 pad2 (10) bit (36),
       2 prt_out (30) bit (36),			/* 313 - 350 printer output buffer */
       2 cons_in (21) bit (36),			/* 351 - 375 console input buffer */
       2 pad3 (322) bit (36),
       2 opt_save (25) bit (36),			/* 1100 - 1130 options save area */
       2 pad4 (31) bit (36),
       2 is_mbx,					/* 1170 - 1177 ISOLTS mailbox area */
         3 control fixed bin (35),			/* ISOLTS in control, if non-zero */
         3 service fixed bin (35),			/* ISOLTS service requested flag, If non-zero */
         3 action_codes unaligned,			/* service action codes */
	 4 pad5 bit (21),
	 4 halt bit (1),				/* bit 21 - halt imediately */
	 4 pad6 bit (4),
	 4 ld_spgm bit (1),				/* bit 26 - load slave mode program */
	 4 ld_mpgm bit (1),				/* bit 27 - load master mode program or PFT */
	 4 wc_eop bit (1),				/* bit 28 - write console, end of program */
	 4 wc_opt bit (1),				/* bit 29 - write console, option request flag */
	 4 read bit (1),				/* bit 30 - read console */
	 4 wc_type bit (1),				/* bit 31 - write console, type message */
	 4 print bit (1),				/* bit 32 - print message */
	 4 err bit (1),				/* bit 33 - error flag */
	 4 pad7 bit (2),
         3 pgm_name bit (36),				/* word 3 - program name or ptr and wd count */
         3 pad8 (4) bit (36),
       2 pad9 (64) bit (36),
       2 wk_survey (16) bit (36),			/* 1300 - 1317 working survey table */
       2 pad10 (3359) bit (36),
       2 imw unaligned,				/* 7757 - IOM interrupt multiplexor word */
         3 pad bit (18),
         3 base bit (18),				/* base address */
       2 sys_survey unaligned,			/* 7760 - 7777 system survey table */
         3 iom0,					/* IOM 0 mailbox and port */
	 4 mbx bit (18),
	 4 port fixed bin,
         3 iom1_3 (3) bit (36),			/* same info for IOMs 1, 2, and 3 */
         3 console,					/* info on system console */
	 4 chan fixed bin (8),			/* console channel number */
	 4 pad bit (27),
	 4 cons_iom bit (36),			/* iom number that console is on */
         3 printer,					/* info about system printer */
	 4 chan fixed bin (8),			/* printer channel number */
	 4 pad bit (27),
	 4 prt_iom bit (36),			/* iom number that printer is on */
         3 cont_cpu,				/* info about control cpu */
	 4 f_vec bit (18),				/* fault vector base address */
	 4 port fixed bin,				/* control cpu port number */
         3 hi_mem,					/* info about highest addressable memory location */
	 4 address fixed bin,
	 4 pad bit (18),
         3 cpu_1,					/* info about cpu # 1 */
	 4 f_vec bit (18),				/* fault vector base address */
	 4 port fixed bin,				/* cpu # 1 port number */
         3 cpu2_4 (3) bit (36),			/* the same info for cpus 2, 3, and 4 */
         3 boot,					/* info on boot device */
	 4 chan fixed bin (8),			/* boot tape chan number */
	 4 pad bit (27),
	 4 iom bit (36),				/* iom number that boot tape is on */
       2 exec (28672) bit (36),			/* 10000 - 77777 PAS2 exec area */
       2 test_pgm (32768) bit (36);			/* 100000 - 177777 slave program area */

dcl  1 slave_hdr based (hdr_p) aligned,			/* slave program header template */
       (
       2 pgm_num bit (36),				/* pgm # in bcd (e.g. - pm700, pa864, ps955) */
       2 erlink bit (18),				/* error linkage pointer */
       2 pgm_rev bit (18),				/* program revision in bcd */
       2 p_int_tab bit (18),				/* pseudo interrupt vector ptr */
       2 pgm_size bit (18),				/* program size in words */
       2 tst_name bit (72),				/* test name */
       2 num_tests bit (18),				/* number of tests in program */
       2 xfer_p bit (18),				/* transfer table pointer */
       2 cksum bit (36),				/* check sum word before init. */
       2 program_name bit (108),			/* program name */
       2 pad (9) bit (36)
       ) unaligned;					/* pad area */

dcl  1 action like is_mbx.action_codes unaligned;		/* copy of action flags */
dcl  1 pi like rsw_1_3.port_info based (pip) unaligned;
dcl  wseg1 (65536) fixed bin based (wseg_p);		/* work seg as an array */
dcl  bcd_str bit (bcd_chars * 6) based (mptr);		/* bcd message input */
dcl  add_wc (2) fixed bin unaligned based (awcp);		/* address and word count */


%include config_cpu_card;
%page;


      isolate_cpu = "0"b;				/* reset cleanup flag */
      on cleanup call clean_up;			/* establish cleanup and */
      on finish call clean_up;			/* finish condition handlers */

      call tolts_util_$get_ttl_date (isolts_, ttl_date);
      call tolts_util_$on_off (pname, "on", ttl_date);	/* signon */

/* now get a pointer to our error message file */

      call isolts_err_log_$init (code);
      if code ^= 0 then				/* if problem */
         go to t_off;				/* wrap up and return */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
/*											*/
/* Loop until user quits									*/
/*											*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/



      term = "0"b;					/* reset terminate cndition */
      do while (^term);
         call ioa_ ("^/***enter ""test cpu <tag>"", "" display_error"", ""test pcd"", ""msg"", or ""quit """);

/* Now find out what user wants to do */

ask:
         call tolts_util_$query ("??? ", com_string, c_len, args, cmd_cnt);
         if args (1) = "quit" | args (1) = "q" then	/* user wants to quit */
	  term = "1"b;				/* so let him */
         else if args (1) = "msg" then			/* user wants to send a msg to the operator */
	  call tolts_util_$opr_msg;
         else if args (1) = "display_error" | args (1) = "display"
	| args (1) = "derr" then do;			/* display error message */
	  do i = 2 to cmd_cnt by 1;

	     if args (i) = "-type" then do;
	        p_err = "0"b;
	        args (i) = "";
	        cmd_cnt = cmd_cnt - 1;
	     end;
	  end;
	  cmd_cnt = cmd_cnt - 1;
	  if ^display_log () then			/* go display requested log entries */

bad_rsp:	     call com_err_ (0, pname, "invalid response - ""^a""", com_string);
	  go to ask;
         end;
         else if cmd_cnt < 2 | args (1) ^= "test" then	/* bad input */
	  go to bad_rsp;
         else if args (2) = "pcd" then do;		/* user wants a list of avail. cpus and scus */
	  if cmd_cnt = 3 then call tolts_pcd_ ("isolts", (args (3)));
	  else call tolts_pcd_ ("isolts", "");
         end;
         else if args (2) ^= "cpu" then			/* user goofed */
	  go to bad_rsp;
         else do;					/* test cpu request */
	  trace_sw = "0"b;				/* reset trace switch if set */
	  if cmd_cnt < 3 then			/* not enough args */
	     go to bad_rsp;
	  cpu_tag = search ("abcdefgh", args (3));	/* convert cpu tag to number */
	  if cpu_tag = 0 then			/* not correct format */
	     go to bad_rsp;
	  term = "0"b;
	  scu_tag = -1;				/* default, let hardcore decide */
	  if cmd_cnt > 3 then do;			/* additional args */
	     trm = "0"b;				/* reset flag */
	     do i = 4 to cmd_cnt;			/* process rest of args */
	        if ^trm then			/* if tag flag not set */
		 if args (i) = "-memory"
		  | args (i) = "-mem" then trm = "1"b;	/* set tag flag */
		 else if args (i) = "-brief"
		  | args (i) = "-bf" then bf_sw = "1"b; /* set brief mode */
		 else if args (i) = "-trace" then	/* user wants to trace action codes */
		    trace_sw = "1"b;		/* set trace switch */
		 else go to bad_rsp;		/* tell user about his typing problem */
	        else do;				/* ok lets find the memory tag */
		 scu_tag = search ("abcdefgh", args (i));
		 if scu_tag = 0 then		/* did not find tag */
		    go to bad_rsp;
		 else scu_tag = scu_tag - 1;
		 trm = "0"b;			/* reset tag flag */
	        end;
	     end;
	  end;

	  cpu_cardp = null;
	  do while (^term);
	     call tolts_util_$find_card ("cpu", cpu_cardp);
	     if cpu_cardp = null then term = "1"b;
	     else if cpu_card.tag = cpu_tag then do;
	        if cpu_card.type ^= "l68"
	         & substr (type, 1, 3) ^= "dps" then do;
		 call ioa_ ("isolts_: unable to determine cpu type for cpu ^a", tags (cpu_tag - 1));
reask:		 call tolts_util_$query ("enter l68 or dps8 ", com_string, c_len, args, cmd_cnt);
		 if args (1) = "l68 "
		  | args (1) = "dps8" then cpu_type = args (1);
		 else do;
		    call ioa_ ("isolts_: invalid input pls reenter.");
		    goto reask;
		 end;
	        end;
	        else cpu_type = cpu_card.type;
	        term = "1"b;
	     end;
	  end;
	  cpu_tag = cpu_tag - 1;			/* a = 0, h = 7, etc */

/* Now lets go to hardcore and check if we can get resources to run */

	  call tandd_$check_isolts_resources (cpu_tag, scu_tag, cpu_port, code);
	  if code ^= 0 then do;			/* can't get what we need */
	     call abort (code);			/* go display config error */
	     go to cmd_loop;
	  end;
	  isolate_cpu = "1"b;			/* set flag for cleanup handler */

/* now  give the operator manual reconfiguration instructions */

	  if opr_com (cpu_tag, scu_tag) then		/* if permission denied */
	     go to cmd_loop;			/* then go release resources */

/* now go do actual reconfig and primitive cpu test */

	  call tandd_$create_cpu_test_env (cpu_tag, scu_tag, switches, wseg_p, code);
	  if code ^= 0 then do;			/* some problem */
	     call abort (code);			/* go display config error */
	     go to cmd_loop;
	  end;
	  call ioa_ ("^/reconfiguration complete");	/* tell user */

	  hdr_p = addr (wseg.test_pgm);		/* set test program header ptr */
	  wseg1 = 0;				/* clear out our memory area */
	  restart = restart_label;			/* set restart label */

/* now go run the pfts and pas2 */

restart_label:					/* target of non-local gotos */
	  call run_pas;
         end;
cmd_loop: call clean_up;				/* go release resources if assigned */
      end;

/* user is all done we can wrap up now */

t_off: call tolts_util_$on_off (pname, "off", ttl_date);	/* signoff */
      return;

%page;


/* run_pas - internal procedure to run and do the test sequencing of the pfts and pas2 */

run_pas: proc;

      nxt_tst = first_pft;				/* set up for first test */
      awcp = addr (is_mbx.pgm_name);			/* set up address/word count templete ptr */
      cont_pas = continue_pas;			/* set up continue label */
      end_pas = end_tst;				/* set up quit label */
      pgm_offset = 0;				/* preset loading offset for master mode program */
      trm, pas_sw, mess_in_prog, ntype, run, option, car_nz = "0"b;
						/* reset flags */
      dump_in_prog, idump = "0"b;

/* quit_handler - quit condition handler for isolts */

      on quit begin;				/* establish quit condition handler */

         if pas_sw then do;				/* if not in primitives */
	  ntype = "0"b;				/* force options type out */
	  string (action_codes) = "0"b;		/* clear out any existing action code */
	  if dump_in_prog & ^idump then do;		/* if dumping to file */
	     dump_in_prog = "0"b;			/* abort dump and return to options */
	     go to eopt;
	  end;
	  if option then do;			/* if we are in the option loop */
	     call ioa_ ("^/");			/* force new line */
	     car_nz = "0"b;
	     go to eopt;
	  end;
	  action_codes.halt = "1"b;			/* set halt imediate flag */
	  go to cont_pas;				/* perform non local go to */
         end;
         else call continue_to_signal_ (code);		/* if not in pas2 pass it on */

      end;

      call ioa_ ("^/start pft ^a^/", nxt_tst);

      do while (^trm);				/* loop until user quits */

/* search for test page in file system */

         call tolts_util_$search (df_iocbp, "pas." || nxt_tst, t_ptr, c_len, code);
         if code ^= 0 then do;			/* if couldn't find test page */
	  call com_err_ (code, pname, "searching for pas.^a", nxt_tst);
	  ntype = "0"b;
	  string (action_codes) = "0"b;
	  action_codes.halt = "1"b;
	  go to cont_pas;
         end;

/* load the core image into our work segment */

tout_retry: call gload_ (t_ptr, addrel (wseg_p, pgm_offset), 0, addr (gload_data), code);
         if code ^= 0 then do;			/* problem durring load */
	  call com_err_ (code, pname, "^a^/attempting to load pas.^a",
	   gload_data.diagnostic, nxt_tst);
	  return;
         end;

/* reset the isolts mailbox flags and set isolts control flag */

         if ^pas_sw then				/* if pft */
	  call set_survey;				/* go set up system survey */
         else do;
	  delay = pas_delay;
	  slave_hdr.cksum = gload_data.checksum;	/* set up deck checksum in pgm header */
         end;
         if nxt_tst = "892" | nxt_tst = "893"		/* thesetests cause timeouts */
	| nxt_tst = "955" then delay_iter = 600;	/* increase the delay until fixed */
         else delay_iter = 300;
         string (is_mbx.action_codes) = "0"b;		/* reset all action flags */
         is_mbx.pgm_name = "0"b;			/* reset program name */
continue_pas:					/* target of non local go tos */
         if is_mbx.control = 0 then			/* if flag is reset */
	  is_mbx.control = 65535;			/* set it to indicate isolts in control */
         is_mbx.service = 0;				/* reset service requested flag */
         if trace_sw then				/* if tracing action codes */
	  if string (action_codes) ^= "0"b then		/* and we have  bit 21 set */
	     call itrace;				/* go trace action code */

/* send interrupt to the cpu under test */

         call tandd_$interrupt_test_cpu (code);
         if code ^= 0 then do;			/* if couldn't interrupt */
	  call com_err_ (code, pname, "attempting to interrupt cpu ^a", tags (cpu_tag));
	  return;
         end;

/* now go to sleep for awhile */

         do i = 1 to 1000 while (is_mbx.service = 0);
         end;					/* give pas2 a chance if intermediate I/O */
         if is_mbx.service = 0 then			/* if didn't make it give up processor */
wait:	  call sleep (delay);
         if is_mbx.service = 0 then do;			/* if time out */
	  call ioa_ (" ");				/* make sure we return to collum 1 */
	  if ^pas_sw & nxt_tst ^= pas_exec then do;	/* if pft and not pas2 exec */
	     call com_err_ (0, pname,
	      "time out after ^d seconds while executing PFT ^a",
	      delay * delay_iter, nxt_tst);
	     call com_err_ (0, pname,
	      "check cpu ^a's maintenence panel and consult program listing to determine failure",
	      tags (cpu_tag));
	  end;
	  else if nxt_tst = pas_exec then		/* hung up while initializing pas exec */
	     call com_err_ (0, pname,
	      "time out after ^d seconds while initializing the pas2 executive",
	      delay * delay_iter);
	  else call com_err_ (0, pname,
	        "time out after ^d seconds while executing pas2 test ^a",
	        delay * delay_iter, nxt_tst);
	  trm1 = "0"b;
	  do while (^trm1);				/* loop until user gets it right */
	     call tolts_util_$query ("respond ""quit (q)"", ""retry (r)"", or ""continue (c)"" - ",
	      com_string, c_len, args, cmd_cnt);
	     if args (1) = "quit" | args (1) = "q" then	/* user wants to get out */
	        return;
	     else if args (1) = "retry"
	      | args (1) = "r" then			/* user wants to retry test */
	        go to tout_retry;
	     else if args (1) = "continue"
	      | args (1) = "c" then			/* wait some more */
	        go to wait;
	  end;
         end;
         else do;
	  string (action) = string (is_mbx.action_codes); /* copy action codes */
	  if trace_sw then				/* if tracing action codes */
	     call itrace;				/* go trace action code */
	  string (is_mbx.action_codes) = "0"b;		/* and reset */
	  call interpret_action;			/* do what the test wants */
         end;
end_tst:						/* target of non-local gotos */
      end;



   end run_pas;

%page;

/* interpret_action - internal procedure to interpret  the isolts action flags */

interpret_action: proc;

      if action.ld_mpgm | action.ld_spgm then do;		/* load next program request */
         call complete_err_mess;			/* go complete error message if one active */
         call bcd_to_ascii_ (substr (pgm_name, 13, 18), new_tst);
						/* convert tst id to ascii */
         if trace_sw then				/* if user tracing action codes... */
	  call ioa_ ("load pgm^a", new_tst);		/* tell him what we want to load */
         do i = 1 to hbound (inv_tst_ids, 1) while (new_tst ^= inv_tst_ids (i));
         end;					/* check validity of test id */
         if i <= hbound (inv_tst_ids, 1) then do;		/* If this test is illegal for isolts */
	  ntype = "1"b;				/* set flag so we don't type options message */
	  action_codes.halt = "1"b;			/* set halt imediate flag */
	  go to cont_pas;				/* perform non local goto */
         end;
         if ^pas_sw & ^bf_sw then			/* if PFT and not in brief mode ... */
	  call ioa_ ("*** end ^a, next ^a ***", nxt_tst, new_tst); /* display test seq for user */
         nxt_tst = new_tst;				/* pick up new test id and go find it */
         if action.ld_spgm then			/* if slave program to be loaded */
	  pgm_offset = fixed (rel (addr (wseg.test_pgm)), 18); /* set slave base */
         else pgm_offset = 0;				/* if master mode pgm then offset = 0 */
      end;					/* fall through and return */
      else if action.wc_type | action.wc_eop | action.wc_opt then do;
						/* write console */
         call complete_err_mess;			/* go complete error message if one active */
         mptr = ptr (wseg_p, add_wc (1));
         bcd_chars = add_wc (2) * 6;			/* get address and word count of message */
         call tolts_util_$bci_to_ascii (bcd_str, out_str, bcd_chars); /* convert bcd */
         if substr (out_str, 1, 1) = NL & length (out_str) > 2 then /* if new line strip it off */
	  out_str = substr (out_str, 2);
         if action.wc_type & length (out_str) >= 1 then	/* if output to go on same line */
	  car_nz = "1"b;
         if action.wc_opt | action.wc_eop then option = "1"b; /* if option type request */
         else option = "0"b;

         if ^ntype then do;				/* if no type flag is on ignore message */
	  call ioa_$nnl ("^[^/^]^a^[^/^]", (car_nz & length (out_str) > 1),
	   out_str, (^action.wc_opt & length (out_str) > 1 & ^option));
	  if length (out_str) > 1 then car_nz = "0"b;	/* reset carriage position switch */
         end;
         go to cont_pas;				/* perform non local goto */
      end;
      else if action.read then			/* enter options request */
         call enter_options;
      else if action.print then do;			/* output message to printer */
         mptr = ptr (wseg_p, add_wc (1));
         mlen = add_wc (2);				/* set word count of message */
         if dump_in_prog then				/* if we are getting dump reg info from pas2 */
	  call isolts_err_log_$dump (d_type, mptr, (mlen), 1, cpu_tag, scu_tag);
         else if action.err | mess_in_prog then do;	/* if new error message or one in progress */
	  if mlen > 1 & mlen < 5 & ^mess_in_prog then do; /* must be end pass & ^message */
	     mptr = ptr (wseg_p, add_wc (1));
	     bcd_chars = add_wc (2) * 6;		/* get address and word count of message */
	     call tolts_util_$bci_to_ascii (bcd_str, out_str, bcd_chars);
						/* convert bcd */
	     call ioa_ (" ^a", out_str);		/* print on terminal */
	     go to cont_pas;
	  end;
	  else if action.err then do;			/* if beginning of new message */
	     call complete_err_mess;			/* complete old one */
	     mess_in_prog = "1"b;			/* indicate an unfinished error message */
	     mtype = 1;				/* set message type flag to start of message */
	     if ^run then do;			/* if run option not in force */
	        call ioa_ ("^/*** an error has occurred ***^/");
						/* let user know about error */
	     end;
	  end;
	  else mtype = 2;				/* must be intermediate message */
	  call isolts_err_log_$write (mptr, mlen, mtype, cpu_tag, scu_tag);
         end;
         else do;					/* write it to users terminal for now */
	  bcd_chars = mlen * 6;			/* get word count of message */
	  call tolts_util_$bci_to_ascii (bcd_str, out_str, bcd_chars);
						/* convert bcd */
	  if ^bf_sw then do;			/* if not in brief mode */
	     call ioa_ ("^[^/^]^a", car_nz, out_str);	/* display message for user */
	     car_nz = "0"b;				/* reset carriage position switch */
	  end;
         end;
         go to cont_pas;				/* perform non local goto */
      end;

   end interpret_action;

%page;

/* enter_options - internal procedure to enter pas2 or isolts options and check for legality */

enter_options: proc;

      add_opt = "";					/* pad additional option  with blanks */
      mptr = ptr (wseg_p, add_wc (1));			/* get ptr to return options string */
      eopt = opt_mess;				/* set enter options label */
      if dump_in_prog then do;			/* dumping and we get here, means we are ready to dump */
         idump = "0"b;				/* octal from the Multics side */
         call isolts_err_log_$dump (d_type, addrel (wseg_p, first), last,
	2, cpu_tag, scu_tag);			/* dump it */
         idump, ntype, dump_in_prog = "0"b;		/* dump finsihed, reset flags */
         go to opt_mess;				/* and go to enter options */
      end;
      if ntype then do;				/* if we are forcing seq option */
         ntype = "0"b;				/* reset it so we don't come back */
         bcd_chars = 6;
         call tolts_alm_util_$ascii_to_bci_ ("seq", bcd_str);
						/* convert ascii to bcd */
         go to cont_pas;				/* and return to pas2 exec */
      end;

reenter:
      call tolts_util_$query (" ", com_string, c_len, args, cmd_cnt);
      if cmd_cnt = 0 then do;				/* if user typed NL char */
         option = "0"b;				/* reset options flag */
         go to cont_pas;				/* return to pas2 at point interrupted */
      end;

/* check for ISOLTS only options first */

      if option then do;				/* execute only if options request */
         if ck_isolts_opt () then			/* if isolts option, it has already been done */
	  go to opt_mess;				/* go to options again */
         else do;					/* must be pas2 option, check them for legality */
	  k = 0;
	  trm1 = "0"b;
	  if cmd_cnt > 0 then do;
	     do i = 1 to cmd_cnt while (^trm1);
	        if length (args (i)) > 2 then do;
		 if substr (args (i), 1, 3) = "prg"
		  | substr (args (i), 1, 3) = "tst" then
		    k = i;			/* set flag for later */
	        end;
	        else
		 do j = 1 to hbound (illegal_pas_opt, 1) while (^trm1);
		 if args (i) = illegal_pas_opt (j) then
		    trm1 = "1"b;			/* if illegal option */
	        end;
	     end;
	  end;
	  if trm1 then do;				/* if user has entered options not supported by ISOLTS */
	     call com_err_ (0, pname, "^a option not supported by ^a", args (i - 1), pname);
opt_mess:	     call ioa_$nnl ("^a", out_str);
	     go to reenter;
	  end;
	  if k ^= 0 then do;			/* if "prgxxx" or "tstxxx" option specified */
	     do i = 1 to hbound (inv_tst_ids, 1) while (substr (args (k), 4, 3) ^= inv_tst_ids (i));
	     end;
	     if i <= hbound (inv_tst_ids, 1) then do;	/* found bad tst id */
	        call com_err_ (0, pname, "^a not supported by ^a",
	         args (k), pname);
	        go to opt_mess;			/* let user try again */
	     end;
	  end;
	  if add_opt ^= "" then			/* if additional option */
	     com_string = rtrim (com_string) || " " || add_opt; /* add it to end */
	  if index (com_string, "run") ^= 0 then	/* if run option specified */
	     run = "1"b;
	  if index (com_string, "halt") ^= 0 then run = "0"b; /* reset run if halt option */
	  if index (com_string, "reset") ^= 0 then do;	/* if reset option */
	     run = "0"b;				/* reset run flag */
	     p_err = "1"b;				/* set print error flag */
	  end;
	  option = "0"b;				/* reset option flag */
         end;
      end;
      bcd_chars = length (rtrim (com_string));		/* get exact options string length */
      if mod (bcd_chars, 6) ^= 0
       then					/* if not already mod 6 */
         bcd_chars = bcd_chars + (6 - mod (bcd_chars, 6));	/* make output mod 6 */
      call tolts_alm_util_$ascii_to_bci_ (com_string, bcd_str); /* convert it to bcd */
      go to cont_pas;				/* perform non_local goto */

   end enter_options;



%page;

/* clean_up - internal procedure to establish a cleanup and finish condition handler */

clean_up: proc;

      if isolate_cpu then do;				/* if cleanup flag set */
         call tandd_$destroy_cpu_test_env;
         isolate_cpu = "0"b;				/* reset flag */
      end;
      if df_iocbp ^= null then do;			/* detach deck file if attached */
         call iox_$close (df_iocbp, code);
         call iox_$detach_iocb (df_iocbp, code);
         df_iocbp = null;
      end;

   end clean_up;

/* sw_mess_1, sw_mess_2 - subroutines to set up read switch error diagnostics */

sw_mess_1: proc (arg, mess);

dcl  (arg, mess) char (*);

      arg = rtrim (arg) || NL || mess;
      return;

sw_mess_2: entry (arg, mess);

      arg = rtrim (arg) || NL || "memory " || tags (i) || " " || mess;
      return;

   end sw_mess_1;

%page;

/* sleep - internal procedure to put process to sleep for specified time period */

sleep: proc (t_delay);

dcl  (t_delay, i) fixed bin;
dcl  tm_delay fixed bin (71);

      tm_delay = t_delay;
      do i = 1 to delay_iter while (is_mbx.service = 0);	/* loop until service requested or time out */
         call timer_manager_$sleep (tm_delay, "11"b);	/* sleep for specified seconds */
      end;

   end sleep;

/* complete_err_mess - internal subroutine to check if an error message is in progress and complete it */

complete_err_mess: proc;

      if ^pas_sw then				/* if still in primitives */
         if nxt_tst >= pas_exec then			/* set pas switch if in pas exec or pas pgm */
	  pas_sw = "1"b;
      if mess_in_prog then do;			/* if error message in progress */
         mess_in_prog = "0"b;				/* reset flag */
         call isolts_err_log_$write (null, 0, 3, 0, 0);	/* complete it */
      end;
   end complete_err_mess;

/* set_survey - internal procdure to set up system survey table */

set_survey: proc;

      delay = pft_delay;				/* set up pft delay value */
      iom0.mbx = "001400"b3;				/* set up iom 0 mailbox address */
      cont_cpu.f_vec, cpu_1.f_vec = "000100"b3;		/* set up fault vector address */
      iom0.port, cont_cpu.port, cpu_1.port = cpu_port;	/* set port number */
      imw.base = "001200"b3;				/* set interrupt multiplexor base */

   end set_survey;

%page;

/* itrace - internal procedure to trace action codes and time */

itrace: proc;

      tim = time;					/* get current time */
      call ioa_ ("^a.^a - action code = ^12.3b", substr (tim, 1, 4),
       substr (tim, 5, 3), string (action_codes));
   end itrace;

/* ck_isolts_opt - internal procedure to check and perform isolts only options */

ck_isolts_opt: proc returns (bit (1));

      if args (1) = "quit" | args (1) = "q" then do;	/* user wants to quit */
         trm = "1"b;				/* set terminate condition */
         go to end_pas;				/* perform non-local goto */
      end;
      else if args (1) = "restart" then			/* user wants to restart from PFTs */
         go to restart;				/* perform non-local goto */
      else if args (1) = "itrace_on"
       | args (1) = "itn" then			/* user wants to turn on trace */
         trace_sw = "1"b;
      else if args (1) = "itrace_off"
       | args (1) = "itf" then			/* user wants to turn trace off */
         trace_sw = "0"b;
      else if args (1) = "type"
       | args (1) = "atype" then do;			/* type messages */
         p_err = "0"b;				/* reset dprint error switch */
         if args (1) = "type" then			/* pas2 still thinks he */
	  add_opt = "print";			/* is going to printer */
         else add_opt = "aprint";
      end;
      else if args (1) = "print"
       | args (1) = "aprint" then do;			/* dprint messages */
         p_err = "1"b;				/* set dprint error switch */
         add_opt = args (1);				/* set additional option */
      end;
      else if args (1) = "test"
       & args (2) = "msg" then			/* user wants to communicate with the operator */
         call tolts_util_$opr_msg;
      else if args (1) = "display_error"
       | args (1) = "display"
       | args (1) = "derr" then do;			/* display error message */
         if ^display_log () then do;			/* go display requested log entries */
inv_display:
	  call com_err_ (0, pname, "invalid input - ""^a""", com_string);
	  return ("1"b);				/* reneter options */
         end;
      end;
      else if args (1) = "E" then do;			/* user wants to execute Multics command */
         com_string = ltrim (substr (com_string, 2));
         call cu_$cp (addr (com_string), length (com_string), code);
						/* execute Multics command */
      end;
      else if args (1) = "cdump" | args (1) = "mdump"
       | args (1) = "xdump" | args (1) = "sdump" then do;
         first = 0;					/* set defaults */
         last = 65535;
         d_type = args (1);
         if cmd_cnt > 1 then do;			/* if we have offset */
	  first = cv_oct_check_ ((args (2)), code);	/* convert offset arg */
	  if code ^= 0 | first > 65535 then		/* tell user what he typed wrong */
	     go to inv_display;
	  last = last - first;			/* adjust length */
	  if cmd_cnt > 2 then do;			/* if length arg supplied */
	     last = cv_oct_check_ ((args (3)), code);
	     if code ^= 0 | first + last > 65536 then	/* tell user what he typed wrong */
	        go to inv_display;
	  end;
         end;
         if args (1) = "cdump" then do;			/* if console dump requested */
	  call ioa_ ("^/^a ""cdump"" from ^o to ^o of cpu ^a using memory ^a^/",
	   pname, first, last + first, tags (cpu_tag), tags (scu_tag));
	  call dump_segment_ (iox_$user_output, addrel (wseg_p, first), 0, first, last, "01000000000"b);
	  dump_in_prog = "0"b;			/* entire cdump done from Multics side */
	  return ("1"b);				/* return for next option */
         end;
         else if args (1) = "sdump" then do;		/* if slave dump to be taken */
	  first = fixed (rel (hdr_p), 17);		/* set first to slave base */
	  last = fixed (slave_hdr.pgm_size, 17);	/* dump this many words */
	  if last = 0 then do;			/* no slave program loaded */
	     call ioa_ ("slave program not loaded");	/* tell user */
	     return ("1"b);				/* and return for next option */
	  end;
	  else if last > hbound (wseg.test_pgm, 1) then	/* in case there is garbage here */
	     last = hbound (wseg.test_pgm, 1) - 1;	/* set it to last loc in wseg */
         end;
         dump_in_prog, ntype, idump = "1"b;		/* set flags */
         return ("0"b);				/* let pas2 handle first part of dump */
      end;
      else return ("0"b);				/* not isolts option, go process pass options */
      return ("1"b);				/* isolts option has been processed */

   end ck_isolts_opt;

%page;

/* opr_com - internal procedure to relay manual reconfiguration intructions to operator */

opr_com: proc (icpu, iscu) returns (bit (1));

dcl  (icpu, iscu) fixed bin (5);
dcl  timer_manager$sleep entry (fixed bin (71), bit (2));
dcl  d fixed bin (71) init (1);

      opr_query_info.q_sw = "1"b;			/* must wait for opr to grant or deny permission */
      opr_query_info.prim = "grant";			/* set primary expected response */
      opr_query_info.alt = "deny";			/* set alternate expected response */
      opr_query_info.r_comment = "";
      call ioa_ ("asking operators permission to test cpu ""^a"" using memory ""^a""", tags (icpu), tags (iscu));
      call opr_query_ (addr (opr_query_info),
       "permission asked to test cpu ""^a"" using memory ""^a""", tags (icpu), tags (iscu));
      if opr_query_info.answer = "deny" then do;		/* if opr doesn't want us to use cpu */
         call ioa_ ("permission denied");		/* tell user the sad news */
         return ("1"b);				/* return and indicate denial */
      end;
      call ioa_ ("permission granted");			/* operator says it ok to test cpu */
      call ioa_ ("asking operator to manually reconfigure cpu ^a", tags (icpu));
      opr_query_info.q_sw = "0"b;			/* no operator response needed */
      call opr_query_ (addr (opr_query_info),
       "execute the following manual reconfiguration on cpu ""^a"":", tags (icpu));
      call timer_manager_$sleep (d, "11"b);		/* To prevent console messages from getting out of sync */
      call opr_query_ (addr (opr_query_info),
       " 1. set all port and initialize enable switches and interlace switches to off.");
      call timer_manager_$sleep (d, "11"b);		/* To prevent console messages from getting out of sync */
      if cpu_type = "dps8"
       then
         call opr_query_ (addr (opr_query_info),
	" 2. set the assignment switches for all ports to 000.");
      else if cpu_type = "l68 "
       then
         call opr_query_ (addr (opr_query_info),
	" 2. set all port assignment switches to 000 and the size switches to full");
      call timer_manager_$sleep (d, "11"b);		/* To prevent console messages from getting out of sync */
      if cpu_type = "dps8" then
         call opr_query_ (addr (opr_query_info),
	" 3. set store size switches to 2222.");
      else if cpu_type = "l68 "
       then
         call opr_query_ (addr (opr_query_info),
	" 3. remove the right free-edge connector on the 645pq wwb at slot ab28.");
      call timer_manager_$sleep (d, "11"b);		/* To prevent console messages from getting out of sync */
      if cpu_type = "dps8" then
         call opr_query_ (addr (opr_query_info),
	" 4. verify that the mode switch is in vms.");
      else if cpu_type = "l68 " then
         call opr_query_ (addr (opr_query_info),
	" 4. install the ""cpu test""  on the right free-edge connector at slot ab28.");
      call timer_manager_$sleep (d, "11"b);		/* To prevent console messages from getting out of sync */
      call opr_query_ (addr (opr_query_info),
       " 5. depress the initialize and clear push button.");
      call timer_manager_$sleep (d, "11"b);		/* To prevent console messages from getting out of sync */
      opr_query_info.q_sw = "1"b;			/* must wait for opr response */
      opr_query_info.prim = "done";			/* set primary expected response */
      opr_query_info.alt = "unable";			/* set alternate response */
      opr_query_info.r_comment = "when reconfiguration complete";
						/* set response comment */
      call opr_query_ (addr (opr_query_info),
       " 6. set the port enable switch ""on"" for port ""^a"".", tags (iscu));
      if opr_query_info.answer = "unable" then do;
         call ioa_ ("having problems reconfiguring");
         return ("1"b);
      end;

      else return ("0"b);				/* return and indicate manual reconfig complete */
   end opr_com;






%page;

/* display_log - internal procedure to display messages in the isolts_err_log */

display_log: proc returns (bit (1));

      if cmd_cnt = 1 then				/* if only last message wanted */
         count, limit = 1;
      else if cmd_cnt >= 2 & cmd_cnt < 4 then		/* count, limit or -all */
         if args (2) = "-all" then			/* print entire log */
	  count, limit = -1;
         else do;
	  count = cv_dec_check_ ((args (2)), code);	/* convert count */
	  if code ^= 0 then				/* must be dec number */
	     return ("0"b);				/* return error */
	  if cmd_cnt < 3 then			/* no limit specified, set to 1 */
	     limit = 0;
	  else do;
	     limit = cv_dec_check_ ((args (3)), code);
	     if code ^= 0 then			/* must be dec number */
	        return ("0"b);			/* return error */
	  end;
         end;
      else return ("0"b);				/* no more than 3 args allowed, return error */
      call isolts_err_log_$display (count, limit, p_err);	/* display requested err messages */
      return ("1"b);				/* return with no error */
   end display_log;

%page;

/* abort - internal subroutine to display reconfiguration error messages */

abort: proc (ecode);

dcl  ecode fixed bin (35);
dcl  (arg1, arg3, arg4) char (12);
dcl  arg2 char (128);

dcl  reconfig_err_message (17) char (64) static options (constant) init
      ("System dynamic reconfiguration in progress, try later", /* rcerr_isolts_locked */
      "cpu tag ^a is illegal",			/* rcerr_isolts_illegal_cpu */
      "cpu ^a is online and unavailable for test",	/* rcerr_isolts_cpu_online */
      "cpu ^a is not configured",			/* rcerr_isolts_no_config */
      "there must be at least two online scus to run isolts", /* rcerr_isolts_two_scu */
      "scu tag ^a is illegal",			/* rcerr_isolts_illegal_scu */
      "scu ^a is the bootload scu and cannot be used for testing", /* rcerr_isolts_bootload_scu */
      "scu ^a is not online",				/* rcerr_isolts_scu_not */
      "requesting process is not running isolts",		/* rcerr_isolts_not */
      "cpu ^a responded to interrupt cell ^a at loc ^a",	/* rcerr_isolts_wrong_cell */
      "cpu ^a responded to an interrupt cell ^a on scu ^a", /* rcerr_isolts_wrong_scu */
      "cpu ^a responded to an interrupt cell ^a on scu ^a at loc ^a", /* rcerr_isolts_wrong_scu_cell */
      "cpu ^a failed to respond to an interrupt cell ^a interrupt", /* rcerr_isolts_no_response */
      "the following switches on cpu ^a are set incorrectly: ^a", /* rcerr_isolts_bad_switches */
      "a ""lda 2"" did not operate properly",		/* rcerr_isolts_lda_fail */
      "a ""lda 65536"" (64k) failed to produce a store fault", /* rcerr_isolts_no_str_flt */
      "scu ^a has no interrupt mask register assigned to cpu ^a"); /* rcerr_isolts_no_mask */

      call com_err_ (0, pname, "the following errors were detected while attempting reconfiguration:^/");
      if ecode > 17 then				/* if standard error code */
         call com_err_ (ecode, pname, "attempting reconfiguration");

      else do;					/* reconfig error message */
         arg1, arg2, arg3, arg4 = "";			/* initialize args */
         if ecode > 9 & ecode < 14 then do;		/* if codes 10 - 13 */
	  rswp = addr (switches (1));			/* set ptr to cpu switch data */
	  arg1 = tags (cpu_tag);			/* set cpu tag arg */
	  call ioa_$rsnnl ("^d", arg2, i, rswp -> switch_w1.cell); /* set int cell number */
	  if ecode > 10 & ecode < 13 then		/* if codes 11 or 12 */
	     arg3 = tags (scu_tag);			/* set scu_tag */
         end;
         go to etype (ecode);				/* go set up correct message */

etype (2):					/* rcerr_isolts_illegal_cpu */
etype (3):					/* rcerr_isolts_cpu_online */
etype (4):					/* rcerr_isolts_no_config */
         arg1 = tags (cpu_tag);			/* cpu tag only */
         go to display_err;				/* display message */

etype (6):					/* rcerr_isolts_illegal_scu */
etype (7):					/* rcerr_isolts_bootload_scu */
etype (8):					/* rcerr_isolts_scu_not */
         arg1 = tags (scu_tag);			/* scu_tag only */
         go to display_err;				/* display message */

etype (10):					/* rcerr_isolts_wrong_cell */
         call ioa_$rsnnl ("^o", arg3, i, rswp -> switch_w1.offset);
         go to display_err;				/* display message */

etype (12):					/* rcerr_isolts_wrong_scu_cell */
         call ioa_$rsnnl ("^o", arg4, i, rswp -> switch_w1.offset);
         go to display_err;				/* display message */

etype (17):					/* rcerr_isolts_no_mask */
         arg1 = tags (scu_tag);
         arg2 = tags (cpu_tag);
         go to display_err;				/* display message */

etype (14):					/* rcerr_isolts_bad_swiches */
         arg1 = tags (cpu_tag);
         rswp = addr (switches (2));
         if cpu_type = "l68 " then do;
	  if dps_rsw_2.fault_base then
	     call sw_mess_1 (arg2, "fault base");
	  if dps_rsw_2.cpu_num ^= 0 then
	     call sw_mess_1 (arg2, "processor number");
         end;
         else if cpu_type = "dps8" then do;
	  if dps8_rsw_2.fault_base then
	     call sw_mess_1 (arg2, "fault base");
	  if dps8_rsw_2.cpu_num ^= 0 then
	     call sw_mess_1 (arg2, "processor number");
         end;
         rswp = addr (switches (4));
         do i = 0 to 7;
	  if i < 4 then
	     pip = addr (addr (switches (1)) -> rsw_1_3.port_info (i));
	  else pip = addr (addr (switches (3)) -> rsw_1_3.port_info (i - 4));

	  if pi.port_assignment then
	     call sw_mess_2 (arg2, "port assignment");
	  if pi.port_enable then
	     call sw_mess_2 (arg2, "port enable");
	  if pi.initialize_enable then
	     call sw_mess_2 (arg2, "initialize enable");
	  if pi.interlace_enable | rsw_4.four (i) then
	     call sw_mess_2 (arg2, "interlace");
	  if pi.mem_size ^= 0 then
	     call sw_mess_2 (arg2, "size");
	  if rsw_4.half (i) then
	     call sw_mess_2 (arg2, "half/full");
         end;

         go to display_err;				/* display_message */

etype (1):					/* rcerr_isolts_locked */
etype (5):					/* rcerr_isolts_two_scu */
etype (9):					/* rcerr_isolts_not */
etype (11):					/* rcerr_isolts_wrong_scu */
etype (13):					/* rcerr_isolts_no_response */
etype (15):					/* rcerr_isolts_lda_fail */
etype (16):					/* rcerr_isolts_no_str_flt */

display_err: call com_err_ (0, pname, reconfig_err_message (ecode), arg1, arg2, arg3, arg4);

      end;



   end abort;

%page;

%include rcerr;
%include rsw;
%include opr_query_info;
%include gload_data;

%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:   <Person>.<Project>.a: permission asked to test cpu <cpu_tag> using memory <mem_tag>

   S:  $beep

   T:  $run

   M:  <person>.<Project> is asking permission to test the indicated cpu that
   is currently deconfigured from the system. The indicated memory will be usurped
   until a primitive test is made on the processor to verify switch settings and
   to assure that a memory address above 64k cannot be generated without a store fault
   occurring. After this primitive test is complete, all memory in the indicated
   SCU above 64k will be given back to the system.
   Until processor testing is completed, the reconfiguration data base is locked
   thereby not allowing dynamic reconfiguration of processors, memories,
   or bulk store.

   A:  $info

   Message:   <Person>.<Project>.a: respond "grant" or "deny".

   S:  $beep

   T:  $run

   M:  <Person>.<Project> is expecting an operator response to either grant or
   deny  permission to test the indicated processor.
   The indicated response must be made via the opr_query_response command.

   A:  Operator must respond "grant" or "deny" via the opr_query_response command
   (or with the oqr entry in the admin ec; e.g. x oqr grant) to either grant or deny the test request.

   Message:   <Person>.<Project>.a: execute the following manual reconfiguration on cpu <tag>:

   S:  $beep

   T:  $run

   M:  <person>.<Project> is asking the operator to manually reconfigure
   the indicated processor.

   A:  $ignore

   Message:   <Person>.<Project>.a:  1. set all port and initialize enable switches to off.

   S:  $beep

   T:  $run

   M:  The first step of the manual reconfiguration instructions.

   A:  $ignore

   Message:   <Person>.<Project>.a:  2. set the assignment switches for all ports to 000.

   S:  $beep

   T:  $run

   M:  The second step of the manual reconfiguration instructions.

   A:  $ignore

   Message:   <Person>.<Project>.a:  3. remove the right free-edge connector on the

   S:  $beep

   T:  $run

   M:  The third step of the manual reconfiguration instructions.
   The indicated free-edge connector contains the port size plugs
   (maximum of 4) for the configured SCU ports.

   A:  $ignore

   Message:   <Person>.<Project>.a:     645pq wwb at slot 28l.

   S:  $beep

   T:  $run

   M:  Continuation of above message.

   A:  $ignore

   Message:   <Person>.<Project>.a:  4. install the "cpu test" free-edge connector at slot 28l.

   S:  $beep

   T:  $run

   M:  The fourth step of the manual reconfiguration instructions.
   The "cpu test" free-edge connector referred to is a special tool
   provided by Field Engingeering. It is simply a port free-edge connector with
   all 4 port groups wired for 64k.

   A:  $ignore

   Message:   <Person>.<Project>.a:  5. depress the initialize and clear push button.

   S:  $beep

   T:  $run

   M:  The fifth step of the manual reconfiguration instructions.

   A:  $ignore

   Message:   <Person>.<Project>.a:  6. set the port enable switch on for port <mem_tag>.

   S:  $beep

   T:  $run

   M:  The sixth and last step of the manual reconfiguration instructions.

   A:  $ignore

   Message:   <Person>.<Project>.a: respond "done" when reconfiguration complete.

   S:  $beep

   T:  $run

   M:  The indicated response must be made via the opr_query_response command.

   A:  Operator must respond "done" via the opr_query_response command
   (x oqr done), when reconfiguration is complete.

   END MESSAGE DOCUMENTATION */

   end isolts_;




		    isolts_err_log_.pl1             10/28/88  1413.0r w 10/28/88  1302.2      184734



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


isolts_err_log_: proc;

/* isolts_err_log_ - a group of subroutines that maintain the isolts_err_log */
/* initially coded by James A. Bush 6/78 */

/* External entries */

dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1),
     fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5),
     ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$set_max_length_seg entry (ptr, fixed bin (19), 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  date_time_ entry (fixed bin (71), char (*));
dcl  dprint_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  user_info_ entry (char (*), char (*), char (*));
dcl  dump_segment_ entry (ptr, ptr, fixed bin, fixed bin, fixed bin, bit (*));
dcl  get_default_wdir_ entry returns (char (168));
dcl (com_err_, ioa_$ioa_switch) entry options (variable);
dcl  clock_ entry returns (fixed bin (71));
dcl  tolts_util_$bci_to_ascii entry (bit (*), char (*) varying, fixed bin);

/* External static */

dcl  error_table_$noentry fixed bin (35) ext;
dcl  iox_$user_output ptr ext;

/* Automatic */

dcl (i, j, first, cnt, lim) fixed bin;			/* do loop cnters */
dcl  tlog char (24);
dcl (uname, uproj, uacct) char (32);
dcl  out_str char (136) varying;
dcl  dump_str char (136);
dcl  cd_type char (5);
dcl  code fixed bin (35);
dcl  tptr ptr;
dcl (term, first_printed) bit (1);
dcl  format bit (11);

/* internal static */

dcl (efp, mep, imep, iocbp) ptr int static;		/* ptr to our error file */
dcl  hdir char (168) int static;
dcl  sname char (32) int static;
dcl  mes_begin bit (1) int static;			/* message begin flag */
dcl (s_att, s_open) bit (1) int static init ("0"b);	/* flags for file attachment and opening */

/* Entry parameters */

dcl  rcode fixed bin (35);				/* standard system error rcode */
dcl  mptr ptr;					/* ptr to message text */
dcl  mlen fixed bin;				/* word length of message */
dcl  mtype fixed bin (2);				/* type of message */
dcl (cput, scut) fixed bin (5);			/* cpu and scu tags of cpu in error */
dcl  a_cnt fixed bin;				/* cnt of log entrieds to display */
dcl  a_lim fixed bin;				/* if not = 0 then the number to display from cnt */
dcl  dp_sw bit (1);					/*  = "0"b then display on user's term, = "1"b then dprint */
dcl  d_type char (5);				/* type of dump */

/* Builtins */

dcl (addr, addrel, fixed, floor, length, null, ptr, substr, rel, rtrim, unspec) builtin;

/* Structures */

dcl 1 ilog based (efp) aligned,			/* definition of isolts_err_log */
    2 len fixed bin (35),				/* length of message buffer area in chars */
    2 version fixed bin,				/* version of this log (1) */
    2 first bit (18) unaligned,			/* relative address of first message in log */
    2 last bit (18) unaligned,			/* relative address of last message in log */
    2 init_wd char (4),				/* = "INIT" if log has been initialized */
    2 time_init fixed bin (71),			/* clock time log was initialized */
    2 nxt_seq fixed bin (35),				/* next message sequence numbr */
    2 first_mess bit (1) unaligned,			/* if = "0"b, log is empty */
    2 pad1 bit (35) unaligned,
    2 buffer char (0 refer (ilog.len)),			/* message buffer */
    2 end_buf char (1);				/* end of error file */

dcl 1 ilog_mess based (mep) aligned,			/* format of message entry */
   (2 next bit (18),				/* fwd and backward message threads */
    2 prev bit (18),
    2 mess_complete bit (1),				/* = "1"b if this is a completeed message */
    2 cpu_tag fixed bin (5),				/* tag of cpu generating error message */
    2 scu_tag fixed bin (5),				/* tag of scu being used for cpu test */
    2 pad1 bit (2),
    2 type fixed bin (2),				/* 1 = begin, 2 = intermediate, 3 = end message */
    2 txt_len fixed bin,				/* length of message in characters */
    2 time_logged fixed bin (71),			/* clock time message logged */
    2 seq_num fixed bin (35),				/* message sequence number */
    2 next_full bit (18),				/* ptr to nxt full message */
    2 pad2 bit (18),
    2 text char (0 refer (ilog_mess.txt_len))) unaligned,	/* message text */
    2 nxt_mess char (1);				/* means of spacing to next message */

dcl 1 ilog_imess based (imep) aligned,			/* format of intermediate message entry */
   (2 next bit (18),				/* fwd and backward message threads */
    2 prev bit (18),
    2 pad1 bit (15),
    2 type fixed bin (2),				/* 1 = begin, 2 = intermediate, 3 = end message */
    2 txt_len fixed bin,				/* length of message in characters */
    2 text char (0 refer (ilog_imess.txt_len))) unaligned,	/* message text */
    2 nxt_imess char (1);				/* means of spacing to next message */


/* Constants */

dcl  cleanup condition;
dcl  pname char (6) int static options (constant) init
    ("isolts");
dcl  tags (0 : 7) char (1) static options (constant) init
    ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  NL char (1) int static options (constant) init ("
");
dcl  NP char (1) int static options (constant) init ("");

/* init - entry to initiate or create at first reference the isolts_err_log */

init:	entry (rcode);

	rcode = 0;				/* preset return code */
	mes_begin = "0"b;				/* reset message begin flag */
	hdir = get_default_wdir_ ();			/* get our home dir name */

/* now get a pointer to our error message file */

	call hcs_$initiate (hdir, "isolts_err_log", "", 0, 1, efp, code);
	if efp = null then				/* if error */
	     if code = error_table_$noentry then do;	/* does not exist */
		call com_err_ (0, pname, "Creating ^a>isolts_err_log", hdir);
		call hcs_$make_seg (hdir, "isolts_err_log", "", 01010b, efp, code);
		if efp = null then do;		/* you can't win */
		     call com_err_ (code, pname, "Attempting to create ^a>isolts_err_log", hdir);
		     rcode = code;
		     return;
		end;
ilog_init:
		call hcs_$set_max_length_seg (efp, 65536, code); /* set max length to 64k */
		if code ^= 0 then do;
		     call com_err_ (code, pname, "Setting max length of ^a>isolts_err_log to 64k", hdir);
		     rcode = code;
		     return;
		end;
		call hcs_$set_bc_seg (efp, 65536 * 36, code); /* set bit cnt to 64k */
		if code ^= 0 then do;
		     call com_err_ (code, pname, "Setting bit cnt of ^a>isolts_err_log to 64k", hdir);
		     rcode = code;
		     return;
		end;

/* now lets set up the log header */

		ilog.len = (65536 - fixed (rel (addr (ilog.buffer)))) * 4; /* set buffer length */
		ilog.version = 1;			/* version of this log is 1 */
		ilog.first, ilog.last = rel (addr (ilog.buffer)); /* set first and last message ptrs */
		ilog.nxt_seq = 0;			/* start with a sequence number of 0 */
		ilog.buffer = "";			/* pad message buffer with blanks */
		ilog.first_mess = "0"b;		/* reset first message flag */
		ilog.time_init = clock_ ();		/* get clock time */
		ilog.init_wd = "INIT";		/* set init word */
		return;
	     end;
	     else do;
		call com_err_ (code, pname, "Initiating ^a>isolts_err_log", hdir);
		rcode = code;
		return;
	     end;
	if ilog.init_wd ^= "INIT" then do;		/* if error file inconsistant */
	     call com_err_ (0, pname, "^a>isolts_err_log is inconsistant, reinitializing", hdir);
	     go to ilog_init;
	end;
	return;

/*  */

/* write - entry to write message entries into the isolts_err_log */

write:	entry (mptr, mlen, mtype, cput, scut);

	go to mess_type (mtype);			/* execute desired code */

mess_type (1):					/* message begining */

	mes_begin = "1"b;				/* set message begining flag */
	if ^ilog.first_mess then do;			/* if we haven't written to log before... */
	     mep = addrel (efp, ilog.first);		/* start at begining */
	     ilog_mess.prev = "0"b;			/* and set prev ptr to 0 */
	     ilog.first_mess = "1"b;			/* set first message flag */
	end;
	else do;					/* otherwise go to next message loc */
	     mep = addrel (efp, ptr (efp, ilog.last) -> ilog_mess.next_full);
	     ilog_mess.prev = ilog.last;		/* set prev ptr to last message complete */
	end;
	ilog_mess.mess_complete = "0"b;		/* reset message complete flag */
	ilog_mess.time_logged = clock_ ();		/* set the time */
	ilog_mess.seq_num = ilog.nxt_seq;		/* set sequence number */
	if unspec (ilog.nxt_seq) = "377777777777"b3 then do; /* do not overflow seq number  */
	     call com_err_ (0, pname, "Error message log sequence number has reached max value of ^d, resetting to 0",
		ilog.nxt_seq);
	     ilog.nxt_seq = 0;			/* reset sequence number */
	end;
	else ilog.nxt_seq = ilog.nxt_seq + 1;		/* otherwise just increment it by one */
	ilog_mess.cpu_tag = cput;			/* set cpu and scu tags */
	ilog_mess.scu_tag = scut;
	ilog_mess.type = 1;				/* set start message type */
	ilog_mess.txt_len = cv_wmess (addr (ilog_mess.text)); /* go convert, and store message */
	ilog_mess.next = rel (addr (ilog_mess.nxt_mess)); /* set next message ptr */
	imep = null;				/* and null out intermediate message ptr */

	return;					/* thats it */

mess_type (2):					/* intemediate message */

	if ^mes_begin then do;			/* something is wrong */
	     call com_err_ (0, pname, "Attempting to write intermediate message entry before beginning of message");
	     return;
	end;
	if imep = null then do;			/* if first intermediate message */
	     imep = addrel (efp, ilog_mess.next);	/* set it */
	     ilog_imess.prev = rel (mep);		/* set prev ptr to start message entry */
	end;
	else do;					/* else go from lst intermediate message */
	     tptr = addr (ilog_imess.nxt_imess);	/* set temp ptr */
	     if wrap (tptr) then do;			/* if buffer wrap around */
		tptr = addrel (efp, ilog.first);	/* reset temp ptr to start of buffer */
		ilog_imess.next = rel (tptr);		/* and change thread from last message */
	     end;
	     tptr -> ilog_imess.prev = rel (imep);	/* set prev thread */
	     imep = tptr;				/* and copy ptr */
	end;
	ilog_imess.type = 2;			/* set intermediate type */
	ilog_imess.txt_len = cv_wmess (addr (ilog_imess.text)); /* go convert and write message */
	ilog_imess.next = rel (addr (ilog_imess.nxt_imess)); /* set next ptr */

	return;					/* and return */

mess_type (3):					/* end message */

	mes_begin = "0"b;				/* reset message begin flag */
	ilog_mess.mess_complete = "1"b;		/* and set message complete flag */
	if imep = null then do;			/* if only 1 message entry in this message */
	     tptr = addr (ilog_mess.nxt_mess);
	     ilog_mess.type = 3;			/* set type in main messae to end */
	end;
	else do;
	     tptr = addr (ilog_imess.nxt_imess);	/* if there were intermediate messages */
	     ilog_imess.type = 3;			/* set type in intermeditate message to end */
	end;
	if wrap (tptr) then do;			/* check for wrap around */
	     ilog_mess.next_full = ilog.first;		/* set next message back to start of buffer */
	     if imep ^= null then			/* if intermediate messages */
		ilog_imess.next = ilog.first;		/* set thread to beginning of buffer */
	     else ilog_mess.next = ilog.first;		/* otherwise set tread of maj. message */
	end;
	else do;
	     if substr (rel (tptr), 18, 1) then		/* if odd address */
		tptr = addrel (tptr, 1);		/* make even */
	     ilog_mess.next_full = rel (tptr);		/* no wrap nedded, set to next one in buffer */
	end;
	ilog.last = rel (mep);			/* set last pointer */

	return;					/* and return */

/*  */

/* display - entry to display requested isolts_err_log entries either on user's terminal or queue a dprint */

display:	entry (a_cnt, a_lim, dp_sw);

	if ^ilog.first_mess then do;			/* log is empty */
	     call com_err_ (0, pname, "Error log file is empty");
	     return;
	end;
	cnt = a_cnt;				/* copy parameters */
	lim = a_lim;
	s_att, s_open = "0"b;			/* reset flags */
	if dp_sw then				/* if user wants log entries dprinted... */
	     call attach_file ("ilog", "0"b);		/* go attach print file */
	else iocbp = iox_$user_output;		/* else put it out to terminal */
	on cleanup call clean_up;			/* establish a cleanup handler */
	if cnt = 0 then				/* set defaults */
	     cnt = 1;
	else if cnt = -1 then
	     cnt = 100000;				/* set to big number to make sure we get all */
	if lim = 0 | lim = -1 then
	     lim = 1;
	else lim = cnt - lim;

	first_printed, term = "0"b;			/* reset terminate condition, and first page flag  */
	mep, tptr = addrel (efp, ilog.last);		/* preset ptrs */

	do i = 1 by 1 while (i ^= cnt + 1 & ^term);	/* go backwards to desired number of entries */
	     mep = tptr;				/* set mep to last valid message */
	     if ilog_mess.prev = "0"b then		/* if we come to first message */
		term = "1"b;
	     else tptr = addrel (efp, ilog_mess.prev);	/* otherwise go to prev mess */
	     if tptr -> ilog_mess.next_full ^= rel (mep) | /* if threads do not match up */
	     ilog_mess.prev ^= rel (tptr) then term = "1"b; /* quit */
	end;

/* now go forward through desired number of message entries */

	do j = i-2 to lim by -1;
	     if ilog_mess.mess_complete then do;	/* display only if complete message */
		call date_time_ ((ilog_mess.time_logged), tlog); /* convert date and time */

/* output isolts message header first */

		call ioa_$ioa_switch (iocbp,
		     "^[^|^]^a error message sequence # ^d logged at ^a for cpu ^a using memory ^a",
		     first_printed, pname, ilog_mess.seq_num, tlog,
		     tags (ilog_mess.cpu_tag), tags (ilog_mess.scu_tag));
		term = "0"b;
		first_printed = "1"b;		/* set first page printed flag */
		imep = mep;			/* set ptr equal */

/* now output each message entry */

		do while (^term);
		     if imep = mep then do;		/* if first message entry */
			out_str = ilog_mess.text;	/* copy message text */
			if substr (out_str, 1, 1) = NP then /* if form feed */
			     out_str = substr (out_str, 2); /* get rid of it */
			call ioa_$ioa_switch (iocbp, "^a", out_str); /* output primary message entry */
		     end;
		     else call ioa_$ioa_switch (iocbp, "^a", ilog_imess.text); /* output inter. message entry */
		     if ilog_imess.type = 3 then	/* if end message */
			term = "1"b;		/* this is the last text for this message */
		     else imep = addrel (efp, ilog_imess.next); /* increment  intermediate message ptr */
		end;
	     end;
	     mep = addrel (efp, ilog_mess.next_full);	/* increment message ptr */
	end;
	if dp_sw then				/* if dprinting file */
	     call prt_queue ("ILOG", "0"b);		/* go queue it up */
	return;

/*  */

/* dump - entry to output dumps to a dump file for dprinting */

dump:	entry (d_type, mptr, mlen, mtype, cput, scut);

	if mtype = 1 then do;			/* output text a line at a time */
	     if ^s_att & ^s_open then do;		/* if first time throutgh */
		call attach_file (d_type, "1"b);	/* attach and open print file */
		on cleanup call clean_up;		/* establish a cleanup condition handler */
		call ioa_$ioa_switch (iocbp, "^3-*** ^a ^a of cpu ^a using memory ^a ***^/",
		     pname, d_type, tags (cput), tags (scut)); /* output header line */
	     end;
	     i = cv_wmess (addr (dump_str));		/* go convert message to ascii */
	     if substr (dump_str, 1, 1) = NP then	/* if form feed */
		dump_str = substr (dump_str, 2);	/* get rid of it */
	     call ioa_$ioa_switch (iocbp, "^a", dump_str); /* and store in dump file */
	end;
	else do;					/* output requested octal dump to dump file */
	     call ioa_$ioa_switch (iocbp, "^2/");	/* skip 2 lines */
	     if d_type = "mdump" then do;
		cd_type = "MDUMP";			/* form dype in all caps */
		format = "01000100000"b;		/* rel address only, long form */
		first = fixed (rel (mptr), 17);
	     end;
	     else if d_type = "sdump" then do;
		cd_type = "SDUMP";
		format = "11000100000"b;		/* abs and rel addresses, long form */
		first = 0;			/* relative address begines at 0 */
	     end;
	     else do;
		cd_type = "XDUMP";
		format = "11000100000"b;		/* abs and rel addresses, long form */
		first = 0;			/* relative address begines at 0 */
	     end;
	     call dump_segment_ (iocbp, mptr, 0, first, mlen, format);
	     call prt_queue (cd_type, "1"b);
	end;
	return;

/*  */

/* cv_wmess - internal function subroutine to convert bci message, store, and return length */

cv_wmess:	proc (str_ptr) returns (fixed bin);

dcl  str_ptr ptr;
dcl  in_str bit (mlen * 36) based (mptr);
dcl  bout_str char (136) based (str_ptr);

	     call tolts_util_$bci_to_ascii (in_str, out_str, mlen * 6); /* convert message */
	     if substr (out_str, length (out_str), 1) = NL then /* if trailing newline... */
		out_str = substr (out_str, 1, length (out_str) - 1); /* get rid of it */
	     if substr (out_str, 1, 1) = NL then	/* if leading newline... */
		out_str = substr (out_str, 2);	/* get rid of it */
	     bout_str = out_str;			/* copy results */
	     return (length (out_str));		/* and return length */

	end cv_wmess;

/* wrap - an internal function subroutine to check if the message buffer should be wrapped around */

wrap:	proc (limp) returns (bit (1));

dcl  limp ptr;
	     if fixed (rel (addrel (limp, 40))) > fixed (rel (addr (ilog.end_buf))) then
		return ("1"b);			/* buffer needs to be wraped */
	     else return ("0"b);			/* no need to wrap */

	end wrap;

/* clean_up - internal procedure to close and detach err file */

clean_up:	proc;

	     if s_open then do;			/* if file open */
		call iox_$close (iocbp, code);
		s_open = "0"b;
	     end;
	     if s_att then do;			/* if file attached */
		call iox_$detach_iocb (iocbp, code);
		s_att = "0"b;
		iocbp = null;
	     end;

	end clean_up;

/*  */

/* attach_file - internal procedure to attach and open stream file */

attach_file: proc (fname, ld_sw);

dcl  fname char (*);				/* either ilog or dump */
dcl  ld_sw bit (1);					/* "0"b = ilog, "1"b = dump */

	     sname = unique_chars_ (""b) || "." || fname; /* form unique name */
	     hdir = get_default_wdir_ ();		/* and get our home dir */
	     call iox_$attach_name ("err_file", iocbp, "vfile_ " || rtrim (hdir) || ">" || sname, null, code);
	     if code ^= 0 then do;			/* if some problem with attach */
		call com_err_ (code, pname, "Attempting to attach ^[dump^;error log^] file - ^a>^a",
		     ld_sw, hdir, sname);
		return;				/* get out now */
	     end;
	     s_att = "1"b;				/* indicate our seg is attached */
	     call iox_$open (iocbp, 2, "0"b, code);	/* open for stream output */
	     if code ^= 0 then do;
		call com_err_ (code, pname, "Attempting to open ^a>^a for stream_output", hdir, sname);
		call clean_up;			/* go detach file */
		return;
	     end;
	     s_open = "1"b;
	end attach_file;

/* prt_queue - internal procedure to queue up a dprint request for a error log file or dump file */

prt_queue: proc (rname, ld_sw);

dcl  rname char (*);				/* either "ERR RPT" or "ZDUMP" */
dcl  ld_sw bit (1);

	     call clean_up;				/* close and detach file */
	     call user_info_ (uname, uproj, uacct);	/* get users name and project */
	     out_str = rtrim (uname) || "." || rtrim (uproj); /* form desc line */
	     if length (out_str) < 10 then
		i = floor ((14 - length (out_str)) / 2); /* form center index */
	     else i = 1;				/* if name to long, start at collum 1 */
	     dpap = addr (dprint_arg_buf);		/* set dprint arg ptr */
	     dprint_arg.version = 1;			/* set appropriate args */
	     dprint_arg.copies = 1;
	     dprint_arg.delete = 1;
	     dprint_arg.queue = 3;			/* probably should be queue 1 */
	     dprint_arg.pt_pch = 1;
	     dprint_arg.notify = 1;			/* might want to make this 0 */
	     dprint_arg.output_module = 1;
	     dprint_arg.dest = "";
	     substr (dprint_arg.dest, i) = out_str;	/* set in person/project info */
	     if ld_sw then				/* if printing dump file */
		dprint_arg.heading = " for ISOLTS " || rname;
	     else dprint_arg.heading = " for ISOLTS ER RPT";
	     call dprint_ (hdir, sname, dpap, code);	/* queue it up */
	     call ioa_$ioa_switch (iox_$user_output,
		"^/^[dump^;error report^] file ^a has been queued for printing", ld_sw, sname);
	end prt_queue;

% include dprint_arg;

     end isolts_err_log_;




		    mtdsim_.pl1                     07/20/88  1306.3r w 07/19/88  1536.9     1649709



/****^  ************************************************************
        *                                                          *
        * Copyright, (C) Honeywell Information Systems Inc., 1983  *
        *                                                          *
        * Copyright, (C) Honeywell Information Systems Inc., 1980. *
        *                                                          *
        * Copyright (c) 1972 by Massachusetts Institute of         *
        * Technology and Honeywell Information Systems, Inc.       *
        *                                                          *
        ************************************************************ */





/* mtdsim_ - (Multics T & D Slave Interface Module) Procedure to drive the gcos T & D Modules
   known as slave mode polt and slave mode molt (and eventually slave mode colt)
   originally coded by J. K. Rhodes 4Q/1977
   extensive modification by J. A. Bush 9/78
   code added to drive slave mode molts by J. A. Bush 2/79
   initial release - MR7.0A
   Modified by J. A. Bush 12/79 for static mme handler and to handle new deckfile catalog format
   Modified by G. Haney & R. Fakoury  80/03/24 to handle mtar
   Modified by J. A. Bush 5/80 for several performance enhancements
   Modified by R. Fakoury 8/80 to handle the error return of "file not found" for a MME GCALL more cleanly.
   Modified by R. Fakoury 8/80 to handle dcw tally of 4096 correctly and to handle an incorrect density from rcp_.
   Modified by R. Fakoury 10/80 to set lostit_time = rcp_ max timeout.
   Modified by R. Fakoury 12/80 for colts implementation.
   Modified by R. Fakoury 10/81 to improve the quit handler.
   Modified by R. Fakoury 11/81 to attach the mpc for disk and tape mdrs.
   Modified by R. Fakoury 11/81 to dump the test exec when a machine fault is en countered.
   Modified by R. Fakoury 01/82 to allow more room for test colts test pages and to be more user friendly on bad test requests.
   Modified by R. Fakoury 03/17/82 to redesign mme allocr handler making it more effecient.
   Modified by R. Fakoury 04/82 to change mme feptype interface, to add a timer for colts attachments,
   add cleanner wrapup sequences for colts attach errors, and to add eurc pr54 support.
   Modified by R. Fakoury 09/30/82 to change illegal zero dcws to a valid single xfer dcw and output a message.
   Modified by R. Fakoury 11/01/82 to correct problem in Colts wrap-up & add 128 chan support.
   Modified by R. Fakoury 01/07/83 to increase the value of iom table words read from the fnp.
   Modified by R. Fakoury 01/21/83 to change the manner the tolts gets print train image to aggree with the way the system gets it.
   Modified by Rick Fakoury 03/16/83 to add a call to tolts_util_$get_ttl_date.
   Modified by R. Fakoury 09/83 to correct a 128chan bug.
   Modified by R. Fakoury 11/84 for hyperchan i/o.
   Modified by R.Fakoury 01/84 to accept multiple args & to implement a debugger for the slave execs.
   Modified by R Fakoury 04/84 to add a new field in sctcmp for DAU support, and to put a temp bypass for an ioi timing problem.
   Modified by R Fakoury 09/84 to correct a problem in get_px_tcx which caused io_sel to be invalid.
   Modified by R Fakoury & Benson Margulies 10/84 to correct problems encountered with new AS,
   to add more debugging functions, and to use convert_status_code instead of com_err.
*/





/****^  HISTORY COMMENTS:
  1) change(85-02-01,Fakoury), approve(86-08-20,MCR7514),
     audit(86-12-09,Martinson), install(86-12-09,MR12.0-1235):
      implement the test nio request (Dipper/MCA) with add debug aides,
      implement extented status store,
      further correct a problem in get_px_tcx,
      prevent returning to the subexec after a fault dump,
      support of a test rsp request (responder/DN8) with added debug aides,
      to dump machine conditions and history regs,
      to increase the bar value,
      to increase the timeout time for printer mdrs,
      to correct a problem encountered while attempting an attach for colts,
      to correct poorly written error messages.
  2) change(86-12-18,Fakoury), approve(86-12-18,MCR7514),
     audit(86-12-18,Martinson), install(86-12-19,MR12.0-1252):
     PBF to correct an error in MME POINTIT that returns the IO system type.
  3) change(86-12-19,Fakoury), approve(86-12-19,MCR7514),
     audit(87-01-05,Martinson), install(87-01-05,MR12.0-1254):
     Modified to correct a problems in MME DATA. One problem was caused by a
     change in the mca driver interface and the other problem was in the trace
     function.
  4) change(87-01-06,Fakoury), approve(87-01-06,MCR7514),
     audit(87-01-07,Martinson), install(87-01-08,MR12.0-1263):
     Corrected a Colt attachment problem by increasing the no responce count,
     corrected a problem in releasing the channel when a failure occurs.
                                                   END HISTORY COMMENTS */






/* mtdsim_ - (Multics T & D Slave Interface Module) Procedure to drive the gcos T & D Modules
   known as slave mode polt and slave mode molt (and eventually slave mode colt)
*/


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */

mtdsim_: proc;


/* External entries */

dcl  bcd_to_ascii_ entry (bit (*) aligned, char (*));
dcl  com_err_ entry () options (variable);
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  convert_dial_message_$return_io_module entry (fixed bin (71), char (*), char (*), fixed bin, 1 aligned,
      2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, 2 bit (33) unal, fixed bin (35));
dcl  convert_status_code_ entry (fixed bin (35), char (*), char (*));
dcl  cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  dial_manager_$privileged_attach entry (ptr, fixed bin (35));
dcl  dial_manager_$release_channel entry (ptr, fixed bin (35));
dcl  dial_manager_$release_channel_no_listen entry (ptr, fixed bin (35));
dcl  dial_manager_$tandd_attach entry (ptr, fixed bin (35));
dcl  db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35));
dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35));
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), ptr, fixed bin (35)); /* arg 3 is suppose to be fixed bin (71) */
dcl  hcs_$get_ips_mask entry (bit (36) aligned);
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  (ioa_, ioa_$rsnnl) entry () options (variable);
dcl  ioi_$connect entry (fixed bin (12), fixed bin (18), fixed bin (35));
dcl  ioi_$release_devices entry (fixed bin (12), fixed bin (35));
dcl  ioi_$set_channel_required entry (fixed bin (12), fixed bin (3), fixed bin (6), fixed bin (35));
dcl  ioi_$set_status entry (fixed bin (12), fixed bin (18), fixed bin (8), fixed bin (35));
dcl  ioi_$suspend_devices entry (fixed bin (12), fixed bin (35));
dcl  ioi_$timeout entry (fixed bin (12), fixed bin (52), fixed bin (35));
dcl  ioi_$workspace entry (fixed bin (12), ptr, fixed bin, fixed bin (35));
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  ioi_$connect_pcw entry (fixed bin (12), fixed bin (18), bit (36), fixed bin (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$read_ev_chn entry (fixed bin (71), fixed bin, ptr, fixed bin (35));
dcl  mca_$attach_ipc entry (char (*), fixed bin, fixed bin, fixed bin (35));
dcl  mca_$attach_mca entry (char (*), fixed bin (71), fixed bin, fixed bin (35));
dcl  mca_$detach_ipc entry (char (*), fixed bin, bit (1), fixed bin (35));
dcl  mca_$detach_mca entry (fixed bin, fixed bin (35));
dcl  mca_$load_ipc entry (fixed bin, fixed bin, bit (36), fixed bin (35));
dcl  mca_$tandd_read_data entry (fixed bin, ptr, fixed bin, bit (36), fixed bin (35));
dcl  mca_$tandd_write_data entry (fixed bin, ptr, fixed bin, bit (36), fixed bin (35));
dcl  mca_$tandd_write_text entry (fixed bin, ptr, fixed bin, bit (36), fixed bin (35));
dcl  mca_$reset entry (fixed bin, bit (36), fixed bin (35));
dcl  opr_query_ entry () options (variable);
dcl  rcp_$attach entry (char (*) aligned, ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35));
dcl  rcp_$check_attach entry (bit (36) aligned, ptr, char (*), fixed bin (12),
      fixed bin (19) aligned, fixed bin (71) aligned, fixed bin, fixed bin (35));
dcl  rcp_$detach entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));
dcl  rcp_priv_$attach entry (char (*) aligned, ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35));
dcl  probe entry options (variable);
dcl  terminate_process_ entry (char (*), ptr);
dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
dcl  tolts_alm_util_$ascii_to_bcd_ entry (char (*), bit (*));
dcl  tolts_alm_util_$enter_ccc_req_ entry (ptr, bit (36));
dcl  tolts_alm_util_$enter_slave_ entry (ptr);
dcl  tolts_alm_util_$gen_ck_sum entry (ptr);
dcl  tolts_alrm_util_$quit entry;
dcl  tolts_device_info_ entry (ptr, fixed bin, fixed bin);
dcl  tolts_file_util_$close entry;
dcl  tolts_file_util_$open entry (fixed bin (35));
dcl  tolts_file_util_$snap entry (ptr);
dcl  tolts_file_util_$wdump entry (ptr);
dcl  tolts_load_firmware_ entry (fixed bin, fixed bin (35));
dcl  tolts_init_ entry (char (4), fixed bin (35));
dcl  tolts_init_$clean_up entry;
dcl  tolts_init_$cr_event_chan entry (fixed bin (71), bit (1), entry, ptr, fixed bin, fixed bin (35));
dcl  tolts_io_int_ entry;
dcl  tolts_qttyio_ entry (char (*), fixed bin);
dcl  tolts_qttyio_$dcw_list entry (ptr, fixed bin);
dcl  tolts_qttyio_$dcw_ptr entry (ptr, fixed bin, fixed bin);
dcl  tolts_qttyio_$rcw entry (ptr);
dcl  tolts_qttyio_$rs entry () options (variable);
dcl  tolts_util_$cata_sel entry (ptr, char (32), ptr, fixed bin (35));
dcl  tolts_util_$find_card entry (char (4), ptr);
dcl  tolts_init_$gc_tod entry (bit (36));
dcl  tolts_util_$get_ttl_date entry (entry, char (6));
dcl  tolts_util_$search entry (ptr, char (32), ptr, fixed bin, fixed bin (35));

/* AUTOMATIC */

dcl  bufp ptr;
dcl  (nargs, return_value, c_len, n_dialed, len, tio, dealc_err, ev_occurred,
     i, j, mesg_len, ndcws, tally, t_err) fixed bin init (0);
dcl  (chan_name, io_module) char (32);
dcl  (error, c_error, mem_needed) fixed bin (35) init (0);
dcl  filename_idx fixed bin;
dcl  lvl_idx fixed bin;
dcl  imu_found bit (1) init ("0"b);
dcl  iom_found bit (1) init ("0"b);
dcl  iom fixed bin (3), chan fixed bin (6), tio_off fixed bin (18), timeout_time fixed bin (52) init (0);
dcl  cpu_time fixed bin (71);
dcl  wake_time fixed bin (71) init (500000);
dcl  mem_now fixed bin (19);
dcl  (pcwa, bcd_callname, gcos_tod) bit (36);
dcl  b18 bit (18);
dcl  bit_buf bit (72);
dcl  pad_char bit (6);
dcl  sb_data_idx fixed bin;
dcl  ws_data_idx fixed bin;
dcl  (argptr, train_ptr, tp, cltp, t_ptr, ioe_ptr, l_ptr, gcatp, info_ptr) ptr;
dcl  coment char (256), shortinfo char (8), lginfo char (100), message char (512), ac_name char (6);
dcl  workspace_move char (c_len * 4) based (bufp);


/* INTERNAL STATIC */

dcl  (gicm_count, io_sel, isc_cntdn, last_mme, mme_number, nr_cnt) fixed bin int static init (0);
dcl  (term, gndc_flag, found, gelbar, glb_brk, in_ccc, isc_ccc_rqt, mpc_io, trace_save, debug, debugging,
     rd_blk, flt_flag, alt_flag, q_flag, rd_flag, tcd, trace_io, trace, itr_run) bit (1) aligned int static init ("0"b);
dcl  tolts_active bit (1) aligned int static init ("0"b);	/* flag for epilogue handler */
dcl  db_addr fixed dec int static;
dcl  exec char (4) int static;
dcl  ttl_date char (6) int static;
dcl  (old_mask, new_mask) bit (36) aligned int static;
dcl  clt_sw char (32) varying int static;
dcl  io_block_len fixed bin;
dcl  (gicmp, icmp, mvp, ricmp, ticmp, wicmp) ptr int static init (null);
dcl  (l, k) fixed bin (6) int static;
dcl  code fixed bin (35) init (0) int static;
dcl  db_sv_wd bit (36) int static;
dcl  (gerout_num, icm_tally, fnp_addr, fnp_num, remote_inquiry_ic) fixed bin int static;
dcl  att_desc char (40) int static;
dcl  (mmep, genp) ptr int static;
dcl  (arglen, n_read) fixed bin (21) int static;
dcl  blk_lbl label int static;
dcl  emsg char (40) int static;
dcl  term_lbl label int static;
dcl  no_blk label int static;

/* EXTERNAL STATIC */

dcl  error_table_$bad_command_name fixed bin (35) ext static;
dcl  error_table_$force_unassign external fixed bin (35);
dcl  error_table_$resource_unavailable external fixed bin (35);
dcl  printer_images_$n_images fixed bin external;
dcl  printer_images_$image_base external;
dcl  printer_images_$image_offsets (10) fixed bin (18) external;
dcl  printer_images_$image_numbers (10) fixed bin external;
dcl  sys_info$alrm_mask bit (36) aligned ext;

/* BASED */

dcl  arg char (arglen) based (argptr);
dcl  data_move char (c_len * 4) based (mvp);
dcl  prt_image (64) char (288) based unaligned;
dcl  exec_wd (0:210000) bit (36) based (execp);
dcl  ioe (11) bit (36) based (ioe_ptr);
dcl  reg_move bit (36 * 8) based aligned;
dcl  fix_wd (2) fixed bin (18) unsigned unaligned based (genp);
dcl  sctwrk (12) bit (36) based (genp);
dcl  mme_call_w (0:11) bit (36) based (mmep) aligned;	/* mme call template for full words */
dcl  1 mme_call_hw (0:11) based (mmep) aligned,		/* mme template for half words */
       (2 upper bit (18),
       2 lower bit (18)) unaligned;

dcl  1 mme_call_hf (0:11) based (mmep) aligned,		/* mme template for fixed half words */
       (2 upper fixed bin,
       2 lower fixed bin) unaligned;

/* STRUCTURES */

/* The following structure declaration defines the gcos slave prefix area as used by the slave
   mode execs. Only areas used by the execs have been defined, the remaining area is set to
   padx. For a full description of the gcos slave prefix area, refer to gcos manual DD19. */

dcl  1 spa based (execp) aligned,			/* slave prefix area, 0 - 77 of slave pgm */
       (2 user_fault (0:10) bit (36),			/* 0 - 12 = user settable fault vectors */
       2 abort,					/* 13 = used for aborting slave pgm */
         3 add bit (18),				/*  U = abort address */
         3 code bit (18),				/*  L = abort reason code */
       2 pad1 (5) bit (36),
       2 glbtmr bit (36),				/* 21 = gelbar mode timer setting */
       2 glbici,					/* 22 = gelbar ic and i value */
         3 ic bit (18),				/*  U = instruction counter value */
         3 ind bit (18),				/*  L = indicator register */
       2 glbflt bit (36),				/* 23 = gelbar fault vector */
       2 pad2 (3) bit (36),
       2 wrapup_add bit (18),				/* 27 = exec wrap up address */
       2 pad3 bit (18),
       2 pad4 bit (36),
       2 acc_fault bit (36),				/* 31 = accumulated fault status word */
       2 enter,					/* 32 = entry into exec always at this point */
         3 lreg bit (36),				/* 32 = "lreg  spa.regs" instruction */
         3 lbar,					/* 33 = "lbar  bar,du" instruction */
	 4 bar bit (18),				/*  U = bar value to load */
	 4 inst bit (18),				/*  L = "230203"b3 (lbar  bar,du) */
         3 ret bit (36),				/* 34 = "ret  spa.enter.icivlu" instruction */
         3 icivlu,					/* 35 = return ic and i value */
	 4 ic bit (18),				/*  U = instruction counter */
	 4 ind bit (18),				/*  L = indicator register */
       2 ccc_icivlu bit (36),				/* 36 = ic and i storage while in courtesy call */
       2 pad5 bit (36),
       2 regs like mc.regs,				/* 40 = return register storage */
       2 ccc_regs like mc.regs,			/* 50 = courtesy call register storage */
       2 pad6 (16) bit (36)) unaligned;

dcl  1 fatal_desc aligned,
       2 version fixed bin,
       2 fatal_code fixed bin (35);

dcl  1 ci aligned like condition_info;

dcl  1 event_out static aligned like event_wait_info;

dcl  1 flags aligned,
       2 dialed_up bit (1) unal,
       2 hung_up bit (1) unal,
       2 control bit (1) unal,
       2 pad bit (33) unaligned;

dcl  1 cata based (io_info.catp) aligned,		/* template for deckfile catalog */
       2 n fixed bin,				/* number of entries */
       2 key (1 refer (cata.n)) char (24);		/* array of key names */

dcl  1 mca_gcata (100) based (gcatp) aligned,
         (2 equip_type bit (36),
       2 cat_index fixed bin,
       2 nblk fixed bin (13),
       2 dipper_flag bit (4),
       2 filename,
         3 filename bit (48),
         3 diskette_prod_tab bit (12),
         3 prog_tab bit (12)) unaligned;


dcl  1 gcata (1000) based (gcatp) aligned,		/* template for a gcos catalog entry */
       (2 edit_rev bit (36),				/* bcd edit name and rev */
       2 cat_index fixed bin,				/* deckfile catalog index */
       2 pad1 bit (3),
       2 nblk fixed bin (14),				/* (same as cat_index) */
       2 ident bit (36),				/* word 0 of ident blk */
       2 purpose bit (36)) unaligned;			/* deck purpose (itr, mdr or fw) */

/* The following structure declaration defines the gcos 11 word I/O  entry  as  used  by  the
   slave  mode  execs.  Only areas used by the execs have been defined, the remaining area is
   set to padx. For a full description of the gcos I/O entry, refer to gcos manual DD14. */

dcl  1 io_entry based (ioe_ptr) aligned,		/* :: */
       (2 pad1 bit (36),				/* word 0 unused */
       2 ext_sts fixed bin,				/* extented status address */
       2 pad2 bit (18),
       2 pad3 bit (5),
       2 sct_add bit (13),				/* system config table entry (test page index) */
       2 pad4 bit (18),
       2 pad5 bit (36),
       2 prim,					/* primary device info */
         3 dev_cmd bit (6),				/* device command */
         3 dev bit (6),				/* punch indicator if not "00"b3 */
         3 pad6 bit (6),
         3 io_cmd bit (6),				/* iom command */
         3 pad7 bit (6),
         3 record_count bit (6),			/* idcw/pcw record count */
       2 first_dcw like dcw,				/* first dcw relative to iom lal */
       2 pad8 bit (36),
       2 second,					/* secondary device info (the same as prim unless dual cmd) */
         3 dev_cmd bit (6),				/* device command */
         3 prex bit (12),				/* preselect index */
         3 io_cmd bit (6),				/* iom command */
         3 pad9 bit (5),
         3 ignore_term bit (1),			/* ignore terminate int, report special int if on */
         3 record_count bit (6),			/* idcw/pcw record count */
       2 dcw_ptr fixed bin,				/* pointer to dcw list (offset to lal) */
       2 pad10 bit (18),
       2 stat_p bit (18),				/* ptr to place to store status */
       2 ccc_p bit (18),				/* courtesy call ptr */
       2 pad11 bit (36)) unaligned;

dcl  1 colts_op_flags aligned ext static,
       2 colt_flag bit (1) unaligned init ("0"b),
       2 dm_attach bit (1) unaligned init ("0"b),
       2 dm_detach bit (1) unaligned init ("0"b),
       2 sicm bit (1) unaligned init ("0"b),
       2 gicm bit (1) unaligned init ("0"b);

dcl  1 gicm based (gicmp) aligned,
       2 cltp ptr init (null),
       2 ricmp ptr init (null),
       2 cc_addr bit (36),
       2 st_addr fixed bin,
       2 tally fixed bin (21);


dcl  1 ricm like icm based (ricmp);
dcl  1 wicm like icm based (wicmp);
dcl  1 ticm like icm based (ticmp);
dcl  1 icm based (icmp) aligned,
       (2 word_total bit (18),
       2 rbuf_addr bit (18),
       2 cksum bit (18),
       2 test_id bit (18),
       2 host_opcode bit (18),
       2 fnp_opcode bit (18),
       2 icm_buf (icm_tally) bit (36)) unaligned;

dcl  1 info_struct based (info_ptr) aligned,
       2 ev_chan fixed bin (71),
       2 out_pend bit;


/* constants */

dcl  (quit, lockup, illop, illegal_modifier, illegal_opcode, illegal_procedure,
     store, program_interrupt, cleanup, tolts_error_) condition;
dcl  (addr, addrel, bin, bit, divide, fixed, index, length, null, rel, rtrim, string, substr, time, unspec) builtin;
%page;
/* enviornment initialization */

      debug, debugging, q_flag, trace_io, trace = "0"b;
      exec = "";
      call cu_$arg_count (nargs);
      call cu_$arg_ptr (1, argptr, arglen, code);
      if arg ^= "polt" & arg ^= "molt" & arg ^= "colt" then do; /* invalid executive */
         call com_err_ (0, "mtdsim_", "Invalid executive code - ""^a""", exec); /* tell user */
         return;
      end;
      exec = arg;
      term = "0"b;
      if nargs > 1 then do;
         do i = 2 to nargs;
	  call cu_$arg_ptr (i, argptr, arglen, code);
	  if arg = "-debug" | arg = "-db" then debug = "1"b;

	  else if arg = "-quit" | arg = "-q" then q_flag = "1"b; /* user wants to return to command level on quits  */

	  else if arg = "-trace" | arg = "-tc" then trace = "1"b; /* user wants mme trace */
	  else if arg = "-trace_cata_data" | arg = "-tcd" then tcd = "1"b;
	  else if arg = "-tio" then trace_io = "1"b;
	  else if arg = "-probe" | arg = "-pb" then call probe (mtdsim_);
         end;
         debugging = "1"b;
      end;


      last_mme, isc_cntdn, tio = 0;
      trace_save, in_ccc, isc_ccc_rqt, rd_blk, gelbar, glb_brk, itr_run = "0"b; /* reset flags */
      gicm_count = 0;
      gicmp, ricmp, ticmp, wicmp = null;		/* initialize colts pointers */
      call tolts_init_ (exec, error);			/* go init our enviornment and create slave seg */
      if error ^= 0 then return;			/* if error durring init */
      on cleanup call clean_up;			/* establish cleanup handler */
      gndc_flag = "0"b;				/* flag to prevent recursive courtsey calls */
      call tolts_util_$get_ttl_date (mtdsim_, ttl_date);
      tolts_active = "1"b;				/* set active flag for epilogue handler */

/* search for <exec>cm in file system (exec can be polt, molt, or colt) */

      call tolts_util_$search (tolts_info.df_iocbp, substr (exec, 1, 1) || "lt." || exec || "cm", t_ptr, c_len, error);
      if error ^= 0 then do;				/* if couldn't find cplt */
         call com_err_ (error, exec, "searching for ^alt.^acm", substr (exec, 1, 1), exec);
         call tolts_init_$clean_up;			/* go delete our event channels and slave seg */
         return;
      end;
      call gload_ (t_ptr, execp, 0, addr (gload_data), error); /* load core image into our work segment */
      if error ^= 0 then do;				/* problem durring load */
         call com_err_ (error, exec, "^a^/attempting to load ^alt.^acm",
	gload_data.diagnostic, substr (exec, 1, 1), exec);
         call tolts_init_$clean_up;			/* go delete our event channels and slave seg */
         return;
      end;

      if debugging then call ioa_ (" execp = ^p", execp);

      if debug then do;
         debug = "0"b;
         tolts_info.mult_ans = "";			/* clear out response */
db_query:
         call tolts_qttyio_$rs (19, "tolts_debugger: enter break point address");
         call message_wait;				/* wait for user response */
         if mult_ans ^= "" then do;
	  db_addr = cv_oct_check_ ((rtrim (mult_ans)), code);
	  if code ^= 0 | db_addr > 65535 then do;
	     call ioa_ ("Debugger: invalid address supplied");
	     goto db_query;
	  end;
	  db_sv_wd = exec_wd (db_addr);
	  exec_wd (db_addr) = "777650001000"b3;
         end;
      end;


      blk_lbl = block_disp;
      term_lbl = done;
      no_blk = no_blk_disp;
      spa.enter.lreg = rel (addr (spa.regs)) || "073200"b3; /* set lreg instruction  (lreg  spa.regs) */
      if exec = "molt" then string (spa.enter.lbar) = "000630230203"b3; /* set initial lbar instruction (lbar =o630,du) */
      else string (spa.enter.lbar) = "000201230203"b3;	/* set initial lbar instruction (lbar =o200,du) */
      spa.enter.ret = rel (addr (spa.enter.icivlu)) || "630200"b3; /* set return instruction (ret  spa.enter.icivlu) */
      spa.enter.icivlu.ic = gload_data.definition (1).offset; /* set initial entry point */
      spa.enter.icivlu.ind = "0"b;			/* initial entry indicators are zero */
      on lockup begin;
         call ioa_ ("^a encountered a lockup fault ^[a dump will be taken^]", exec, ^flt_flag);
         if ^flt_flag then call fault_dump;
         else call continue_to_signal_ (error);
      end;
      on illop begin;
         call ioa_ ("^a encountered a illop fault ^[a dump will be taken ^]", exec, ^flt_flag);
         if ^flt_flag then call fault_dump;
         else call continue_to_signal_ (error);
      end;
      on illegal_modifier begin;
         call ioa_ ("^a encountered an illegal_modifier fault ^[a dump will be taken ^]", exec, ^flt_flag);
         if ^flt_flag then call fault_dump;
         else call continue_to_signal_ (error);
      end;
      on illegal_opcode begin;
         call ioa_ ("^a encountered an illegal_opcode fault ^[a dump will be taken ^]", exec, ^flt_flag);
         if ^flt_flag then call fault_dump;
         else call continue_to_signal_ (error);
      end;
      on illegal_procedure begin;
         call ioa_ ("^a encountered an illegal_procedure fault ^[a dump will be taken ^]", exec, ^flt_flag);
         if ^flt_flag then call fault_dump;
         else call continue_to_signal_ (error);
      end;
      on store begin;
         call ioa_ ("^a encountered a store fault ^[a dump will be taken ^]", exec, ^flt_flag);
         if ^flt_flag then call fault_dump;
         else call continue_to_signal_ (error);
      end;
      on tolts_error_ begin;
         call probe (mtdsim_);
         call clean_up;
      end;

      on quit begin;				/* establish quit handler */
         if ^q_flag then				/* if normal operation */
	  call tolts_alrm_util_$quit;
         else call continue_to_signal_ (error);
      end;
      on program_interrupt begin;			/* establish pi handler for debugging */
         call hcs_$wakeup (tolts_info.process, tolts_info.quith_event, null, error);
      end;
      call tolts_qttyio_ ("??? ", 9);			/* exec read for original data */
%page;
/* this is the main program dispatcher */

      term = "0"b;					/* reset terminate condition */
      do while (^term);				/* loop until we are done */
block_disp:					/* target of nonlocal gotos */
         call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error);
         if error ^= 0 then do;			/* this is a fatal error, terminate our process */
	  call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */
	  fatal_desc.version = 0;
	  fatal_desc.fatal_code = error;
	  if ^debugging then
	     call terminate_process_ ("fatal_error", addr (fatal_desc));
	  else signal tolts_error_;
         end;					/* no need to return, as we won't be back */
         if tolts_info.wait_list.nchan > 1 then do;	/* if we are waiting for > 1 event */
	  if event_out.channel_id ^= wait_list.wait_event_id (2)
	   | event_out.channel_id ^= tolts_info.dm_event
	  then do;				/* if the wake up is not for the second channel */
	     ev_occurred = 0;			/* initialize in case code ^= 0 */
	     call ipc_$read_ev_chn (wait_list.wait_event_id (2),
	      ev_occurred, addr (event_out), code);	/* check and see if the second channel is ready */
	     if code ^= 0 then do;
	        call com_err_ (code, exec, "Error calling ipc_$read_ev_chn");
	        if debugging then signal tolts_error_;
	     end;
	     if ev_occurred ^= 1 then do;
	        if nr_cnt < 20 then do;
		 if debugging then call ioa_ ("nr_cnt = ^d", nr_cnt);
		 wake_time = 500000;
		 call timer_manager_$sleep (wake_time, "10"b);
		 nr_cnt = nr_cnt + 1;
		 call wake_disp;			/* if the second channel hasn't awaken then wait */
	        end;
	        else do;
		 if substr (clt_sw, 3, 4) = "c000" then do; /* if exec chan - wrapup */
		    call tolts_qttyio_$rs (0, "^as: timeout error attempting attach of ^a",
		     tolts_info.exec, clt_sw);	/* notify the user */
		    call tolts_abort ("$c1");		/* then abort colts */
		 end;
		 else do;
		    call rel_tst_chan (l);
		    colts_pages (l).in_use = "0"b;	/* reset test page active */
		    call tolts_qttyio_$rs (0, "^as:  timeout error attempting a tandd_attach of ^a",
		     tolts_info.exec, substr (colts_pages (l).cdt_name, 1, 6));
		    colts_op_flags.colt_flag = "0"b;	/* make use flag is reset so we don't go blocked */
		    colts_op_flags.sicm = "0"b;
		    colts_op_flags.dm_attach = "0"b;
		    if mme_call_hf (2).lower ^= 0 then do; /* cc requested */
		       exec_wd (mme_call_hf (2).upper) = "000000000004"b3; /* store error status */
		       call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
		        (mme_call_hw (2).lower || "000000"b3)); /* enter cc request */
		    end;
		    colts_pages (l).status_word = "000000000002"b3; /* test channel - store status */
		 end;
	        end;
	     end;
	  end;
	  tolts_info.wait_list.nchan = tolts_info.wait_list.nchan - 1; /* else decrement the wait list */
	  chan_name, io_module = "";
	  n_dialed = 0;
	  flags = ""b;
	  call convert_dial_message_$return_io_module (event_out.message,
	   chan_name, io_module, n_dialed, flags, code);	/* convert the message into flags */
	  if code ^= 0 then do;
	     call ioa_$rsnnl ("error attaching channel ^a", emsg, mesg_len, chan_name);
	     call output_status_code (code, emsg);
	  end;
	  if trace_io then
	     call ioa_ ("Channel ^a, IO Module ^a, N_dialed ^d, flags^[ dialed_up^]^[ hung_up^]^[ control^]",
	      chan_name, io_module, n_dialed, flags.dialed_up, flags.hung_up, flags.control);

	  if flags.control				/* if control flag then error */
	   | (^flags.control			/* or an informative message */
	   & ^flags.dialed_up & ^flags.control) then do;	/* with no information */

	     if substr (clt_sw, 3, 4) = "c000" then do;	/* if exec chan - wrapup */
	        call tolts_qttyio_$rs (0, "^as: control error attempting dial_manager_attach of ^a",
	         tolts_info.exec, substr (clt_sw, 1, 6)); /* notify user */
	        call tolts_abort ("$c0");		/* then abort colts */
	     end;
	     else do;
	        call rel_tst_chan (l);
	        colts_pages (l).in_use = "0"b;		/* reset test page active */
	        call tolts_qttyio_$rs (0, "^as:  control error attempting a tandd_attach of ^a",
	         tolts_info.exec, substr (colts_pages (l).cdt_name, 1, 6));
	        colts_op_flags.colt_flag = "0"b;	/* make use flag is reset so we don't go blocked */
	        colts_op_flags.sicm = "0"b;
	        colts_op_flags.dm_attach = "0"b;
	        if mme_call_hf (2).lower ^= 0 then do;	/* cc requested */
		 exec_wd (mme_call_hf (2).upper) = "000000000002"b3; /* store error status */
		 call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
		  (mme_call_hw (2).lower || "000000"b3)); /* enter cc request */
	        end;
	        colts_pages (l).status_word = "000000000002"b3; /* else test channel - store status */
	     end;
	  end;

	  if flags.dialed_up & colts_op_flags.dm_attach then do; /* if the channel is dialed attaching */
	     call iox_$attach_name ((clt_sw), cltp, att_desc, null, code); /* create an io switch */
	     if code ^= 0 then goto sw_err;		/* if error */
	     call iox_$open (cltp, 3, "0"b, code);	/* open a switch */
	     if code ^= 0 then goto sw_err;		/* if error */
	     call iox_$modes (cltp, "rawi,rawo", "", code); /* now set the modes for the channel */
	     if code ^= 0 then do;			/* if error */
sw_err:	        if substr (clt_sw, 3, 4) = "c000" then do;/* if exec channel - wrapup */
		 call convert_status_code_ (code, shortinfo, lginfo); /* convert the status code */
		 call tolts_qttyio_$rs (0, "^as: ^a/ attempting a switch operation for ^a",
		  tolts_info.exec, lginfo, clt_sw);	/* and notify the user */
		 call tolts_abort ("$c1");		/* then abort colts */
	        end;
	        else do;
		 colts_pages (l).status_word = "000000000002"b3; /* else test channel - store status */
		 colts_pages (l).in_use = "0"b;
	        end;
	     end;
	     if code = 0 then do;
	        if substr (clt_sw, 3, 4) = "c000" then do;/* if exec channel */
		 tolts_info.fnp (k).exec_active = "1"b; /* set exec active */
		 fnp (k).fnp_execp = cltp;		/* save iocb ptr */
		 exec_wd (remote_inquiry_ic) = "0000000500"b3 || "1"b
		  || substr (bit (k), 2, 5);		/* answer remote inquiry request */
	        end;
	        else do;				/* else a test channel */
		 colts_pages (l).chanp = cltp;	/* save iocb ptr */
		 colts_pages (l).status_word = "000000000004"b3; /* store good status */
		 exec_wd (remote_inquiry_ic) = "0000000500"b3 || "0"b
		  || substr (bit (l), 2, 5);		/* answer remote inquiry request */
	        end;
	        colts_op_flags.colt_flag = "0"b;	/* reset colts flag */
	        colts_op_flags.dm_attach = "0"b;	/* reset dial_manager attach flag */
	        remote_inquiry_ic = 0;		/* reset remote inquiry ic */
	     end;
	  end;
         end;

         if colts_op_flags.sicm then do;		/* if an icm need to be sent to the fnp */
	  call iox_$put_chars (fnp (k).fnp_execp, wicmp, (bin (wicm.word_total) + 1) * 4, code); /* send it */
	  if code ^= 0 then do;			/* if error */
	     call convert_status_code_ (code, shortinfo, lginfo);
	     call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer to fnp colt exec ^a",
	      tolts_info.exec, lginfo, fnp (k).fnp_execp);
	     call tolts_abort ("$c1");		/* then abort colts */
	  end;
	  gicmp = addr (gicm);			/* else get ptr for return icm */
	  gicm_count = gicm_count + 1;		/* inc position in the queue */

	  if gicm_count = 17 then do;			/* if 17 - error */
	     call tolts_qttyio_$rs (0, "^as: execessive outstanding io's", tolts_info.exec);
	     call tolts_abort ("$c2");		/* abort colts */
	  end;
	  gicm.cltp = fnp (k).fnp_execp;		/* save iocb ptr */
	  gicm.ricmp = ricmp;			/* rtrn icm ptr */
	  gicm.tally = bin (wicm.word_total) + 1;	/* tally */
	  if mme_call_hf (2).lower ^= 0 then do;	/* cc requested */
	     gicm.cc_addr = mme_call_hw (2).lower || "000000"b3; /* save cc address */
	     gicm.st_addr = mme_call_hf (2).upper;	/* save status address */
	  end;
	  colts_op_flags.sicm = "0"b;			/* reset send icm flag */
         end;

         if tolts_info.special_fault then do;		/* special int. fault from tolts_io_int_ */
	  tolts_info.special_fault = "0"b;
	  call tolts_abort ("$b6");
         end;
         else if tolts_info.exec_term_io_wait then term = "1"b; /* we are all done */
         else if tolts_info.first_request_done then do;	/* if we have something to do... */
no_blk_disp:					/* target of non-local gotos */
	  if gicm_count ^= 0 then do;			/* if outstanding icm */
	     alloc info_struct;			/* alloc an info struct */
	     info_ptr = addr (info_struct);		/* get its ptr */

	     if gicm.cltp ^= null then do;		/* if slot is in use */
	        call iox_$control (gicm.cltp, "read_status", info_ptr, code); /* read the status */
	        if info_struct.out_pend then do;	/* output ready */
		 call iox_$get_chars (gicm.cltp, gicm.ricmp, gicm.tally * 4, n_read, code); /* get the icm */
		 if code ^= 0 then do;		/* if error */
		    call convert_status_code_ (code, shortinfo, lginfo);
		    call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer from fnp", tolts_info.exec, lginfo);
		    call tolts_abort ("$c1");		/* then abort colts */
		 end;
		 if gicm.cc_addr ^= "0"b3 then do;	/*  if a courtesy call requested */
		    if fnp (k).fnp_execp = gicm.cltp then
		       exec_wd (gicm.st_addr) = fnp (k).status_word;
		    else exec_wd (gicm.st_addr) = colts_pages (l).status_word;
		    call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
		     (gicm.cc_addr));		/* enter ccc request */
		 end;
		 gicm_count = gicm_count - 1;		/* dec the count */
		 gicm.cltp = null;			/* open up the slot */
		 gicm.ricmp = null;
		 if gicm_count = 0
		 then do;				/* delete unused gicms */
		    free gicm;
		    gicmp = null;
		 end;
	        end;
	     end;

	     free info_struct;			/* free the info structure */
	  end;

	  if isc_ccc_rqt then do;			/* if outstanding inter slave read ... */
	     if tolts_info.exec_dta_cnt = 0 then isc_cntdn = isc_cntdn - 1; /* but no data to xfer yet ... */
	     if isc_cntdn = 0 | tolts_info.exec_dta_cnt ^= 0 then do; /* if timeout or isc data avail */
	        isc_ccc_rqt = "0"b;			/* reset isc courtesy call flag and enter courtesy call */
	        call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), (isc_queue.icivlu));
	        exec_wd (isc_queue.status_add + 1) = "0"b;/* dcw residue = zero */
	        if tolts_info.exec_dta_cnt = 0 then	/* if no data to xfer... */
		 exec_wd (isc_queue.status_add) = "400006000000"b3; /* set status to timeout */
	        else call pop_isc (isc_queue.status_add, isc_queue.data_add); /* data to xfer */
	     end;
	  end;
	  if ^in_ccc & ^gndc_flag then		/* if not in ccc */
	     if tolts_info.ccc_requests ^= 0 & ^gelbar then do; /* pay courtesy call first */
	        unspec (spa.ccc_regs) = addr (spa.regs) -> reg_move; /* move current regs into safe store */
	        spa.ccc_icivlu = string (spa.enter.icivlu);
	        string (spa.enter.icivlu) = tolts_info.ccc_queue (1).icivlu;
	        tolts_info.ccc_requests = tolts_info.ccc_requests - 1; /* decrement count */
	        do i = 1 to tolts_info.ccc_requests;
		 tolts_info.ccc_queue.icivlu (i) = tolts_info.ccc_queue.icivlu (i + 1); /* move queue down */
	        end;
	        in_ccc = "1"b;
	     end;
	     else if rd_blk then do;			/* road blocked? */
	        if isc_ccc_rqt then call wake_disp;	/* wakeup dispatcher */
	        rd_blk = "0"b;
	     end;
	  if trace | (trace_save & in_ccc) then		/* if tracing mmes and dispatches */
	     call tolts_qttyio_$rs (10,
	      "^a ^a ^12.3b^[, ^a^;^s^]^[, ^a ^6.3b^;^2s^]^[, ^a ^a ^12.3b, ^a ^12.3b^]",
	      ctime (), "Dispatch to ici -", string (spa.enter.icivlu), in_ccc,
	      "in courtesy call", gelbar, "in gelbar, BAR -", spa.enter.lbar.bar, glb_brk,
	      "gelbar break,", "gb ici -", string (spa.glbici), "gbfv -", spa.glbflt);
	  glb_brk = "0"b;				/* reset gelbar break indicator if set */
	  gndc_flag = "0"b;
	  if ^flt_flag then
	     call tolts_alm_util_$enter_slave_ (addr (spa.enter)); /* enter slave program */
         end;
done:						/* target of nonlocal goto */
      end;
      if ^tolts_active then return;
      tolts_info.exec_term_io_wait = "1"b;		/* make sure we quit */
      call clean_up;				/* go cleanup our enviornment */
      return;					/* and return  to tolts command level */
%page;

/* mme_fault - static condition handler for GCOS type mme faults */

mme_fault: entry (mcptr, cname, tptr1, tptr2, tcont);

dcl  (mcptr, tptr1, tptr2) ptr;
dcl  cname char (*);
dcl  tcont bit (1);
dcl  tags (1:8) char (1) static options (constant) init
      ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  fnp_state (0:4) char (7) static options (constant) init
      ("free   ", "unknown", "down   ", "booting", "up     ");


      mcp = mcptr;					/* get ptr to machine conditions */
      scup = addr (mc.scu);				/* get ptr to scu data */
      unspec (spa.regs) = addr (mc.regs) -> reg_move;	/* save the processor regs */
      spa.enter.icivlu.ind = string (scu.ir);

      if gelbar then				/* if in gelbar mode, pass fault on to gcos module */
         call set_gelbar;				/* we want return from this call */
      mmep = addrel (execp, scu.ilc);			/* set mme call ptr */

      if substr (mme_call_w (0), 19, 10) ^= "0000000010"b then /* if not mme1 instruction... */
         go to undefm;

      if in_ccc then
         if mme_call_hw (0).upper ^= "000016"b3 then do;
	  call tolts_qttyio_$rs (0, "^as: Illegal mme in ccc  (^12.3b) @ ^p",
	   exec, mme_call_w (0), mmep);
	  call tolts_abort ("$a4");
         end;
      mme_number = mme_call_hf (0).upper;
      if (mme_number < -127 | mme_number > 31)		/* if out of legal range */
       | (mme_number < -66 & mme_number > -87)
       | (mme_number < -94 & mme_number > -127) then
         go to undefm;
      if trace | trace_save then do;			/* if tracing mmes and dispatches */
         if trace then do;				/* if currently tracing */
	  if (mme_number = -1 & last_mme = -39)
	   | (mme_number = -39 & last_mme = -1)
	   | mme_number = last_mme then do;		/* do not display idle loop */
	     trace_save = "1"b;			/* save state and turn trace off */
	     trace = "0"b;				/* idle loop */
	  end;
         end;
         else if mme_number ^= last_mme then do;		/* if idle loop has ended */
	  trace = "1"b;				/* turn back on trace */
	  trace_save = "0"b;
         end;
      end;
      last_mme = mme_number;				/* save mme number for nxt time */
      go to mme_typ (mme_number);			/* process gcos mme */
%page;
/* ********* MME ABSTIM ********* (absolute time)

   input registers: none

   mme     abstim
   ------  return

   return registers: AR = time of day, 1/64 ms. since midnight */

mme_typ (-1): if trace then call tolts_qttyio_$rs (10, "^a MME ABSTIM @ ^p", ctime (), mmep);
      call tolts_init_$gc_tod (spa.regs.a);		/* get current time of day */
      call return_plus (1);

/* ********* MME ACCWRT ********* (accounting file write, unused in Multics)

   input registers:   x1 -> message address

   mme     accwrt
   ------  return

   return registers: none */

mme_typ (-2): if trace then call tolts_qttyio_$rs (10, "^a MME ACCWRT @ ^p", ctime (), mmep);
      call return_plus (1);

/* ********* MME ASGPAT ********* (assign peripheral allocation table, unused in Multics)

   input registers:   X1 = sct (test page index mod 4),   X4 = pat address (lal offset)

   mme     asgpat
   ------  return

   return registers: X2 = sct word 1 (returned = 0) */

mme_typ (-5): if trace then call tolts_qttyio_$rs (10, "^a MME ASGPAT @ ^p", ctime (), mmep);
      spa.regs.x (2) = "0"b;				/* set # modules to zero */
      call return_plus (1);
%page;
/* *********************************************************************************
   *   alternate mtar device is defined as  "alt sct addr = (page index) *4 + 512   *
   ********************************************************************************* */

/* ********* MME ALLOCR ********* (allocate peripheral)

   input registers:   x1 = sct (test page index mod 4)
   x3 = chan number if new format

   mme	allocr
   zero	ficcdd,delaysct			ficcdd ptr, sct value if delayed allocation
   zero	sctwrk,mtardata	                    ficcdd ptr to sct work area.
   mtardata is storage for (even) mtar r/w flag (molts only)
   zero	alcflg,0				ptr to alcflg
   zero	alcccp,dldcwp			ptr to courtesy call routine, ptr to dcw for delayed allocation message
   ----	return error 			(mme call + 5)
   ----	return ask stranger permission	(mme call + 6)
   ----	return not free			(mme call + 7)
   ----	return allocated or usage count bumped	(mme call + 8)
   ----	return shared device		(mme call + 9)
   ----	return allocation in progress, wait	(mme call + 10)

   return registers:	X2 = error code on error (see set_sctwrk subroutine for error codes)
   *			output in sctwrk (12 words): see the set_sctwrk subroutine */

mme_typ (-4): if trace then call tolts_qttyio_$rs (10, "^a MME ALLOCR @ ^p", ctime (), mmep);
      call get_px_sct ("ALLOCR", bin (spa.regs.x (1), 17), "0"b); /* get test page index */
      call set_sctwrk (io_sel);			/* go set up the sct work area */
      if spa.regs.x (2) ^= "0"b then do;		/* if some error from tolts_device_info_... */
         if fixed (spa.regs.x (2)) = m_iv_iom then	/* if invalid IOM number... */
	  spa.regs.x (2) = "0"b;			/* correct error code */
         call return_plus (5);			/* take error return */
      end;
      io_info_ptr = addr (pages (io_sel));		/* get ptr to this test page */

/* create an event call channel for tdio status events */

      if ^io_info.ev_ch_ass then do;			/* we we havn't done this already */
         call tolts_init_$cr_event_chan (io_info.status_event,
	"1"b, tolts_io_int_, io_info_ptr, 2, error);
         if error ^= 0 then				/* if error creating event call chan */
	  call tolts_abort ("$a9");
         io_info.ev_ch_ass = "1"b;			/* set event chan assigned flag */
      end;

      if mme_call_hf (1).lower = 0 then do;		/* if we havn't already attached perp... */
         alt_flag, rd_flag = "0"b;			/* make sure we start in a known state */
         if io_info.devsct.type_code = "22"b3		/* if ccu as a reader */
	& ^io_info.ccu_pun then rd_flag = "1"b;		/* set read flag */
         if ^io_info.alloc_wait & ^io_info.p_att then do;

	  if io_info.io_type = mca_io_type
	   & io_info.mca_attach_state = MCA_NOT_CONFIGURED then do;
	     call mca_$attach_mca ((io_info.device_name), io_info.status_event,
	      io_info.mca_ioi_idx, error);
	     io_info.mca_attach_state = MCA_FREE;
	  end;
	  else do;

attach:	     if ^alt_flag then do;			/* if we want the primary or only channel */
	        call ioa_$rsnnl ("T&D is attaching for a ^[write^]^[read^] ^a",
	         att_desc, mesg_len, (^rd_flag), (rd_flag), io_info.device_name);
	        call rcp_priv_$attach (io_info.rcp_name, addr (io_info.rcp_area (1)), io_info.status_event,
	         att_desc, io_info.rcp_id, error);
	     end;
	     else do;
	        call ioa_$rsnnl ("T&D is attaching for a ^[write^]^[read^] ^a",
	         att_desc, mesg_len, (^rd_flag), (rd_flag), io_info.alt_device_name);
	        call rcp_priv_$attach (io_info.rcp_name, addr (io_info.alt_rcp_area (1)), io_info.status_event,
	         att_desc, io_info.alt_rcp_id, error);
	     end;

	     if error ^= 0 then do;
	        call output_status_code (error, "rcp attach error");
	        call dealcp_sub;			/* go release status event */
	        spa.regs.x (2) = bit (os_deny);		/* set appropriate error code */
	        call return_plus (5);			/* take error return */
	     end;
	     if ^alt_flag then
	        call rcp_$check_attach (io_info.rcp_id, addr (io_info.rcp_area (1)), coment, io_info.device_index,
	         tolts_info.max_wks_sz, tolts_info.max_to, io_info.rcp_state, io_info.attach_err);
	     else call rcp_$check_attach (io_info.alt_rcp_id, addr (io_info.alt_rcp_area (1)), coment,
		 io_info.alt_device_index, tolts_info.max_wks_sz,
		 tolts_info.max_to, io_info.rcp_state, io_info.attach_err);

	  end;
         end;
      end;

/* only one call to rcp_$check_attach here. If delayed allocation (tape or disk),  RCP  will  signal
   (via  the  status call channel) tolts_io_int_, when an event has ocurred. tolts_io_int_ will check the
   rcp state flag and either return and let RCP work if attachment is incomplete or enter the  courtesy
   call request and signal the dispatcher if the attachment is complete or if an error has occurred */

/* *********************************************
   *   check for mtar write permission denial	*
   ********************************************* */

      if io_info.io_type = mtar_io_type
       & (^io_info.p_att | io_info.alt_dev_flag) then do;
         if io_info.attach_err = error_table_$force_unassign then do;
	  if ^alt_flag then disk_info_ptr = addr (io_info.rcp_area (1));
	  else disk_info_ptr = addr (io_info.alt_rcp_area (1));
	  if ^rd_flag then do;			/* opr denied write request */
	     disk_info.write_flag = "0"b;		/* read only */
	     rd_flag = "1"b;
	     goto attach;
	  end;
	  else do;
	     call output_status_code (io_info.attach_err, "ioi_assign error--check attach");
	     call dealcp_sub;			/* go release status event */
	     spa.regs.x (2) = bit (os_deny);		/* set appropriate error code */
	     call return_plus (5);			/* take error return */
	  end;
         end;
      end;

      if ^io_info.p_att | ^io_info.p2_att then do;

         if io_info.attach_err ^= 0
	| error ^= 0 then do;
	  if io_info.attach_err = error_table_$resource_unavailable then do; /* must have been busy */
	     spa.regs.x (2) = bit (dev_busy);		/* set appropriate error code */
	     if ^io_info.dev_busy then do;		/* only output device busy message once */
	        call tolts_qttyio_$rs (0, "^a device busy, allocation queued", io_info.test_hdr);
	        io_info.dev_busy = "1"b;		/* set flag so we only output message once */
	     end;
	     call return_plus (7);			/* return ic + 7 */
	  end;
	  if io_info.io_type ^= mca_io_type then
	     call output_status_code (io_info.attach_err, "ioi_assign error--check attach");
	  else call output_status_code (error, " mca assign error");
	  call dealcp_sub;				/* go release status event */
	  spa.regs.x (2) = bit (os_deny);		/* set appropriate error code */
	  call return_plus (5);			/* take error return */
         end;
         if io_info.rcp_state ^= 0			/* return - allocation wait */
	| (io_info.io_type = mca_io_type
	& io_info.mca_attach_state < MCA_ATTACHED) then do;
	  io_info.alloc_wait = "1"b;			/* set wait flag for tolts_io_int_ */
	  io_info.icivlu.ic = mme_call_hw (4).upper;	/* save ccc ptr for tolts_io_int_ */
	  io_info.icivlu.ind = "0"b;
	  call tolts_qttyio_$dcw_list (addrel (execp, mme_call_hf (4).lower), 0);
	  tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1; /* increment global IO count */
	  call return_plus (10);			/* return ic + 10, allocation wait */
         end;

         if io_info.io_type = mdr_io_type & ^io_info.p2_att then /* if running mdrs */
	  if substr (io_info.device_name, 1, 3) = "tap"	/* if tape */
	   | substr (io_info.device_name, 1, 3) = "dsk" then do; /* or disk */
	     io_info.p2_att = "1"b;			/* set perph attach flag */
	     io_info.alt_rcp_id = io_info.rcp_id;	/* mv rcp id to alt rcp id */
	     go to mme_typ (-4);			/* we have the mpc now go get the dev */
	  end;
         if ^alt_flag then io_info.p_att = "1"b;		/* set perp attach flag */
         else io_info.p2_att = "1"b;
         io_info.dev_busy = "0"b;			/* reset device busy flag */
      end;


/* ***************************************************
   *   attach alternate device for mtar if required   *
   *************************************************** */


      if io_info.io_type = mtar_io_type & io_info.alt_dev_flag
       & io_info.p_att & ^io_info.p2_att then do;

         if rd_flag then do;				/* sct requested permission equal to that of primary */
	  disk_info_ptr = addr (io_info.alt_rcp_area (1));
	  disk_info.write_flag = "0"b;
	  rd_flag, alt_flag = "1"b;
	  goto attach;
         end;
         else do;
	  disk_info_ptr = addr (io_info.alt_rcp_area (1));
	  disk_info.write_flag = "1"b;
	  rd_flag = "0"b;
	  alt_flag = "1"b;
	  goto attach;
         end;
      end;




/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
/*   set permission code for mtar								*/
/*   The address for permission storage is in the lower half of (mme call + 2).				*/
/*   appropriate permission is stored in the lower half of the target word,      			*/
/*    0 = write permission, 8 = read permission                                                               */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/



      if ^rd_flag then
         exec_wd (mme_call_hf (2).lower) = exec_wd (mme_call_hf (2).lower) & "777777000000"b3;
      else exec_wd (mme_call_hf (2).lower) = (exec_wd (mme_call_hf (2).lower)) | ("000000000010"b3);
      if io_info.rcp_name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then /* if tape device... */
         call decode_den;				/* go decode density info */

      if io_info.io_type = mca_io_type then
         call get_temp_segment_ ("mca_workspace", io_info.workspace_ptr, error);
      else call ioi_$workspace (io_info.device_index, io_info.workspace_ptr, tolts_info.wks_sz, error);
      if error ^= 0 then do;
         call output_status_code (error, "workspace assign error");
         call dealcp_sub;				/* go release status event */
         spa.regs.x (2) = bit (os_deny);		/* set appropriate error code */
         call return_plus (5);			/* take error return */
      end;
      io_info.cur_wks_sz = tolts_info.wks_sz;		/* set current value of workspace size */
      if io_info.io_type ^= mca_io_type then do;
         ioi_wksp = io_info.workspace_ptr;
         call ioi_$set_status (io_info.device_index, fixed (rel (addr (tolts_workspace.status)), 18), 1, error);
         if error ^= 0 then do;
	  call output_status_code (error, "set_status error");
	  call dealcp_sub;				/* go detach and release status event */
	  spa.regs.x (2) = bit (os_deny);		/* set appropriate error code */
	  call return_plus (5);			/* take error return */
         end;
         if io_info.nff then do;
	  iom = fixed (substr (io_info.devsct.icc, 1, 3), 3) + 1;
	  chan = fixed (substr (io_info.devsct.icc, 6, 6), 6);
         end;
         else do;
	  iom = fixed (substr (io_info.devsct.icc, 1, 3), 3) + 1;
	  chan = fixed (substr (io_info.devsct.icc, 4, 6), 6);
         end;
         call ioi_$set_channel_required (io_info.device_index, iom, chan, error);
         if error ^= 0 then do;
	  call output_status_code (error, "set_channel error");
	  call dealcp_sub;				/* go detach and release status event */
	  spa.regs.x (2) = bit (os_deny);		/* set appropriate error code */
	  call return_plus (5);			/* take error return */
         end;

         timeout_time = 30000000;			/* set timeout to a minimum value of 30 sec */
         if io_info.io_type = mdr_io_type
	& io_info.devsct.type_code = "001110"b then	/* if mdr and 601/610 */
	  timeout_time = 390000000;			/* set timeout to 6.5 mins */
         else if io_info.io_type = itr_io_type		/* if mdrs on an eurc */
	& io_info.devsct.cr501_pr54 then
	  timeout_time = 60000000;			/* time_out = 1min */
         else if io_info.io_type = mtar_io_type then
	  timeout_time = 90000000;			/* time_out = 1.5min */
         io_info.lostit_time =			/* set lostit time = time_out time + 1sec * 64 / 1000 */
	divide ((timeout_time + 1000000) * 64, 1000, 35);
         call ioi_$timeout (io_info.device_index, timeout_time, error);
         if error ^= 0 then do;
	  call output_status_code (error, "set timeout error");
	  call dealcp_sub;				/* go release status event */
	  spa.regs.x (2) = bit (os_deny);		/* set appropriate error code */
	  call return_plus (5);			/* take error return */
         end;
      end;
      io_info.allocated = "1"b;
      call return_plus (8);				/* return ic + 8 - good return */
%page;
/* ********* MME CATA. ********* (Get itr or mdr deckfile catalog)

   input registers:		qu = ICC
   *			x1 = ptr to call seq (defined by cata_call structure (below)
   *			x2 = max load address
   *			x3 = test page base
   mme     cata.
   ------  return if error
   ------  return if more or extenstion file follows
   ------  return if all read

   return registers:	AL    = words read in this call
   *			Q-reg = error code
   *			status word 1 bit 18 set for extension call */

dcl  1 cata_call based (genp) aligned,			/* structure for mme cata and mme data */
       (2 fdcwp bit (18),				/* first dcw ptr */
       2 statp bit (18),				/* ptr to status */
       2 patp bit (18),				/* ptr to PAT entry */
       2 nblk fixed bin) unaligned;			/* next catalog block */

mme_typ (-50): if trace | tcd then call tolts_qttyio_$rs (10, "^a MME CATA. @ ^p", ctime (), mmep);
      if substr (spa.regs.q, 7, 1) then			/* if new format */
         call get_px_tcx ("CATA. ", substr (spa.regs.q, 8, 11)); /* get test page index */
      else call get_px_tcx ("CATA. ", substr (spa.regs.q, 10, 9)); /* get test page index */
      if io_info.io_type = mca_io_type then do;
         if io_info.mcata_idx = 0 then do;
	  call tolts_util_$cata_sel (tolts_info.df_iocbp, "cata.nio.mca", addr (io_info.n_keys), error);
	  if error ^= 0 then do;			/* if we couldn't find catalog */
	     call output_status_code (error, "selecting catalog subset of cata." || io_info.cat_name);
	     call return_plus (1);			/* take error return */
	  end;
	  call tolts_util_$search (tolts_info.df_iocbp, (io_info.cata_keys (1)), io_info.catp, c_len, error);
	  if error ^= 0 then do;			/* if we couldn't find catalog */
	     call output_status_code (error, "searching for " || io_info.cata_keys (io_info.mcata_idx));
	     call return_plus (1);			/* take error return */
	  end;
	  do io_info.mcata_nkeys = 1 to cata.n;
	     io_info.mcata_keys (io_info.mcata_nkeys) = cata.key (io_info.mcata_nkeys);
	  end;
	  io_info.mcata_idx = 1;
         end;
         io_info.cat_name = substr (io_info.mcata_keys (io_info.mcata_idx), 6, 7);
      end;
      if io_info.catx = 0 then do;			/* only select catalog keys once */
         call tolts_util_$cata_sel (tolts_info.df_iocbp, "cata." || io_info.cat_name, addr (io_info.n_keys), error);
         if error ^= 0 then do;			/* if we couldn't find catalog */
	  call output_status_code (error, "selecting catalog subset of cata." || io_info.cat_name);
	  call return_plus (1);			/* take error return */
         end;
         io_info.catx = io_info.n_keys;
         if io_info.io_type ^= mca_io_type
	& io_info.n_keys > 1 then do;			/* multiple catalogs */
	  call tolts_qttyio_$rs (0, "^a Multiple catalog files (^d) for ^a ^a catalog.",
	   io_info.test_hdr, io_info.n_keys, substr (io_info.cat_name, 5), substr (io_info.cat_name, 1, 3));
	  do io_info.catx = 1 to io_info.n_keys;
	     i = search (substr (io_info.cata_keys (io_info.catx), 10), ".");

	     call tolts_qttyio_$rs (0, "^a ^a catalog, ^[firmware rev ^a^] - ",
	      substr (io_info.cata_keys (io_info.catx), 10, i - 1),
	      substr (io_info.cata_keys (io_info.catx), 6, 3),
	      (substr (io_info.cata_keys (io_info.catx), 6, 3) = "itr"),
	      substr (io_info.cata_keys (io_info.catx), 10 + i));
	  end;
	  call tolts_qttyio_$rs (0, "^a^/^a",
	   "Indicate which one is to be used by answering yes to",
	   "one of the following catalog entrys:");
	  tolts_info.mult_ans = "";			/* clear out response */
	  do io_info.catx = 1 to io_info.n_keys while (mult_ans = "" | mult_ans = "no" | mult_ans = "n");
	     i = search (substr (io_info.cata_keys (io_info.catx), 10), ".");
requery:
	     call tolts_qttyio_$rs (19, "^a ^a catalog, ^[firmware rev ^a^] - ",
	      substr (io_info.cata_keys (io_info.catx), 10, i - 1),
	      substr (io_info.cata_keys (io_info.catx), 6, 3),
	      (substr (io_info.cata_keys (io_info.catx), 6, 3) = "itr"),
	      substr (io_info.cata_keys (io_info.catx), 10 + i));
	     call message_wait;			/* wait for user response */
	     if tolts_info.mult_ans ^= ""
	      & (mult_ans ^= "yes" & mult_ans ^= "y")
	      & (mult_ans ^= "no" & mult_ans ^= "n") then do;
	        call tolts_qttyio_ ("Please answer yes, no, or eom", 0);
	        go to requery;			/* go ask again */
	     end;
	  end;
	  io_info.catx = io_info.catx - 1;		/* currect io_info.catx */
	  if io_info.catx > io_info.n_keys
	   | (mult_ans ^= "yes" & mult_ans ^= "y") then
	     call return_plus (1);			/* take error return */
         end;
      end;
      else if io_info.io_type = mca_io_type then do;
         if ^io_info.cata_cycle then io_info.cata_cycle = "1"b; /* first time thru */
         else do;					/* must be second pass */
	  if io_info.catx > 1 then			/* if diskette catalog index > 1 */
	     io_info.catx = io_info.catx - 1;		/* subtract 1 */
	  else do;				/* else move to the mca cata index */
	     io_info.mcata_idx = io_info.mcata_idx + 1;
	     io_info.catx = 0;			/* reset the diskette catalog index */
	  end;
	  io_info.cata_cycle = "0"b;
         end;
         spa.regs.a = "0"b;				/* intialize words read to 0 */
      end;
      if io_info.catx ^= 0 then do;
         call tolts_util_$search (tolts_info.df_iocbp, (io_info.cata_keys (io_info.catx)), io_info.catp, c_len, error);
         if error ^= 0 then do;			/* if we couldn't find catalog */
	  call output_status_code (error, "searching for " || io_info.cata_keys (io_info.catx));
	  call return_plus (1);			/* take error return */
         end;
         genp = addrel (execp, spa.regs.x (1));		/* get ptr to slave call */
         dcwp = addrel (execp, cata_call.fdcwp);		/*  get ptr to dcw */
         gcatp = addrel (execp, dcw.address);		/* get ptr to buffer */
         if trace | tcd then call tolts_qttyio_$rs (10, "MME CATA.; loading catalog ""cata.^a"" @ ^p",
	   io_info.cat_name, gcatp);
         do i = 1 to cata.n;				/* give page all catalog entries */
	  if io_info.io_type = mca_io_type then do;
	     unspec (mca_gcata (i)) = "0"b;		/* reset this entry */
	     mca_gcata (i).cat_index, mca_gcata (i).nblk = i; /* set cata index & block number */
	     if index (cata.key (i), "HDR") ^= 0 then do;
	        mca_gcata (i).dipper_flag = "0100"b;	/* set header flag */
	        filename_idx = index (cata.key (i),
	         after (cata.key (i), "HDR."));		/* get index of filename */
	     end;

	     else if index (cata.key (i), "DIR") ^= 0 then do;
	        mca_gcata (i).dipper_flag = "0101"b;	/* set dir flag */
	        filename_idx = index (cata.key (i), "DIR"); /* get index of filename */
	     end;

	     else if index (cata.key (i), "cata") ^= 0 then do;
	        mca_gcata (i).dipper_flag = "0100"b;	/* set cata flag */
	        filename_idx = index (cata.key (i),
	         after (cata.key (i), "nio."));		/* get index of filename */
	     end;

	     else filename_idx = index (cata.key (i),
		 after (cata.key (i), "nio."));	/* get index of filename */
	     call tolts_alm_util_$ascii_to_bcd_
	      (substr (cata.key (i), filename_idx, 12), bit_buf);
	     unspec (mca_gcata (i).filename) = bit_buf;
	  end;

	  else do;
	     unspec (gcata (i)) = "0"b;		/* clear element first */
	     j = length (rtrim (cata.key (i)));		/* get true length of key */
	     ac_name = substr (cata.key (i), j - 6, 4) || substr (cata.key (i), j - 1, 2);
	     call tolts_alm_util_$ascii_to_bcd_ (ac_name, gcata (i).edit_rev); /* set edit name an rev */
	     gcata (i).cat_index, gcata (i).nblk = i;	/* set index */
	     if j < 13 then
	        call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), j, 6), gcata (i).ident); /* set ident */
	     else call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), j - 13, 6), gcata (i).ident); /* set ident */
	     if index (cata.key (i), ".") > 4 then	/* if firmware */
	        call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), 1, 6), gcata (i).purpose);
	     else do;
	        call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), 1, 3), b18);
	        substr (gcata (i).purpose, 19, 18) = b18;
	     end;
	  end;
         end;
         spa.regs.a = bit (bin (cata.n * 4, 36));		/* set words read */
      end;
      if io_info.mcata_idx <= io_info.mcata_nkeys
       & io_info.io_type = mca_io_type then call return_plus (2); /* still more catalogs to read */
      else call return_plus (3);			/* take good return */



/* ********* MME CHANTM ********* (channel time)

   input registers:   X1 = sct (test page index mod 4),   X4 = pat address (lal offset)

   mme     chantm
   ------  return

   return registers: AR = channel time */

mme_typ (-6): if trace then call tolts_qttyio_$rs (10, "^a MME CHANTM @ ^p", ctime (), mmep);
      call get_px_sct ("CHANTM", bin (spa.regs.x (1), 17), "1"b); /* get test page index */
      spa.regs.a = bit (bin (pages (io_sel).chan_time, 36));
      call return_plus (1);

/* ********* MME CLEARQ ********* (clear ISC queue)

   input/return registers: none

   mme     clearq
   ------  return */

mme_typ (-7): if trace then call tolts_qttyio_$rs (10, "^a MME CLEARQ @ ^p", ctime (), mmep);
      isc_ccc_rqt = "0"b;
      if isc_cntdn ^= 1 then isc_cntdn = 0;
      call return_plus (1);
%page;
/* ********* MME COINIT ********* (colts slave executive initialize)

   input/output registers: none

   mme	coinit
   zero	6,0       number of designators
   zero	wwflag,1
   zero	lstloc,2	core size available as loaded
   zero	tdflt,5	wrapup address
   zero	mmexec,7  interface module ttl
   zero   systyp,10  os type
   zero	crd30,11   .crd30	  bit 17 = 1 if fnp active and 18-29 = # of active fnps
   ----	return	return is mme call + the number of designators + 2

   .crfig:

   0 = series 60 0r 6000	6 = system sckd. save opt.		24-30 = reserved for gcos
   1 = class. module present	7 = reserved for gcos		31 = not in mem avail. space tab
   2 = shared memory system	8,9,10,11 = ioms 0-3 configured	32 = RLP300 present
   3 = >256k		12,13,14,15 = CPUs 0-3 configured	33 = DN30
   4 = IOM system		16-19 = reserved for gcos		34 = DN305
   5 = series 60 system	20,21,22,23 = CPU has EIS		35 = DN	355/6600
*/


mme_typ (-62): if trace then call tolts_qttyio_$rs (10, "^a MME COINIT @ ^p", ctime (), mmep);
      exec_wd (mme_call_hf (2).upper) = "0"b;		/*	zeros says not ww system */
      spa.wrapup_add = mme_call_hw (4).upper;		/* set wrapup address */
      call tolts_alm_util_$ascii_to_bcd_ (ttl_date, bcd_callname); /* convert ttl date to bcd */
      exec_wd (mme_call_hf (5).upper) = bcd_callname;	/* and store in message */
      substr (exec_wd (mme_call_hf (5).upper - 1), 19, 18) = "622017"b3; /* change version? ?? to version?s ? */
      genp = addrel (execp, mme_call_hf (3).upper);	/* get ptr to lstloc */
      if fix_wd (1) ^= 0 then				/* if lstloc specified... */
         mem_now, fix_wd (1) = fix_wd (1) + 49152;	/* add 48k to lstloc */
      else mem_now, fix_wd (1) = fixed (gload_data.text_len) + 49152; /* otherwise use loaded length */
      call cpu_time_and_paging_ (i, cpu_time, j);		/* get current cpu time */
      tolts_info.init_time = cpu_time;			/* save  */
      exec_wd (mme_call_hf (6).upper) = "000000000002"b3;	/* set os to multics */
      exec_wd (mme_call_hf (7).upper) = "000001001000"b3;	/* set fnp present bit and number of active fnp's to max */
      fnp.status_word, colts_pages.status_word = "000000000004"b3;
      call return_plus (8);

/* ********* MME CONTML ********* (controlling terminal)

   input registers:   x1 = old controlling terminal

   mme     contml
   ------  return tolts aborted
   ------  return tolts swapped
   ------  return denied
   ------  return slaves copying
   ------  return good

   return registers:   x1 = new logical controlling terminal in lower */

mme_typ (-8): if trace then call tolts_qttyio_$rs (10, "^a MME CONTML @ ^p", ctime (), mmep);
      spa.regs.x (1) = "000004"b3;			/* coded terminal 4 */
      call return_plus (5);				/* return ic + 5 */

%page;

/* ********* MME DATA. ********* (Get itr or mdr from deckfile)

   input registers:		qu = ICC
   *			x1 = ptr to call seq (defined by cata_call structure (see MME CATA.)
   *			x2 = max load address
   *			x3 = test page base
   *			x4 = diskette sector number relative to sector 0

   mme     data.
   ------  return if error
   ------  return if more or extenstion file follows
   ------  return if all read

   return registers:	AL    = words read in this call
   *			Q-reg = error code
   *			status word 1 bit 18 set for extension call */

mme_typ (-51): if trace | tcd then do;
         call tolts_qttyio_$rs (10, "^a MME DATA. @ ^p to load ^a",
	ctime (), mmep, cata.key (cata_call.nblk));
         genp = addrel (execp, spa.regs.x (1));		/* get ptr to slave call */
      end;

      if substr (spa.regs.q, 7, 1) then			/* if new format */
         call get_px_tcx ("DATA. ", substr (spa.regs.q, 8, 11)); /* get test page index */
      else call get_px_tcx ("DATA. ", substr (spa.regs.q, 10, 9)); /* get test page index */
      genp = addrel (execp, spa.regs.x (1));		/* get ptr to slave call */
      dcwp = addrel (execp, cata_call.fdcwp);		/*  get ptr to dcw */
      l_ptr = addrel (execp, dcw.address);		/* get ptr to buffer */
      call tolts_util_$search (tolts_info.df_iocbp, (cata.key (cata_call.nblk)), t_ptr, c_len, error);
      if error ^= 0 then do;				/* if we couldn't find module */
         call output_status_code (error, "searching for " || cata.key (cata_call.nblk));
         call return_plus (1);			/* take error return */
      end;

      if io_info.io_type = mca_io_type then do;
         if spa.regs.x (4) ^= "777777"b3 then do;		/* if data is wanted */
	  io_info.catx = 0;
	  io_info.mcata_idx = 1;
	  t_ptr = addrel (t_ptr, fixed (spa.regs.x (4)) * 64); /* adjust the ptr to the correct sector */
	  if bin (dcw.tally) = 0 then tally = 4096;	/* ck for a zero tally */
	  else tally = bin (dcw.tally);
	  if c_len < (fixed (spa.regs.x (4)) * 64) + tally then /* if the data wanted is > then end */
	     c_len = c_len - fixed (spa.regs.x (4)) * 64; /* adjust the amount to be sent */
	  else c_len = tally;
	  if c_len < 0 then call return_plus (1);	/* should not happen */
	  mvp = addrel (execp, dcw.address);		/* set mvp to where data is to go */
	  data_move = t_ptr -> data_move;		/* move it */
	  spa.regs.a = bit (bin (c_len, 36));		/* set words read */
         end;
         else spa.regs.a = "0"b;
      end;
      else do;
         call gload_ (t_ptr, l_ptr, fixed (spa.regs.x (3), 18), addr (gload_data), error); /* load it */
         if error ^= 0 then do;
	  call output_status_code (error,
	   gload_data.diagnostic || " loading module " || cata.key (cata_call.nblk));
	  call return_plus (1);			/* take error return */
         end;
         spa.regs.a = bit (bin (gload_data.text_len, 36));	/* set words read */
      end;
      if trace | tcd then call tolts_qttyio_$rs (10, "MME DATA.; loaded ""^a"" @ ^p to ^p for ^d",
	cata.key (cata_call.nblk), t_ptr, l_ptr, spa.regs.a);

      call return_plus (3);				/* take good return */

%page;

/* ********* MME DEALCP ********* (deallocate peripheral)

   input registers:   x1 = sct (test page index mod 4)

   mme     dealcp
   ------  return

   return registers: none */

mme_typ (-9): if trace then call tolts_qttyio_$rs (10, "^a MME DEALCP @ ^p", ctime (), mmep);
      call get_px_sct ("DEALCP", bin (spa.regs.x (1), 17), "0"b); /* get test page index */
      call dealcp_sub;
      if dealc_err ^= 0 then
         call tolts_abort ("$b3");
      else call return_plus (1);




/* ********* MME DOFPIO ********* (mme to do reponder io)

   input registers:
   x1 = pointer to FPINFO table
   x3 = test page base
   a  = PCW like direct_channel_pcw
   q  = time out time

   I/O COMMANDS
   71 - Interrupt fnp (uses level 3, 4, 5, 6 & 77)
   72 - Bootload fnp (not used)
   73 - Interrupt host (uses level 3 & 7)
   75 - Test data xfer (fnp - host)
   76 - Test data xfer (host - fnp)


   mme	DOFPIO
   zero	good return       (mme call + 1) */


mme_typ (-89): if trace | trace_io then call tolts_qttyio_$rs
	(10, "^a MME DOFPIO ^p, type - ^12.3b", ctime (), mmep, substr (spa.regs.a, 25));

      tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1));

      do io_sel = 1 to hbound (tolts_info.pages, 1)	/* get the correct io_info for this page */
       while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num);
      end;

      if io_sel > hbound (tolts_info.pages, 1) then call tolts_abort ("$c3");
      io_info_ptr = addr (pages (io_sel));
      io_info.fpinfo_ptr = tolts_fpinfo_ptr;		/* save fpinfo_ptr for this page */
      tolts_rspd_wksp = io_info.tolts_rspd_wksp;		/* get work space ptr */
      tolts_fpinfo.fnpdcw.address =			/* set dcw address */
       bin (bin (spa.regs.x (3), 18) + bin (substr (spa.regs.a, 1, 18), 18), 18);
      direct_channel_pcw_ptr =			/* set pcw */
       addr (tolts_rspd_workspace.mailbox.pcw);
      substr (unspec (direct_channel_pcw), 19) = substr (spa.regs.a, 19);
      substr (unspec (tolts_fpinfo.pcw_info), 19) =
       substr (spa.regs.a, 19);			/* save pcw for test page */
      io_info.dcw_list (1) = exec_wd (tolts_fpinfo.fnpdcw.address); /* set dcw */
      direct_channel_tcw_ptr = addr (tolts_rspd_workspace.tcw); /* get tcw */
      unspec (direct_channel_tcw) = unspec (io_info.dcw_list (1));
      if direct_channel_pcw.operation = "75"b3		/* if data xfer pcw */
       | direct_channel_pcw.operation = "76"b3 then do;	/* set up pcw */
         substr (spa.regs.a, 1, 18) = unspec (tolts_fpinfo.fnpdcw.address);
         direct_channel_pcw.tcw_address = wordno (addr (tolts_rspd_workspace.tcw));
      end;

      else direct_channel_pcw.tcw_address = 0;		/* else set to 0 */
      io_info.pcwa = spa.regs.a;
      if direct_channel_pcw.operation = "76"b3 then do;	/* if sending data - move it */
         c_len = direct_channel_tcw.host_word_count;
         mvp = addrel (execp, bin (substr (spa.regs.a, 1, 18)) + 1);
         bufp = addr (tolts_rspd_workspace.data_buf);
         workspace_move = mvp -> workspace_move;
      end;

      tolts_rspd_workspace.pcw = direct_channel_pcw;
      unspec (tolts_rspd_workspace.tcw) = unspec (direct_channel_tcw);
      tio_off = wordno (direct_channel_pcw_ptr);
      io_info.lostit_time = bin (tolts_fpinfo.timeout_time);
      call tolts_init_$gc_tod ((tolts_fpinfo.timeout_time));
      tolts_fpinfo.timeout_time = bit (bin (tolts_fpinfo.timeout_time, 36) + io_info.lostit_time, 35);
      tolts_fpinfo.io_rq_cnt = tolts_fpinfo.io_rq_cnt + 1;	/* bump io request count */

      io_info.io_in_progress = "1"b;
      io_info.num_connects = io_info.num_connects + 1;
      call ioi_$connect (io_info.device_index, tio_off, error);
      if error ^= 0 then do;
         call output_status_code (error, "io connect error");
         call tolts_abort ("$c7");
      end;

      wake_time = 500000;
      call timer_manager_$sleep (wake_time, "10"b);
      tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1;
      call return_plus (1);

/* ********* MME EXPDEV ********* (return device sct)

   input registers:   x1 = sct (test page index mod 4)

   mme     expdev
   ------  return

   return registers: A and Q regs contain 1st and 2nd words of device sct entry */

mme_typ (-12): if trace then call tolts_qttyio_$rs (10, "^a MME EXPDEV @ ^p", ctime (), mmep);
      call get_px_sct ("EXPDEV", bin (spa.regs.x (1), 17), "1"b); /* get test page index */
      spa.regs.a = unspec (io_info.devsct.w1);		/* set sct in a  */
      spa.regs.q = unspec (io_info.devsct.w2);		/* and q registers */
      call return_plus (1);

/* ********* MME FEPTYP ********* (return fnp type)

   input registers:   x2 =  logical fep number * 4

   mme     feptyp
   oct	 0         data returned here
   ------  return	     */



mme_typ (-59): if trace then call tolts_qttyio_$rs (10, "^a MME FEPTYP @ ^p", ctime (), mmep);


      cdtp = cdtptr;
      j = bin (spa.regs.x (2));			/* get true fnp number */
      tolts_info.fnp (j).type = (fnp_entry (j + 1).type);	/* find type */
      if tolts_info.fnp (j).type = 1 then spa.regs.x (2) = "000002"b3; /* if type 1 (dn355) set code */
      else if tolts_info.fnp (j).type = 3
       then spa.regs.x (2) = "000001"b3;		/* if type 3 (DN6670) set code */
      else if tolts_info.fnp (j).type = 0
       then spa.regs.x (2) = "777777"b3;		/* if type = 0 then illegal type set error return */
      if fnp_entry (j + 1).mpxe.current_service_type ^= 1
       & fnp_entry (j + 1).state ^= 4 then do;		/* if fnp is not up */
         spa.regs.x (2) = "777777"b3;			/* return a bad code */
         call tolts_qttyio_$rs (0, "^as: fnp ^a is ^a", exec, tags (j + 1),
	fnp_state (fnp_entry (j + 1).mpxe.state));	/* notify the user */
      end;
      call return_plus (1);


/* ********* MME FPWRAP ********* (Responder wrapup)

   input registers:   X1 = fpinfo pointer

   mme     fpwrap
   ------  return    */


mme_typ (-93): if trace then call tolts_qttyio_$rs (10, "^a MME FPWRAP @ ^p", ctime (), mmep);

      tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1));	/* get pointer to test page fpinfo table */

      do io_sel = 1 to hbound (pages, 1)		/* get the correct io_info for this page */

       while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num);
      end;

      if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* page not found - */
      io_info_ptr = addr (pages (io_sel));
      tolts_rspd_wksp = io_info.tolts_rspd_wksp;		/* get the io workspace for this page */
      tolts_fpinfo.partrs = 0;			/* reset tolts assigned flag */
      if ^io_info.io_in_progress then tolts_fpinfo.io_rq_cnt = 0; /* reset io rquest count */
      unspec (tolts_rspd_workspace.mailbox.num_int) = "0"b; /* reset int count */
      tolts_rspd_workspace.mailbox.status_word = "0"b;
      call dealcp_sub;				/* release the fep */
      call return_plus (1);



/* ********* MME FREEZE ********* (wire main memory (gcos only))

   input registers:   none

   mme     freeze
   ------  return

   return registers: X5 = LAL (returned = 0) */


mme_typ (-53): if trace then call tolts_qttyio_$rs (10, "^a MME FREEZE @ ^p", ctime (), mmep);
      spa.regs.x (5) = "0"b;				/* set x 5 to 0 */
      call return_plus (1);
%page;


/* ********* MME GECALL ********* (load object deck)

   input registers: none
   output register: q       error code entry options(variable)
   mme     gecall
   bci     1,name
   zero    add,error return
   zero    transfer add,0 */



mme_typ (18): call bcd_to_ascii_ (mme_call_w (1), ac_name); /* convert callname to ascii */
      if trace then call tolts_qttyio_$rs (10, "^a MME GECALL (^a) @ ^p", ctime (), ac_name, mmep);
      coment = "";
      l_ptr = addrel (execp, mme_call_hf (2).upper);
      call tolts_util_$search (tolts_info.df_iocbp,
       substr (tolts_info.exec, 1, 1) || "lt." || ac_name, t_ptr, c_len, error);
      if error ^= 0 then				/* if could'nt find polt or molt page, try util */
         call tolts_util_$search (tolts_info.df_iocbp, "utl." || ac_name, t_ptr, c_len, error);
      if error ^= 0 then				/* if found test page */
         call ioa_$rsnnl ("searching for test page ^a", coment, mesg_len, ac_name);
      if error = 0 then
         call gload_ (t_ptr, l_ptr, fixed (spa.regs.x (3), 18), addr (gload_data), error); /* load it */
      if error ^= 0 then do;
         if coment = "" then
	  call ioa_$rsnnl ("^a loading test page ^a", coment, mesg_len, gload_data.diagnostic, ac_name);
         call output_status_code (error, coment);
         if mme_call_hw (2).lower = "0"b		/* error return = 0 */
	then spa.enter.icivlu = spa.wrapup_add;		/* set return to molts wrapup */
         else do;
	  spa.enter.icivlu.ic = mme_call_hw (2).lower;	/* error return */
	  mme_call_hw (2).lower = "0"b;		/* zero error return to prevent loop */
	  spa.regs.q = "63"b3;			/* set q = file not found eror code */
         end;
      end;
      else spa.enter.icivlu.ic = mme_call_hw (3).upper;	/* normal return */
      call wake_disp;				/* go wake up dispatcher */

/* ********* MME GEENDC ********* (end courtesy call)

   input/return registers: none

   mme     geendc
   no return from mme,   enters code whereever ccc interrupted */

mme_typ (14): if trace | trace_io then call tolts_qttyio_$rs (10, "^a MME GEENDC @ ^p", ctime (), mmep);
      if ^in_ccc then do;				/* if not in courtesy call complain */
         call tolts_qttyio_$rs (0, "^as: MME GEENDC while not in courtesy call", exec);
         call tolts_abort ("$a6");
      end;
      gndc_flag = "1"b;				/* set geendc complete flag */
      in_ccc = "0"b;				/* reset courtesy call flag */
      unspec (spa.regs) = addr (spa.ccc_regs) -> reg_move;
      string (spa.enter.icivlu) = spa.ccc_icivlu;
      call wake_disp;				/* go wake up dispatcher */
%page;
/* ********* MME GEINOS ********* (console write or interslave read)

   input/return registers: none

   isc read:	mme     geinos		console write:	mme     geinos
   *		oct     010000000000			oct     130000000000
   *		zero    quefcd,quedcw			zero    flcode,ondcw
   *		zero    quests,quecc			zero    ofstat,offccc
   *		------  return				------  return   */
mme_typ (1): if trace then call tolts_qttyio_$rs (10, "^a MME GEINOS @ ^p, type - ^12.3b", ctime (), mmep, mme_call_w (1));
      if mme_call_w (1) ^= "130000000000"b3 & mme_call_w (1) ^= "010000000000"b3 then do; /* illegal type */
         call tolts_qttyio_$rs (0, "^as: MME GEINOS type ^12.3b not supported", exec, mme_call_w (1));
         call tolts_abort ("$a7");
      end;
      dcwp = addrel (execp, mme_call_hf (2).lower);	/* get ptr to dcw */
      exec_wd (mme_call_hf (3).upper), exec_wd (mme_call_hf (3).upper + 1) = "0"b; /* set status & dcw res to 0 */
      if mme_call_hw (1).upper = "010000"b3 then do;	/* isc read */
         if dcw.type ^= "0"b then do;			/* dcw not iotd */
	  call tolts_qttyio_$rs (0, "^as: MME GEINOS; Read isc dcw type not iotd. DCW = 12.3b",
	   exec, string (dcw));
	  call tolts_abort ("$a7");
         end;
         if dcw.tally ^= "0003"b3 then do;		/* isc read word cnt must be 3 */
	  call tolts_qttyio_$rs (0, "^as: MME GEINOS; Read isc word count ^= 3. DCW = 12.3b",
	   exec, string (dcw));
	  call tolts_abort ("$a7");
         end;
         if tolts_info.exec_dta_cnt ^= 0 then do;		/* if data to xfer... */
	  j = mme_call_hf (3).upper;			/* copy status address */
	  call pop_isc (j, bin (dcw.address, 17));	/* do it */
	  if mme_call_hf (3).lower ^= 0 then		/* if courtesy call requested */
	     call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
	      mme_call_hw (3).lower || "000000"b3);
         end;
         else do;					/* no data to xfer */
	  isc_cntdn = 10000;
	  if mme_call_hf (3).lower ^= 0 then do;	/* if courtesy call requested */
	     isc_ccc_rqt = "1"b;
	     isc_queue.icivlu = mme_call_hw (3).lower || "000000"b3;
	     isc_queue.status_add = mme_call_hf (3).upper;
	     isc_queue.data_add = fixed (dcw.address);
	  end;
         end;
      end;
      else do;					/* console write */
         if mme_call_hf (3).lower ^= 0 then		/* if courtesy call requested */
	  call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
	   mme_call_hw (3).lower || "000000"b3);
         call tolts_qttyio_$dcw_list (dcwp, 0);		/* output the dcwp */
      end;
      call return_plus (4);				/* return ic + 4 */
%page;
/* ********* MME GELBAR ********* (load base address register)

   input registers:	AR = upper/ptr to LOC1 structure (defined by gelbar_temp below)
   *		QR = CPU time increment beffor interrupt

   mme   gelbar
   no return, return to ic value located in gelbar_temp.ic

   return registers: none */

dcl  1 gelbar_temp based (genp) aligned,		/* template for gelbar loc1 and loc1+1 */
       (2 bar bit (18),				/* desired bar value */
       2 reg_ptr bit (18),				/* ptr to register storage */
       2 ic bit (18),				/* instruction counter */
       2 ind bit (18)) unaligned;			/* indicator register */

mme_typ (31): if trace then call tolts_qttyio_$rs (10, "^a MME GELBAR @ ^p", ctime (), mmep);
      spa.glbtmr = spa.regs.q;			/* store entry timer setting */
      genp = addrel (execp, substr (spa.regs.a, 1, 18));	/* get ptr to LOC1 */
      spa.enter.icivlu.ic = gelbar_temp.ic;		/* set desired ic value */
      spa.enter.icivlu.ind = gelbar_temp.ind;		/* and indicators */
      spa.enter.lbar.bar = gelbar_temp.bar;		/* store new bar value to return */
      spa.acc_fault = gelbar_temp.bar || "000000"b3;	/* also save bar in accum fault status word */
      call tolts_init_$gc_tod (gcos_tod);		/* get current time of day */
      string (spa.glbici) = gcos_tod;			/* save current time of day in word 22 */
      genp = addrel (execp, gelbar_temp.reg_ptr);
      unspec (spa.regs) = genp -> reg_move;		/* move regs to be returned */
      gelbar = "1"b;				/* and set gelbar mode indicator */
      call wake_disp;				/* go wake up dispatcher */

/* ********* MME GEMORE ********* (get more memory)

   input/return registers: none

   mme     gemore
   zero    0,no. 1024 word blocks
   ------  return denial
   ------  return succesful */

mme_typ (9): if trace then call tolts_qttyio_$rs (10, "^a MME GEMORE @ ^p", ctime (), mmep);
      call return_plus (3);				/* return ic + 3 */

/* ********* MME GEMREL ********* (release memory)

   input registers:	AR = return address in upper, lower not used
   *		QR = words lower mem to release in upper, words upper mem to release in lower

   mme     gemrel
   ------  return

   return registers: none */

mme_typ (21): if trace then call tolts_qttyio_$rs (10, "^a MME GEMREL @ ^p", ctime (), mmep);
      spa.enter.icivlu.ic = substr (spa.regs.a, 1, 18);	/* return to address in a upper */
      call wake_disp;				/* go wake up dispatcher */
%page;
/* ********* MME GEPROC ********* (dedicate CPU, unused in Multics. Return error)

   input/return registers: none

   mme     geproc
   zero    gprprc,0
   zero    work,0
   ------  return error
   ------  return good */

mme_typ (-13): if trace then call tolts_qttyio_$rs (10, "^a MME GEPROC @ ^p", ctime (), mmep);
      call return_plus (3);				/* return ic + 3, error return for Multics */

/* ********* MME GERELC ********* (wait for I/O interrupt to occur)

   input/return registers: none

   mme     gerelc
   ------  return */

mme_typ (15): if trace then call tolts_qttyio_$rs (10, "^a MME GERELC @ ^p", ctime (), mmep);
      call return_plus (1);

/* ********* MME GEROAD ********* (road block, wait)

   input/return registers: none

   mme     geroad
   ------  return */
mme_typ (2): if trace then call tolts_qttyio_$rs (10, "^a MME GEROAD @ ^p", ctime (), mmep);
      rd_blk = "1"b;
      call return_plus (1);


/* ********* MME GEROUT ********* (colts communications)

   l   mme    gerout
   l+1	 vfd     18/record pointer,06/op,12/terminal id
   l+2	         status word pointer,courtesy call pointer
   l+3	         return


   There are six gerout types handled by tolts.
   04  write/read
   05  remote inquiry
   06  terminal type request
   07  fnp colts wake-up
   17  disconnect
   20  line status request	   */


mme_typ (24): if trace then call tolts_qttyio_$rs (10, "^a MME GEROUT ^p, type - ^12.3b", ctime (), mmep, mme_call_w (1));

      gerout_num = bin (substr (mme_call_hw (1).lower, 1, 6)); /* get the gerout number index 	*/
      if gicm_count > 0 then call return_plus (0);
      else go to gerout (gerout_num);			/* goto the gerout handler for this gerout	*/
%page;


gerout (4): wicmp = addrel (execp, mme_call_hf (1).upper);	/* get write icm pointer */
      ricmp = addrel (execp, bin (wicm.rbuf_addr) - 1);	/* get read icm pointer */
      if gicmp = null then alloc gicm;			/* alloc an icm area */
      gicmp = addr (gicm);				/* get a ptr to it */
      icm_tally = bin (wicm.word_total) * 2;		/* get icm tally */
      k = bin (substr (mme_call_hw (1).lower, 15, 4));	/* get index */
      if substr (mme_call_hw (1).lower, 13, 1) = "1"b then do; /* an exec request */
         if substr (wicm.host_opcode, 10, 9) = "042"b3 then do; /* if load memory request */
	  alloc ticm;				/* allocate a temp icm */
	  ticmp = addr (ticm);			/* get a ptr */
	  ticm = wicm;				/* move the icm */
	  fnp_num = bin (substr (mme_call_hw (1).lower, 16, 3)) + 1; /* get the fnp number */
	  do i = 1 to 2;
	     if substr (ticm.icm_buf (1), 1, 18) = "777777"b3 then do; /* if first get mem icm */
	        call db_fnp_eval_ (null (), fnp_num, ".criom", null (), exec, fnp_addr, code);
						/* get address of fnp iom table */
	        if code ^= 0 then go to db_err;		/* if error go to error routine */
	        icm_tally = 1;			/* else set icm tally to correct value */
	     end;
	     else do;
	        i = 2;				/* second get mem icm */
	        icm_tally = bin (wicm.word_total) * 2;	/* compute the icm tally */
	        fnp_addr = bin (substr (ticm.icm_buf (1), 1, 18)); /* fill in fnp address */
	     end;
	     call db_fnp_memory_$fetch (null (), fnp_num, fnp_addr, icm_tally, addr (ticm.icm_buf), code);
						/* get the iom table */
db_err:	     if code ^= 0 then do;			/* if error */
	        call convert_status_code_ (code, shortinfo, lginfo);
	        call tolts_qttyio_$rs (0, "^as: ^a error reading fnp memory", tolts_info.exec, lginfo);
						/* can't read fnp memory */
	        ticm.fnp_opcode = "000051"b3;		/* set bad status */
	     end;
	     else ticm.fnp_opcode = "000041"b3;		/* supply op complete code */
	  end;
	  ticm.rbuf_addr = "0"b;			/* zero read buffer pointer */
	  call tolts_alm_util_$gen_ck_sum (ticmp);	/* generate an icm check sum */
	  ricm = ticm;				/* move icm */
	  free ticm;
	  ticmp = null;
	  if mme_call_hf (2).lower ^= 0 then do;	/* a cc is requested */
	     exec_wd (mme_call_hf (2).upper) = "000000000004"b3;
	     call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
	      mme_call_hw (2).lower || "000000"b3);	/* enter a ccc request */
	  end;
         end;
         else if substr (wicm.host_opcode, 10, 9) = "001"b3 then do; /* if a start test request */
	  do i = 1 to 8 while (colts_pages (i).in_use);	/* find vacant test page slot */
	  end;
	  if i = 8 & colts_pages (8).in_use then do;	/* if 8 pages running - error */
	     call tolts_qttyio_$rs (0, "^a: mme gerout 04; no vacant test page slot found", exec);
	     call tolts_abort ("$c1");
	  end;

	  colts_pages (i).in_use = "1"b;		/* else set page in use */

	  do j = 1 to 8;
	     if substr (fnp (k).cdt_name (j), 1, 5) ^= "empty" then do;
	        colts_pages (i).cdt_name = tolts_info.fnp (k).cdt_name (j);
						/* save the cdt name in the test page */
	        tolts_info.fnp (k).cdt_name (j) = "empty";
	        j = 8;
	     end;
	  end;
	  tolts_info.exec_page_count = tolts_info.exec_page_count + 1; /* inc test page count */
	  dmap = addr (tolts_info.colts_pages (i).dm_arg);/* get dial_manager_arg ptr */
	  colts_pages (i).dm_arg.version = dial_manager_arg_version_2; /* fill in the required fields */
	  colts_pages (i).dm_arg.dial_qualifier = substr (colts_pages (i).cdt_name, 1, 22);
	  colts_pages (i).dm_arg.dial_channel = tolts_info.dm_event;
	  colts_pages (i).dm_arg.channel_name = colts_pages (i).cdt_name;
	  colts_pages (i).type_code = substr (wicm.icm_buf (1), 22, 6);
	  nr_cnt = 0;				/* reset the no responce count */
	  call dial_manager_$tandd_attach (dmap, code);	/* get the channel for testing */
	  if code ^= 0 then do;			/* if error */
	     if debugging then call com_err_ (code, "mtdsim_", "Error on tandd_attachment of ^a.",
	         colts_pages (i).cdt_name);
	     colts_pages (i).in_use = "0"b;		/* reset test page active */
	     call convert_status_code_ (code, shortinfo, lginfo);
	     call tolts_qttyio_$rs (0, "^as: ^a/ error attempting a tandd_attach of ^a",
	      tolts_info.exec, lginfo, substr (colts_pages (i).cdt_name, 1, 6));
	     colts_op_flags.colt_flag = "0"b;		/* make use flag is reset so we don't go blocked */
	     alloc ticm;				/* allocate a temp icm */
	     ticmp = addr (ticm);			/* get a ptr */
	     ticm = wicm;				/* move the icm */
	     ticm.fnp_opcode = "000051"b3;		/* set error status code */
	     ticm.rbuf_addr = "0"b;			/* zero read buffer pointer */
	     call tolts_alm_util_$gen_ck_sum (ticmp);	/* generate an icm check sum */
	     ricm = ticm;				/* move icm */
	     free ticm;
	     ticmp = null;
	     if mme_call_hf (2).lower ^= 0 then do;	/* a cc is requested */
	        exec_wd (mme_call_hf (2).upper) = "000000000004"b3;

	        call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
	         mme_call_hw (2).lower || "000000"b3);	/* enter a ccc request */
	     end;
	     call return_plus (3);
	  end;
	  tolts_info.wait_list.nchan = tolts_info.wait_list.nchan + 1; /* inc the event wait list */
	  tolts_info.wait_event_id (tolts_info.wait_list.nchan) = tolts_info.dm_event; /* store the event id */
	  clt_sw = substr (colts_pages (i).cdt_name, 1, 6) || ".sw"; /* create a switch name */
	  att_desc = "tty_ " || substr (colts_pages (i).cdt_name, 1, 6); /* and an attach description */
	  colts_op_flags.dm_attach = "1"b;		/* set colts control flags */
	  colts_op_flags.colt_flag = "1"b;
	  colts_op_flags.sicm = "1"b;
	  l = i;					/* save i for later use */
         end;
         else do;					/* else a normal exec icm */
	  call iox_$put_chars (fnp (k).fnp_execp, wicmp, (bin (wicm.word_total) + 1) * 4, code); /* transmit the icm */
	  if code ^= 0 then do;			/* if error */
	     call convert_status_code_ (code, shortinfo, lginfo);
	     call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer to fnp", tolts_info.exec, lginfo);
	     call tolts_abort ("$c1");		/* then abort colts */
	  end;
	  gicm_count = gicm_count + 1;		/* inc outstanding icms count */

	  if gicm_count = 17 then do;			/* if = 17 - error */
	     call tolts_qttyio_$rs (0, "^as: excessive outstanding io's", tolts_info.exec);
	     call tolts_abort ("$c1");		/* abort colts */
	  end;

	  gicm.cltp = fnp (k).fnp_execp;		/* save iocb ptr */
	  gicm.ricmp = ricmp;			/* rd icm ptr */
	  gicm.tally = bin (wicm.word_total) + 1;	/* icm tally */
	  if mme_call_hf (2).lower ^= 0 then do;	/* if cc requested */
	     gicm.cc_addr = mme_call_hw (2).lower || "000000"b3; /* save ccc address */
	     gicm.st_addr = mme_call_hf (2).upper;	/* save status address */
	  end;
         end;
      end;
      else do;					/* else icm for test chan */

         call iox_$put_chars (colts_pages (k).chanp, wicmp, (bin (wicm.word_total) + 1) * 4, code); /* send the icm */
         if code ^= 0 then do;			/* if error */
	  call convert_status_code_ (code, shortinfo, lginfo);
	  call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer to chan ^a",
	   tolts_info.exec, lginfo, substr (colts_pages (k).cdt_name, 1, 6));
	  colts_pages (k).status_word = "000000000002"b3; /* store bad status */
         end;

         gicm_count = gicm_count + 1;			/* inc outstanding icm count */

         if gicm_count = 17 then do;			/* if 17 - error */
	  call tolts_qttyio_$rs (0, "as: excessive outstanding io count", tolts_info.exec);
	  call tolts_abort ("$c1");			/* abort tolts */
         end;
         gicm.cltp = colts_pages (k).chanp;		/* save iocb ptr */
         gicm.ricmp = ricmp;				/* read icm ptr */
         gicm.tally = bin (wicm.word_total) + 1;		/* tally */
         if mme_call_hf (2).lower ^= 0 then do;		/* if cc requested */
	  gicm.cc_addr = mme_call_hw (2).lower || "000000"b3; /* save ccc address */
	  gicm.st_addr = mme_call_hf (2).upper;		/* status address */
         end;
      end;
      call return_plus (3);



gerout (5): remote_inquiry_ic = bin (rel (addr (mme_call_w (1)))); /* remember remote inquiry location */
      call return_plus (3);				/* return to colts */

gerout (06):
      k = bin (substr (mme_call_hw (1).lower, 15, 4));
      if substr (mme_call_hw (1).lower, 13, 1) = "1"b then
         mme_call_hw (1).upper = tolts_info.fnp (k).exec_type_code || "0000"b3; /* set type code	*/

      else substr (mme_call_hw (1).upper, 1, 6) = colts_pages (k).type_code;
      call return_plus (3);


gerout (7): if remote_inquiry_ic ^= 0 then do;		/* if no outstanding remote inquiry - error */

         k = bin (substr (mme_call_hw (1).upper, 1, 3));	/* k = fnp number */

         if ^tolts_info.fnp (k).exec_active then do;	/* if the fnp exec is not active */
	  dmap = addr (tolts_info.fnp (k).dm_arg);	/* get addr of dial_manager arg */
	  fnp (k).dm_arg.version = dial_manager_arg_version_2;
	  fnp (k).dm_arg.dial_qualifier = substr (fnp (k).exec_chan, 1, 22);
	  tolts_info.fnp (k).dm_arg.dial_channel = tolts_info.dm_event; /* set dial_channel to event channel */
	  tolts_info.fnp (k).dm_arg.channel_name = fnp (k).exec_chan; /* get channel name	*/

	  nr_cnt = 0;				/* reset the no responce count */
	  call dial_manager_$privileged_attach (dmap, code);
	  if code ^= 0 then do;
	     call convert_status_code_ (code, shortinfo, lginfo);
	     call tolts_qttyio_$rs (0, "^as: ^a/ error attempting a priviledged_attatch of ^a",
	      tolts_info.exec, lginfo, fnp (k).channel_name);
	     call tolts_abort ("$c1");		/* then abort colts */
	  end;

	  tolts_info.wait_list.nchan = wait_list.nchan + 1;
	  tolts_info.wait_event_id (tolts_info.wait_list.nchan) = tolts_info.dm_event;
	  clt_sw = substr (fnp (k).exec_chan, 1, 6) || ".sw";

	  att_desc = "tty_ " || substr (fnp (k).exec_chan, 1, 6);
	  colts_op_flags.colt_flag = "1"b;
	  colts_op_flags.dm_attach = "1"b; ;
	  fnp (k).exec_type_code = substr (mme_call_hw (1).lower, 13, 6); /* save exec type code	*/
         end;
         call return_plus (2);
      end;
      else do;
         call tolts_qttyio_$rs (0, "^as:  MME GEROUT 07 - no outstanding GEROUT 05", exec);
         call tolts_abort ("$c9");
      end;


gerout (15): if mme_call_hw (1).lower = "170000"b3 then call return_plus (3);
      k = bin (substr (mme_call_hw (1).lower, 15, 4));
      if substr (mme_call_hw (1).lower, 13, 3) = "4"b3 then call rel_exec_chan (k);

      else call rel_tst_chan (k);

      if mme_call_hf (2).lower ^= 0 then do;
         exec_wd (mme_call_hf (2).upper) = "000000000002"b3;
         call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), mme_call_hw (2).lower || "000000"b3);
      end;

      call return_plus (3);



gerout (16): k = bin (substr (mme_call_hw (1).lower, 15, 4));
      if substr (mme_call_hw (1).lower, 13, 1) = "1"b then
         exec_wd (mme_call_hf (2).upper) = "000000000004"b3;
      else exec_wd (mme_call_hf (2).upper) = colts_pages (k).status_word;
      call return_plus (3);


%page;

/* ********* MME GESNAP ********* (snap shot dump)

   input/return registers: none

   mme     gesnap
   iotd    add,wc
   ------  return */

mme_typ (5): if trace then call tolts_qttyio_$rs (10, "^a MME GESNAP @ ^p", ctime (), mmep);
      if tolts_info.file_attach then			/* if print file attached */
         call tolts_file_util_$snap (addrel (mmep, 1));	/* go output snap dump */
      call return_plus (2);				/* return ic + 2 */
						/* ********* MME GETIME ********* (return date/time)

						   input registers: none

						   mme     getime
						   ------  return

						   return registers:   AR - date,  QR - time (right justified--1/64 ms. past midnight */

mme_typ (17): if trace then call tolts_qttyio_$rs (10, "^a MME GETIME @ ^p", ctime (), mmep);
      call tolts_init_$gc_tod (spa.regs.q);		/* get time of day */
      spa.regs.a = tolts_info.gc_date;			/* and bcd date */
      call return_plus (1);

/* ********* MME HUNGTM ********* (check for outstanding I/O)

   input registers:   AU = test page index (mod 4)

   mme     hungtm
   ------  return not in transmission
   ------  return in transmission

   return registers: QR = lostit time, X1 = 5 if timeout; = 3 if still time to go */

mme_typ (-16): if trace then call tolts_qttyio_$rs (10, "^a MME HUNGTM @ ^p", ctime (), mmep);
      call get_px_sct ("HUNGTM", bin (substr (spa.regs.a, 1, 18), 17), "1"b); /* get test page index */
      if substr (spa.regs.a, 1, 18) = "0"b then do;
         call tolts_qttyio_$rs (0, "^a MME HUNGTM  illegal test page index @ ^p", ctime (), mmep);
         call tolts_abort ("$b6");
      end;
      call tolts_init_$gc_tod (gcos_tod);		/* get current time of day */
      if bin (gcos_tod, 36) >= io_info.con_time + io_info.lostit_time then do; /* if time exceeded */
         spa.regs.x (1) = "000005"b3;			/* set courtesy call wating */
         exec_wd (io_info.status_add) = "510006000000"b3;	/* set time out status */
         call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
	string (io_info.icivlu));			/* enter ccc request */
         spa.regs.q = "0"b;				/* set 0 lostit time */
      end;
      else do;					/* not time out yet */
         spa.regs.x (1) = "000003"b3;			/* set in xmission */
         spa.regs.q = bit ((io_info.con_time + io_info.lostit_time) - bin (gcos_tod, 35, 0), 35);
      end;
      call return_plus (2);				/* return ic + 2 */
%page;
/* ********* MME IOCONS ********* (return number of I/O connects)

   input registers:   x1 = sct (test page index mod 4)

   mme     iocons
   ------  return

   return registers:   AR = number of connects for this test page */

mme_typ (-17): if trace then call tolts_qttyio_$rs (10, "^a MME IOCONS @ ^p", ctime (), mmep);
      call get_px_sct ("IOCONS", bin (spa.regs.x (1), 17), "1"b); /* get test page index */
      spa.regs.a = bit (bin (pages (io_sel).num_connects, 36));
      call return_plus (1);

/* ********* MME IPCW. ********* ( send initialize PCW to mpc )

   input registers:   x1 = ICC


   mme     ipcw.
   ------  return

   return registers: none */

mme_typ (-55): if trace then call tolts_qttyio_$rs (10, "^a MME IPCW. @ ^p", ctime (), mmep);
      if substr (spa.regs.x (1), 7, 1) then		/* if new format */
         call get_px_tcx ("IPCW. ", substr (spa.regs.x (1), 8, 11)); /* get test page index */
      else call get_px_tcx ("IPCW. ", substr (spa.regs.x (1), 10, 9)); /* get test page index */
      pcwa = "0"b;					/* initialize pcw first */
      pcwp = addr (pcwa);
      pcw.code = "111"b;				/* Set PCW code */
      pcw.mask = "1"b;				/* Make it a reset PCW */
      pcw.control = "11"b;
      ioi_wksp = io_info.workspace_ptr;			/* get ptr to our workspace */
      tio_off = fixed (rel (addr (tolts_workspace.p_idcw)));/* set default dcw list offset for ioi */
      idcwp = addr (tolts_workspace.p_idcw);		/* set up idcw ptr */
      string (idcw) = "0"b;				/* intiialize idcw */
      idcw.code = "7"b3;				/* set in idcw type code */
      io_info.to_no_cc = "1"b;			/* set flag for int processor */
      call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error);
      if error ^= 0 then do;
         call output_status_code (error, "io connect error");
         call tolts_abort ("$m5");
      end;
      call return_plus (1);
%page;
/* ********* MME LODIMG ********* (load print train image (GCOS only))

   input registers:   x1 = sct (test page index mod 4)

   mme     lodimg
   ------  return good
   ------  return bad

   return registers: none */

mme_typ (-18): if trace then call tolts_qttyio_$rs (10, "^a MME LODIMG @ ^p", ctime (), mmep);
      call return_plus (1);				/* return ic + 1 */

/* ********* MME LODVFC ********* (load printer vertical format control (VFC) (GCOS only))

   input registers:   x1 = sct (test page index mod 4)

   mme     lodvfc
   ------  return good
   ------  return error

   return registers:   a-reg = error code on error */

mme_typ (-19): if trace then call tolts_qttyio_$rs (10, "^a MME LODVFC @ ^p", ctime (), mmep);
      call return_plus (1);				/* return ic + 1 */

/* ********* MME LPW. ********* ( return LPW tally residue )

   input registers:   x1 = ICC

   mme     lpw.
   ------  return

   return registers:   A-REG = LPW, .crmb1,1 */

mme_typ (-52): if trace then call tolts_qttyio_$rs (10, "^a MME LPW. @ ^p", ctime (), mmep);
      if substr (spa.regs.x (1), 7, 1) then		/* if new format */
         call get_px_tcx ("LPW.  ", substr (spa.regs.x (1), 8, 11)); /* get test page index */
      else call get_px_tcx ("LPW.  ", substr (spa.regs.x (1), 10, 9)); /* get test page index */
      ioi_wksp = pages (io_sel).workspace_ptr;		/* get ptr to proper workspace */
      spa.regs.a = tolts_workspace.lpw (1);		/* copy lpw tally residue */
      call return_plus (1);


/* ********* MME MASTER MODE ENTRY ********* */

mme_typ (30):					/* not valid on Multics */
      call return_plus (1);



%page;

/* ********* MME MBXCMP ********* (Responder compare mailbox data)

   inputr registers:

   X1 = pointer to was data
   X2 = pointer to s/b data
   X5 = fpinfo pointer
   mme     mbxcmp
   error return
   good return

   return registers:
   A = bad data if not compare  */

mme_typ (-90): if trace then call tolts_qttyio_$rs (10, "^a MME MBXCMP @ ^p", ctime (), mmep);

      tolts_fpinfo_ptr = addrel (execp, spa.regs.x (5));	/* get a ptr to the test page fpinfo table */
      do io_sel = 1 to hbound (pages, 1)		/* get the io_info for this page */
       while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num);
      end;
      if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* io_info for this page not found */
      io_info_ptr = addr (pages (io_sel));
      tolts_rspd_wksp = io_info.tolts_rspd_wksp;
      lvl_idx = (bin (substr (spa.regs.x (1), 13, 3)));	/* get the level */
      ws_data_idx = (bin (substr (spa.regs.x (1), 16, 3))); /* was data index */
      sb_data_idx = (bin (substr (spa.regs.x (2), 16, 3))); /* s/b data index */
      if tolts_rspd_workspace.ima_level (lvl_idx).word (sb_data_idx) /* compare the data */
       ^= tolts_rspd_workspace.ima_level (lvl_idx).word (ws_data_idx) then do;
         spa.regs.a = tolts_rspd_workspace.ima_level (lvl_idx).word (ws_data_idx);
         call return_plus (1);			/* take error return */
      end;
      else call return_plus (2);			/* take good return */


/* ********* MME MBXDAT ********* (mme to manipulate mailbox data)

   input registers:
   x1 = pointer to FPINFO table
   x2 = subcommand code
   1 = MBLC (get mbx location)       2 = INITMB (intialize mailbox data)
   3 = RDMBX (read mailbox)	       6 = RDINT (read interrupt word)
   7 = RDINT0 (rd intrpt wrd & 0)   11 = STMBX (store mailbox word)

   mme	MBXDAT
   zero	error return       (mme call + 1)
   zero	timeout return       (mme call + 2)
   zero	retry return       (mme call + 3)
   zero	good return        (mme call + 4)

   return registers:
   A & Q = data requested.

   Data is also entered into FPINFO table.

   dcl 1 tolts_fpinfo aligned based (tolts_fpinfo_ptr),
   *      2 pcw_info,
   *         3 fnp_num fixed bin unaligned,
   *         3 chan fixed bin (6) unaligned,
   *         3 cmnd fixed bin (6) unaligned,
   *     2 fnpdcw,
   *         3 address fixed bin unaligned,
   *         3 word_count fixed bin unaligned,
   *     2 io_rq_cnt fixed bin (35),
   *     2 mbxloc fixed bin (35),
   *     2 spec_cnt fixed bin,
   *     2 term_cnt fixed bin,
   *     2 partrs fixed bin (35),
   *     2 timeout_time fixed bin (35),
   *     2 temp01,
   *       3 word1,
   *         4 upper bit (18),
   *         4 lower bit (18),
   *       3 word2,
   *         4 upper bit (18),
   *         4 lower bit (18),
   *     2 temp02,
   *       3 word1,
   *         4 upper bit (18),
   *         4 lower bit (18),
   *       3 word2,
   *         4 upper bit (18),
   *         4 lower bit (18),
   *     2 temp03,
   *       3 word1,
   *         4 upper bit (18),
   *         4 lower bit (18),
   *       3 word2,
   *         4 upper bit (18),
   *         4 lower bit (18),
   *     2 lvl3_flag bit (36),
   *     2 lvl7_flag bit (36),
   *     2 lvl3_cnt fixed bin (35),
   *     2 lvl7_cnt fixed bin (35),
   *     2 pprt_avail bit (35); */



mme_typ (-65): if trace then call tolts_qttyio_$rs (10, "^a MME MBXDAT ^p, type - ^6.3b", ctime (), mmep, spa.regs.x (2));

      tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1));	/* get a ptr to the test page fpinfo table */
      do io_sel = 1 to hbound (pages, 1)		/* get the io_info for this page */
       while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num);
      end;
      if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* io_info for this page not found */
      io_info_ptr = addr (pages (io_sel));
      io_info.fpinfo_ptr = tolts_fpinfo_ptr;
      goto sub_cmnd (bin (spa.regs.x (2)));


sub_cmnd (1):


      call tolts_device_info_ (addr (io_info.test_req), io_sel, t_err);
      if t_err ^= 0 then call tolts_abort ("$c4");

/* create an event call channel for tdio status events */

      if ^io_info.ev_ch_ass then do;			/* we we havn't done this already */
         call tolts_init_$cr_event_chan (io_info.status_event,
	"1"b, tolts_io_int_, io_info_ptr, 2, error);
         if error ^= 0 then				/* if error creating event call chan */
	  call tolts_abort ("$a9");
         io_info.ev_ch_ass = "1"b;			/* set event chan assigned flag */
      end;
      call ioa_$rsnnl ("T&D is attaching for a ^[write^]^[read^] ^a",
       att_desc, mesg_len, (^rd_flag), (rd_flag), io_info.device_name);
      call rcp_$attach (io_info.rcp_name, addr (io_info.rcp_area (1)), io_info.status_event,
       att_desc, io_info.rcp_id, error);

      if error ^= 0 then do;
         call output_status_code (error, "rcp attach error");
         call dealcp_sub;				/* go release status event */
         call tolts_abort ("$c5");
      end;

      call rcp_$check_attach (io_info.rcp_id, addr (io_info.rcp_area (1)), coment, io_info.device_index,
       tolts_info.max_wks_sz, tolts_info.max_to, io_info.rcp_state, io_info.attach_err);
      if io_info.attach_err ^= 0
       | io_info.rcp_state ^= 0 then do;
         if io_info.attach_err ^= 0 then
	  call output_status_code (io_info.attach_err, "workspace assign error");
         call dealcp_sub;
         call tolts_abort ("$c6");
      end;
      io_info.p_att = "1"b;
      io_info.tolts_rspd_wksp = addr (tolts_rspd_workspace);
      call ioi_$workspace (io_info.device_index, io_info.tolts_rspd_wksp, tolts_info.wks_sz, error);
      if error ^= 0 then do;
         call output_status_code (error, "workspace assign error");
         call dealcp_sub;				/* go release status event */
         call tolts_abort ("$c6");
      end;
      io_info.cur_wks_sz = tolts_info.wks_sz;		/* set current value of workspace size */
      call ioi_$set_status (io_info.device_index, fixed (rel (addr (tolts_rspd_workspace.mailbox.status_word)), 18), 1, error);

      tolts_fpinfo.mbxloc = 0;
      spa.regs.q = "0"b;
      tolts_fpinfo.partrs = -1;

      call return_plus (4);


sub_cmnd (2):

      tolts_rspd_wksp = io_info.tolts_rspd_wksp;
      unspec (tolts_rspd_workspace.num_int) = "0"b;

      call return_plus (4);


sub_cmnd (3):

      tolts_rspd_wksp = io_info.tolts_rspd_wksp;
      spa.regs.a = unspec (tolts_rspd_workspace.mailbox.pcw);

      call return_plus (4);

sub_cmnd (6):

      tolts_rspd_wksp = io_info.tolts_rspd_wksp;
      unspec (tolts_fpinfo.temp03.word1) = unspec (tolts_rspd_workspace.mailbox.num_int);

      call return_plus (4);

sub_cmnd (7):

      tolts_rspd_wksp = io_info.tolts_rspd_wksp;
      unspec (tolts_fpinfo.temp03.word2) = unspec (tolts_rspd_workspace.mailbox.num_int);
      unspec (tolts_rspd_workspace.mailbox.num_int) = "0"b;

      call return_plus (4);

sub_cmnd (11):

      tolts_rspd_wksp = io_info.tolts_rspd_wksp;
      k = bin (substr (tolts_fpinfo.temp03.word1.upper, 13, 3));
      unspec (tolts_rspd_workspace.ima_level (k)) = "0"b;
      do i = 1 to bin (tolts_fpinfo.temp02.word1.upper);
         ima_level (k).word (i) = spa.regs.a;
      end;

      call return_plus (4);

%page;


/* ********* MME PACMAN ********* (allocate IPC's for mcad test )

   input registers:			    Channel List format:
   x1 = sct (test page index mod 4)	    vfd 9/base chnl,9/# of chnls,16/flags
   x2 = address of channel list	    .
   x5 = address of mca config		    .
   A  =  0 then attach channels	    oct -1 end of list flag
   A ^= 0 then return channels
   Q  = ICC
   mme	pacman
   zero	error return	x2 = reason code		  (mme call + 1)
   zero	error return	no chnls requested configured	  (mme call + 2)
   zero	retry return	I/O in progress, retry	  (mme call + 3)
   zero	good return	requested chnls assigned	  (mme call + 4)

   return registers:
   X2 = error code on error (see set_sctwrk subroutine for error codes)
   *			output in sctwrk (12 words): see the set_sctwrk subroutine */

dcl  1 chan_list aligned based (clp),
         (2 base_chan fixed bin (9) uns,
       2 num_chans fixed bin (9) uns,
       2 flags,
         3 reboot bit (1),
         3 pad bit (17)) unaligned;
dcl  clp ptr;
dcl  p99 pic "99" based;


mme_typ (-87): if trace then call tolts_qttyio_$rs (10, "^a MME PACMAN @ ^p", ctime (), mmep);

      if substr (spa.regs.q, 7, 1) then			/* if new format */
         call get_px_tcx ("PACMAN", substr (spa.regs.q, 8, 11)); /* get test page index */
      else call get_px_tcx ("PACMAN", substr (spa.regs.q, 10, 9)); /* get test page index */
      clp = addrel (execp, fixed (spa.regs.x (2)));
      if spa.regs.a = "0"b then do;
         if io_info.ipc_attached then do;
	  call mca_$detach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx, "0"b, code);
	  call tolts_qttyio_$rs (0, "^a ipc was still attached will detach leaving the device suspended", io_info.ipc_id);
         end;
         io_info.ipc_id = substr (io_info.device_name, 4, 1) || convert (p99, (chan_list.base_chan));
         call mca_$attach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx, io_info.ipc_number, code);
         if code ^= 0 then do;
	  if code = error_table_$resource_unavailable then do; /* must have been busy */
	     spa.regs.x (2) = bit (dev_busy);		/* set appropriate error code */
	     call tolts_qttyio_$rs (0, "^a ipc ^a busy", io_info.test_hdr, io_info.ipc_id);
	     call return_plus (1);			/* return ic + 7 */
	  end;
	  else do;
	     call output_status_code (code, "ipc attach error");
	     spa.regs.x (2) = bit (os_deny);		/* set appropriate error code */
	     call return_plus (1);			/* take error return */
	  end;
         end;
         io_info.ipc_attached = "1"b;
      end;
      else if io_info.ipc_attached then do;
         call mca_$detach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx,
	chan_list.flags.reboot, code);
         if code ^= 0 then call tolts_abort ("$p2");
         else io_info.ipc_attached = "0"b;
      end;
      call return_plus (4);


%page;
/* *************************************************************************************************************
   *   MTAR has to know what operating system it is running on. This code passes the Multics code to cmlt
   *   which passes it to mtar at initialize time.   *
   ************************************************************************************************************** */

/*    ********* MME POINIT ********* (slave executive initialize)

   input/output registers: none

   mme	poinit
   zero	wwflag,o.s. code	from .crfig (upper) Multics o.s. code (lower)
   zero	lstloc,0	core size available as loaded
   zero	tewrk,0	from .crctb
   zero	.tdioc,0	from .crioc
   zero	wradd,0	wrapup address
   zero	cvttbl,0	conversion table ptr
   zero	mmexec,0	position of ttl date in message
   zero	mintr,0	min/max memory test ranges (2 words)
   zero	crafc0,0	.cracf bit 3 & mpc entry if single disk & disk acf for pri and alt files (3 words )
   ----	return	return is mme call + 10

   .crfig:

   0 = series 60 0r 6000	6 = system sckd. save opt.		24-30 = reserved for gcos
   1 = class. module present	7 = reserved for gcos		31 = not in mem avail. space tab
   2 = shared memory system	8,9,10,11 = ioms 0-3 configured	32 = RLP300 present
   3 = >256k		12,13,14,15 = CPUs 0-3 configured	33 = DN30
   4 = IOM system		16-19 = reserved for gcos		34 = DN305
   5 = series 60 system	20,21,22,23 = CPU has EIS		35 = DN	355/6600

   .crctb ->    chars specify the first six tabs beyond position 0
   .crioc ->    -1 = IOMs */

mme_typ (-20): if trace then call tolts_qttyio_$rs (10, "^a MME POINIT @ ^p", ctime (), mmep);
      exec_wd (mme_call_hf (1).upper) = "0"b;		/*	zeros says not ww system */
      if mme_call_hf (1).lower ^= 0 then
         exec_wd (mme_call_hf (1).lower) = "000000000002"b3;/* store Multics code if pointer */
      exec_wd (mme_call_hf (3).upper) = "122436506274"b3;	/*	tabs at 10,20,30,40,50,60  */
      iom_cardp = null;
      term = "0"b;					/* reset terminate condition */
      do while (^term);				/* find all iom cards */
         call tolts_util_$find_card ("iom ", iom_cardp);	/* find iom card */
         if iom_cardp = null then term = "1"b;		/* completed search of the deck */
         else do;
	  if iom_card.model = "imu " then imu_found = "1"b;
	  else if iom_card.model = "iom" then iom_found = "1"b;
         end;
      end;

      if imu_found then				/* imu system  */
         exec_wd (mme_call_hf (4).upper) = "777777000000"b3;
      else if iom_found then				/* iom system */
         exec_wd (mme_call_hf (4).upper) = "777777777777"b3;
      else exec_wd (mme_call_hf (4).upper) = "0"b3;	/* let the usbexec complain */

      spa.wrapup_add = mme_call_hw (5).upper;		/* set wrapup address */
      call tolts_alm_util_$ascii_to_bcd_ (ttl_date, bcd_callname); /* convert ttl date to bcd */
      exec_wd (mme_call_hf (7).upper) = bcd_callname;	/* and store in message */
      substr (exec_wd (mme_call_hf (7).upper - 1), 19, 18) = "622017"b3; /* change version? ?? to version?s ? */
      genp = addrel (execp, mme_call_hf (2).upper);	/* get ptr to lstloc */
      if exec = "molt" then do;
         if fix_wd (1) ^= 0 then			/* if lstloc specified... */
	  mem_now, fix_wd (1) = fix_wd (1) + 196608;	/* add 196k to lstloc */
         else mem_now, fix_wd (1) = fixed (gload_data.text_len) + 196608; /* otherwise use loaded length */
      end;
      else do;
         if fix_wd (1) ^= 0 then			/* if lstloc specified... */
	  mem_now, fix_wd (1) = fix_wd (1) + 32768;	/* add 32k to lstloc */
         else mem_now, fix_wd (1) = fixed (gload_data.text_len) + 32768; /* otherwise use loaded length */
      end;
      call cpu_time_and_paging_ (i, cpu_time, j);		/* get current cpu time */
      tolts_info.init_time = cpu_time;			/* save  */
      call return_plus (10);				/* return ic + 10 */
%page;
/* ********* MME PROCTM ********* (return CPU time used since exec init)

   input registers: none

   mme     proctm
   ------  return

   return registers:   a-reg = processor time in 1/64 ms */

mme_typ (-21): if trace then call tolts_qttyio_$rs (10, "^a MME PROCTM @ ^p", ctime (), mmep);
      call cpu_time_and_paging_ (i, cpu_time, j);		/* get current cpu time */
      cpu_time = cpu_time - tolts_info.init_time;		/* compute delta */
      spa.regs.a = bit (bin (divide (cpu_time * 64, 1000, 71, 0), 36)); /* return time */
      call return_plus (1);

/* ********* MME PRTRAN ********* (load print train image for test)

   input registers:   x1 = sct (test page index mod 4)

   mme     prtran
   zero    loc,0 pointer to buffer for train image
   ------  return error
   ------  return good

   return registers: AR contains error code if error */

mme_typ (-22): if trace then call tolts_qttyio_$rs (10, "^a MME PRTRAN @ ^p", ctime (), mmep);
      call get_px_sct ("PRTRAN", bin (spa.regs.x (1), 17), "1"b); /* get test page index */
      do i = 1 to printer_images_$n_images while (io_info.devsct.ptrain ^= printer_images_$image_numbers (i));
      end;
      if i > printer_images_$n_images then do;
         call tolts_qttyio_$rs (0, "^as: MME PRTRAN; No such train number - ^d",
	exec, io_info.devsct.ptrain);
         call tolts_abort ("$b1");
      end;
      tp = addrel (addr (printer_images_$image_base), printer_images_$image_offsets (i));
      train_ptr = addrel (execp, mme_call_hf (1).upper);
      train_ptr -> prt_image = tp -> prt_image;
      call return_plus (3);				/* return ic + 3 */
%page;
/* ********* MME READIO ********* (read options)

   input registers:	   x1 = 3/exec #,9/0,6/cid
   *		   x4 -> (see opt_temp structure declaration below)

   mme     readio
   ------  return if tolts aborted
   ------  return if tolts swapped
   ------  return good

   return registers: none */

dcl  1 opt_temp based (genp) aligned,			/* template for MME READIO */
       (2 bcd_o_dash bit (18),			/* = bcd " o-" */
       2 tdpcn_add fixed bin,				/* address of .tdpcn */
       2 bufnum fixed bin,				/* tadio buffer (array element) number */
       2 nu1 bit (6),
       2 exec_num bit (6),
       2 nu2 bit (6),
       2 opt_ptr fixed bin,				/* ptr to options storage area */
       2 nu3 bit (6),
       2 phy_term bit (12)) unaligned;			/* physical terminal id */

dcl  bcd_options bit (6 * 84) based (genp);		/* to move options to test page */

mme_typ (-24): if trace then call tolts_qttyio_$rs (10, "^a MME READIO @ ^p", ctime (), mmep);
      genp = addrel (execp, spa.regs.x (4));		/* get ptr to options template */
      i = opt_temp.bufnum;				/* get tadio buffer number */
      tolts_info.tadio (i).inuse = "0"b;		/* reset  buffer in use flag */
      genp = addrel (execp, opt_temp.opt_ptr);		/* get ptr to store options */
      bcd_options = tolts_info.tadio (i).option;		/* move options to test page */
      call return_plus (3);				/* return ic + 3 */
%page;
/* ********* MME RELEAS ********* ( release device (reboot mpc firmware if running ITRs))

   input registers:

   *	POLT			MOLT
   X0	----			Master console file code
   X1	SCT (test page index * 4)	SCT (test page index * 4)
   X2	Patptr			----
   X4	----			Patptr
   X6	----			possible hang flag
   X7	0			Molt test type (In upper 6 bits: C = itrs, R = MDRs, T = MTAR, M = memory)
   AR	----			type code (tdcxxa)
   QR	----			ICC (XICCXXXX)

   mme     releas
   ------  return if error
   ------  return

   return registers: none */

mme_typ (-56): if trace then call tolts_qttyio_$rs (10, "^a MME RELEAS @ ^p", ctime (), mmep);
      if spa.regs.x (7) ^= "0"b then			/* if not polts */
         if substr (spa.regs.x (7), 1, 6) = "23"b3 then do; /* molts, running itrs */
	  call get_px_sct ("RELEAS", bin (spa.regs.x (1), 17), "1"b); /* get test page index */
	  if io_info.chan_suspended then do;		/* only load firmware if channel suspended */
	     call tolts_load_firmware_ (io_sel, error);	/* go load mpc firmware */
	     if error ^= 0 then			/* if error loading firmware */
	        call ck_release;			/* try again, and then ask user */
	  end;
         end;
      call return_plus (2);

/* ********* MME RLSMPC ********* (release mpc)

   input registers:   x1 = mpc controller sct pointer

   mme     rlsmpc
   ------  return

   return registers: none */

mme_typ (-26): if trace then call tolts_qttyio_$rs (10, "^a MME RLSMPC @ ^p", ctime (), mmep);
      call return_plus (1);

/* ********* MME RLSPAT ********* (release peripheral allocation table entry)

   input registers:   x4 = pat address (offset relative to LAL)

   mme     rlspat
   ------  return

   return registers: none */

mme_typ (-28): if trace then call tolts_qttyio_$rs (10, "^a MME RLSPAT @ ^p", ctime (), mmep);
      call return_plus (1);
%page;

/* ********* MME RSPCHK ********* (check for fnp response)

   input registers:   x1 = fpinfo table pointer

   mme     rspchk
   ----	 error return
   ----	 timeout return
   ----	 retry return
   ----	 good return

   return registers:  q = status word if fault occurs */

mme_typ (-91): if trace then call tolts_qttyio_$rs (10, "^a MME RSPCHK @ ^p", ctime (), mmep);

      tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1));	/* get a ptr to the test page fpinfo table */
      do io_sel = 1 to hbound (pages, 1)		/* get the io_info for this page */
       while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num);
      end;
      if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* io_info for this page not found */
      io_info_ptr = addr (pages (io_sel));
      tolts_rspd_wksp = io_info.tolts_rspd_wksp;
      call tolts_init_$gc_tod (gcos_tod);
      if tolts_rspd_workspace.mailbox.status_word ^= "0"b then do; /* error status stored */
         if tolts_fpinfo.io_rq_cnt > 0 then		/* if io request cnt > 0 */
	  tolts_fpinfo.io_rq_cnt = tolts_fpinfo.io_rq_cnt - 1;
         if substr (tolts_rspd_workspace.status_word, 4, 1) = "1"b /* if timeout */
	| bin (tolts_fpinfo.timeout_time) - bin (gcos_tod) < 1 then
	  call return_plus (2);			/* take timeout return */
         else do;					/* else take normal error return */
	  spa.regs.q = tolts_rspd_workspace.status_word;	/* return the status */
	  call return_plus (1);			/* take error return */
         end;
      end;
      else do;					/* no error */
         tolts_fpinfo.spec_cnt =
	tolts_rspd_workspace.mailbox.num_int.lvl7;	/* move spec count */
         tolts_fpinfo.term_cnt =
	tolts_rspd_workspace.mailbox.num_int.lvl3;	/* move term count */
         tolts_fpinfo.lvl3_cnt =			/* decr levl 3 count with saved value */
	tolts_fpinfo.term_cnt - bin (unspec (tolts_fpinfo.temp01.word2));
         tolts_fpinfo.lvl7_cnt =			/* decr levl 7 count with saved value */
	tolts_fpinfo.spec_cnt - bin (unspec (tolts_fpinfo.temp01.word1));
         if (tolts_fpinfo.lvl3_cnt = 0 & tolts_fpinfo.lvl3_flag) /* if no term int & one expected */
	| (tolts_fpinfo.lvl7_cnt = 0 & tolts_fpinfo.lvl7_flag) /* or no spec int & one ecpected */
	& (bin (tolts_fpinfo.timeout_time) < 0) then	/* & no timeout */
	  call return_plus (3);			/* take retry return */
         else do;
	  if tolts_fpinfo.io_rq_cnt > 0 then
	     tolts_fpinfo.io_rq_cnt = tolts_fpinfo.io_rq_cnt - 1;
	  if (tolts_fpinfo.lvl3_cnt = 1 | ^tolts_fpinfo.lvl3_flag)
	   & (tolts_fpinfo.lvl7_cnt = 1 | ^tolts_fpinfo.lvl7_flag) then
	     call return_plus (4);			/* take good return */
         end;
      end;

%page;
/* ********* MME SCTCMP********* (generate SCT entry)

   input registers: X2 = 128 chan number for new format

   mme     sctcmp
   zero    ficcdd,0
   zero    sctwrk,0
   ------  return good--shared file
   ------  return good--non-shared file
   ------  return error

   return registers:	X2 = error code if error (see set_sctwrk subroutine for error codes)
   *			output in sctwrk area: see set_sctwrk subroutine */

mme_typ (-29): if trace then call tolts_qttyio_$rs (10, "^a MME SCTCMP @ ^p", ctime (), mmep);
      do i = 1 to 8 while (pages (i).in_use);		/* find vacant page */
      end;
      if i = 8 & pages (8).in_use then do;		/* no vacant page */
         call tolts_qttyio_$rs (0, "^a: MME SCTCMP; No vacant test page slot found", exec);
         call tolts_abort ("$a1");
      end;
      unspec (pages (i)) = "0"b;			/* clear test page data */
      call set_sctwrk (i);				/* go set up the sct work area */
      if spa.regs.x (2) ^= "0"b then do;		/* if error */
         if fixed (spa.regs.x (2)) = m_iv_iom then	/* if invalid IOM number... */
	  spa.regs.x (2) = "0"b;			/* correct it */
         call return_plus (5);			/* take error return */
      end;
      pages (i).in_use = "1"b;			/* set page in use flag */
      tolts_info.exec_page_count = tolts_info.exec_page_count + 1; /* increment total test page count */
      if pages (i).io_type = polt_io_type then		/* if user wants to run itrs... */
         itr_run = "1"b;				/* set flag for wake_disp subroutine */
      call return_plus (4);				/* take good return */
%page;
/* ********* MME SETPRT & MME SETPR2 ********* (reserve printer (attach print file in Multics's case ))

   input/return registers: none

   mme     setprt
   ------  return tolts aborted
   ------  return tolts swapped
   ------  no prt available
   ------  return pr2 in use
   ------  return good */

mme_typ (-30):
mme_typ (-31): if trace then call tolts_qttyio_$rs (10, "^a MME SET^[PRT^;PR2^] @ ^p", ctime (), (mme_number = -33), mmep);
      if ^tolts_info.file_attach then do;		/* if print file not already attached... */
         call tolts_file_util_$open (error);		/* attach and open it */
         if error = 0 then				/* if no attach error */
	  call return_plus (5);			/* return good */
      end;
      call return_plus (3);				/* return ic + 3 */

/* ********* MME SETPUN ********* (set reader/punch to punch mode)

   input registers:   x1 = sct (test page index mod 4)

   mme     setpun
   ------  return, no operator message
   ------	 return, Output Operator message to put reader/punch in punch mode

   return registers: X1 = sct address

   Issued for 214 reader/punch to set in punch mode before mme allocr to set punch indicator in sct */

mme_typ (-32): if trace then call tolts_qttyio_$rs (10, "^a MME SETPUN @ ^p", ctime (), mmep);
      call get_px_sct ("SETPUN", bin (spa.regs.x (1), 17), "0"b); /* get test page index */
      io_info.ccu_pun = "1"b;				/* remember we want a punch */
      call return_plus (1);

/* ********* MME SETTYP & MME DISPRT ********* (reset prt or pr2 request)

   input/return registers: none

   mme     settyp
   ------  return tolts aborted
   ------  return tolts swapped
   ------  return good */

mme_typ (-11):
mme_typ (-33): if trace then call tolts_qttyio_$rs (10, "^a MME ^[SETTYP^;DISPRT^] @ ^p", ctime (), (mme_number = -33), mmep);
      if tolts_info.file_attach then			/* if print file attached... */
         call tolts_file_util_$close;			/*  close it out */
      call return_plus (3);				/* return ic + 3 */
%page;
/* ********* MME TADIOD ********* (T&D terminal I/O)

   input registers:	a-reg = 18/.tdpcn,6/pad,1/nu,1/dont record denial,1/mbz,3/exec,6/lid

   mme     tadio
   zero    nodcws,0
   zero    iotpd,wc   from 1 to 5 of these exist
   ------  return if tolts aborted
   ------  return if tolts swapped
   ------  return if request denied
   ------  return accepted

   return registers: none

   tadio type:		bit 23 "p" 1     print line	bit 22 "c" 2    controlling terminal
   *			bit 21 "s" 4     slave term.	bit 20 "m" 8    master console output
   *			bit 19 "r" 16    output/input	bit 18 "e" 32   select console/printer by option
   all valid combinations:	ps  - 5	sp  - 5	cs  - 6	sc  - 6	mp  - 9	pm  - 9	cm  - 10
   *			mc  - 10	ms  - 12	sm  - 12	mps - 13	msp - 13	pms - 13	psm - 13
   *			smp - 13	spm - 13	cms - 14	csm - 14	mcs - 14	msc - 14
   *			scm - 14	smc - 14	ep  - 33	pe  - 33	em  - 40	me  - 40	   */

mme_typ (-34): if trace then call tolts_qttyio_$rs (10, "^a MME TADIOD @ ^p", ctime (), mmep);
      ndcws = mme_call_hf (1).upper;			/* extract number of dcws */
      if ndcws < 1 | ndcws > 5 then do;
         call tolts_qttyio_$rs (0, "^as: MME TADIOD; Number of dcws = ^d", exec, ndcws);
         call tolts_abort ("$b2");
      end;
      do i = 1 to 8 while (tolts_info.tadio (i).inuse);	/* find vacant tadio queue entry */
      end;
      if i = 8 & tolts_info.tadio (8).inuse then do;	/* no queue entry */
         call tolts_qttyio_$rs (0, "^as: MME TADIOD; No vacant queue entry", exec);
         call tolts_abort ("$b2");
      end;
      tolts_info.tadio (i).inuse = "1"b;		/* fill in the queue entry */
      tolts_info.tadio (i).return_word (3) = "000000006361"b3; /* phy term sb 24-35 */
      tolts_info.tadio (i).return_word (2) = bit (bin (i, 18)) || "000000"b3;
      if substr (mme_call_w (2), 20, 1) = "1"b then do;	/* if read involved */
         tolts_info.tadio (i).optrd = "1"b;
         tolts_info.tadio (i).return_word (1) = "204652"b3 || substr (spa.regs.a, 1, 18); /* " o-||.tdpcn */
         pad_char = substr (spa.regs.a, 19, 6);		/* pick up pad character */
         do j = 0 to 83;				/*  pad options buffer */
	  substr (tolts_info.tadio (i).option, (j * 6) + 1, 6) = pad_char;
         end;
      end;
      else do;
         tolts_info.tadio (i).optrd = "0"b;
         tolts_info.tadio (i).return_word (1) = "206252"b3 || substr (spa.regs.a, 1, 18); /* " s-||.tdpcn */
      end;
      call tolts_qttyio_$dcw_ptr (addrel (mmep, 2), ndcws, i); /* go queue up message */
      spa.enter.icivlu.ic = rel (addr (mme_call_w (5 + ndcws))); /* return ic +5 + number of dcws */
      call wake_disp;				/* go wake up dispatcher */
%page;
/* ********* MME TDIO ********* (issue I/O to device under test)

   input registers: none

   mme     tdio			eep commands:	3100007x4000 = diagnostic mode control
   zero    myioq,0					2200007x4000 = read controller main memory
   zero    tpbase,0					0600007x4000 = initiate read data transfer
   zero    datara,redfol-wrtpre+1  ( = 0 if molts)	where x = 0 if last and 2 if continue idcw
   zero    iotrac,0
   ------  return

   return registers: AR = Time of day of connect, QR = lostit time, X4 = test page index */

mme_typ (-36): ioe_ptr = addrel (execp, mme_call_hf (1).upper); /* get ptr to our io_entry */
      if trace then do;
         call tolts_qttyio_$rs (10, "^a MME TDIO @ ^p", ctime (), mmep);
         call ioa_$rsnnl ("^/io_entry:^-^4(^12.3b ^)^/^-^4(^12.3b ^)^/^-^3(^12.3b ^)",
	message, mesg_len, ioe, ioe (5), ioe (9));
         call tolts_qttyio_ (message, 10);
      end;
      if trace_io then do;				/* count number of mme tdio's if -tio option true */
         call tolts_qttyio_$rs (10, "^a MME TDIO @ ^p", ctime (), mmep);
         call ioa_$rsnnl ("^/io_entry:^-^4(^12.3b ^)^/^-^4(^12.3b ^)^/^-^3(^12.3b ^)",
	message, mesg_len, ioe, ioe (5), ioe (9));
         call tolts_qttyio_ (message, 10);
         tio = tio + 1;
         call tolts_qttyio_$rs (10, " MME TDIO =  ^b @ ^a", tio, ctime ()); /* notify user of tally of tdio's */
      end;
      call get_px_sct ("TDIO  ", bin (io_entry.sct_add, 17), "1"b); /* get test page index */
      if io_info.io_type = mca_io_type then call mca_io_setup; /* mca is special */
      else call io_setup;				/* go set up our workspace */
      if io_info.suspend_chan then do;			/* if channel to be suspended */
         call ioi_$suspend_devices (io_info.device_index, error); /* let ioi_$ stop other io */
         if error ^= 0 then do;			/* error, abort */
	  call output_status_code (error, "suspend devices error");
	  call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
	   string (io_info.icivlu));			/* enter ccc request */
	  io_info.suspend_chan = "0"b;
	  io_info.io_in_progress = "0"b;		/* reset io in progress flag */
	  if tolts_info.gewake_active then do;		/* if gewake alarm set */
	     call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* reset it */
	     call ipc_$drain_chn (tolts_info.gewake_event, error); /* make sure no alarms queue up */
	     tolts_info.gewake_active = "0"b;		/* reset flag */
	  end;

	  call tolts_abort ("$b5");
         end;
         io_info.chan_suspended = "1"b;			/* remember that channel suspended */
      end;
      if io_info.io_type = mca_io_type then do;
         if io_entry.prim.dev_cmd = "40"b3 then		/* if reset dcw */
	  call mca_$reset (io_info.mca_ioi_idx, "0"b, error);
         else if io_entry.prim.dev_cmd = "15"b3 then	/* send mca data */
	  call mca_$tandd_write_data (io_info.mca_ioi_idx,
	   io_info.workspace_ptr, io_block_len, "0"b, error);
         else if io_entry.prim.dev_cmd = "13"b3 then	/* send mca command */
	  call mca_$tandd_write_text (io_info.mca_ioi_idx,
	   io_info.workspace_ptr, io_block_len, "0"b, error);
         else if io_entry.prim.dev_cmd = "03"b3 then	/* every write must be followed by a read */
	  call mca_$tandd_read_data (io_info.mca_ioi_idx,
	   io_info.workspace_ptr, io_block_len, "0"b, error);
         else error = error_table_$bad_command_name;
      end;
      else call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error);
      if error ^= 0 then do;
         call output_status_code (error, "doing io for a tdio");
         call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
	string (io_info.icivlu));			/* enter ccc request */
         io_info.io_in_progress = "0"b;			/* reset io in progress flag */
         if tolts_info.gewake_active then do;		/* if gewake alarm set */
	  call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* reset it */
	  call ipc_$drain_chn (tolts_info.gewake_event, error); /* make sure no alarms queue up */
	  tolts_info.gewake_active = "0"b;		/* reset flag */
         end;

         call tolts_abort ("$b5");
      end;
      call tolts_init_$gc_tod (spa.regs.a);		/* get current time of day */
      io_info.con_time = bin (spa.regs.a, 35);		/* save connect time */
      spa.regs.q = bit (bin (io_info.lostit_time, 36));	/* set lostit time */
      spa.regs.x (4) = bit (bin (io_sel * 4, 18));	/* return test page index, mod 4 */
      tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1;/* increment global IO count */
      call return_plus (5);				/* return ic + 5 */
%page;
/* ********* MME TERMIN ********* (terminate slave executive)

   input registers: none

   mme     termin
   does not return */

mme_typ (-35): if trace then call tolts_qttyio_$rs (10, "^a MME TERMIN @ ^p", ctime (), mmep);
      term = "1"b;					/* set terminate condition */
      go to term_lbl;				/* and perform nonlocal goto */

/* ********* MME TNDBUG ********* (tolts debugger break point))

   input/return registers: none

   mme     tndbug

   restores mme word with original value and returns to mme location */

mme_typ (-88):
      if ^debugging then call return_plus (1);
      call probe (mtdsim_);
      exec_wd (db_addr) = db_sv_wd;
      tolts_info.mult_ans = "";			/* clear out response */
      call tolts_qttyio_$rs (19, "tolts_debugger: enter break point address");
      call message_wait;				/* wait for user response */
      if mult_ans ^= "" then do;
         db_addr = cv_oct_check_ ((rtrim (mult_ans)), code);
         db_sv_wd = exec_wd (db_addr);
         exec_wd (db_addr) = "777650001000"b3;
      end;
      call return_plus (0);				/* return ic + 0 */

/* ********* MME TOLDIS ********* (disconnect logical terminal ID (LID))

   input/return registers: none

   mme     toldis
   ------  return tolts aborted
   ------  return tolts swapped
   ------  return */

mme_typ (-37): if trace then call tolts_qttyio_$rs (10, "^a MME TOLDIS @ ^p", ctime (), mmep);
      call return_plus (3);				/* return ic + 3 */


/* ********* MME TOLGON ********* (used in gecos to inform tolts is terminating)
   mme	   tolgon
   -----   return   */

mme_typ (-38): if trace then call tolts_qttyio_$rs (10, "^a MME TOLGON @ ^p", ctime (), mmep);
      call return_plus (1);


/* ********* MME TOLTIN ********* (slave executive idle dispatcher)

   input registers:   q-reg = time in 1/64 ms for wakeup

   mme     toltin
   ------  return not in core
   ------  return in core   (does mme gewake if in core)

   return registers: none */

mme_typ (-39): if trace then call tolts_qttyio_$rs (10, "^a MME TOLTIN @ ^p", ctime (), mmep);

      wake_time = divide (fixed (spa.regs.q) * 1000, 64, 71, 0); /* convert gcos time to useconds */
      call timer_manager_$alarm_wakeup (wake_time, "10"b, tolts_info.gewake_event); /* set the alarm  */
      tolts_info.gewake_active = "1"b;			/* set flag for int processor */
      spa.enter.icivlu.ic = rel (addr (mme_call_w (2)));	/* increment ic by 2 */
      go to blk_lbl;				/* return to blocked state */
%page;
/* ********* MME TRACIO ********* (trace I/O events (GCOS only, Unused in Multics))

   input/output registers: none

   mme     tracio
   iotd    msg,wordcount
   ------  return */

mme_typ (-40): if trace then call tolts_qttyio_$rs (10, "^a MME TRACIO @ ^p", ctime (), mmep);
      call return_plus (2);				/* return ic + 2 */

/* ********* MME UNFREZ ********* (unwire  main memory (gcos only))

   input/return registers:   none

   mme     unfrez
   ------  return */

mme_typ (-54): if trace then call tolts_qttyio_$rs (10, "^a MME UNFREZ @ ^p", ctime (), mmep);
      call return_plus (1);

/* ********* MME WRDUMP ********* (wrapup dump)

   input registers:	areg = iotd for dump prefix
   *		qreg = start,size (relative to LAL)
   *		x1 = address bias (-1024 or page base)
   *		x2 = master/slave (=3hm  ,=3hs  )

   mme     wrdump
   ------  return

   return registers: none */

mme_typ (-42): if trace then call tolts_qttyio_$rs (10, "^a MME WRDUMP @ ^p", ctime (), mmep);
      if tolts_info.file_attach then do;		/* if print file attached... */
         call tolts_file_util_$wdump (addr (spa.regs));	/* go output entire dump */
         call tolts_file_util_$close;
      end;
      else call tolts_qttyio_$rcw (addr (spa.regs.a));	/* otherwise just output dump prefix */
      call return_plus (1);				/* return ic + 1 */
%page;
mme_typ (-60): mme_typ (-58): mme_typ (-57):
mme_typ (-49): mme_typ (-48): mme_typ (-47): mme_typ (-46): mme_typ (-45):
mme_typ (-44): mme_typ (-43): mme_typ (-41): mme_typ (-27): mme_typ (-23): mme_typ (-10):
mme_typ (-25): mme_typ (-15): mme_typ (-14):
mme_typ (-3): mme_typ (0): mme_typ (3): mme_typ (4): mme_typ (6): mme_typ (7):
mme_typ (8): mme_typ (10): mme_typ (11): mme_typ (12): mme_typ (13): mme_typ (16):
mme_typ (19): mme_typ (20): mme_typ (22): mme_typ (23): mme_typ (25):
mme_typ (26): mme_typ (27): mme_typ (28): mme_typ (29):
undefm:

      in_ccc = "0"b;
      call tolts_qttyio_$rs (0, "^as: Improper MME @ ^p; MME type - ^d; Instruction - ^12.3b",
       exec, mmep, mme_call_hf (0).upper, mme_call_w (0));
      call tolts_abort ("$b6");

/* epilogue - entry called by execute_epilogue_ when process is terminated */

epilogue: entry;

      if tolts_active then do;			/* continue only if we were active */
         tolts_info.finish_cond = "1"b;			/* set finish flag */
         call hcs_$get_ips_mask (old_mask);		/* get current ips mask */
         new_mask = old_mask | sys_info$alrm_mask;	/* make sure "alrm"s are enabled */
         call hcs_$set_ips_mask (new_mask, new_mask);	/* set the mask */
         call clean_up;				/* go cleanup our enviornment */
         call hcs_$set_ips_mask (old_mask, old_mask);	/* set original ips mask */
      end;
      return;
%page;

/* return_plus - int procedure to add specified value to ic, wakeup dispatcher and take non-local goto to block */

return_plus: proc (ic_inc);

dcl  ic_inc fixed bin;				/* value to increment ic by */

      spa.enter.icivlu.ic = rel (addr (mme_call_w (ic_inc))); /* increment ic */

/* wake_disp - entry to do non-local goto to dispatcher. If there is any oustanding IO,
   the wait event channel is woken up and we do non-local goto to the dispatcher block label.
   If there is no outstanding IO (terminal or test IO), we do non-local goto  directly
   back to the no_blk label, thus saving needless wakeyps and blocks */

wake_disp: entry;

      if (tolts_info.term_io_req_cnt = 0 & tolts_info.glob_int_cnt = 0 /* if there is nothing to wait for... */
       & ^tolts_info.exec_term_io_wait & ^colts_op_flags.colt_flag) then /* go back to slave exec, don't go blocked */
         go to no_blk;				/* do non-local goto */

      call hcs_$wakeup (tolts_info.process, tolts_info.wait_list.wait_event_id (1), null, error);
      if error ^= 0 then do;				/* this is a fatal error, terminate our process */
         call com_err_ (error, exec, "***fatal error, terminating process"); /* but tell user first */
         fatal_desc.version = 0;
         fatal_desc.fatal_code = error;
         if ^debugging then
	  call terminate_process_ ("fatal_error", addr (fatal_desc));
         else signal tolts_error_;
      end;					/* no need to return, as we won't be back */
      go to blk_lbl;				/* take non-local goto to dispatcher block */

   end return_plus;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
/*											*/
/* fault_dump - internal procedure to force open a file for tolts abort				*/
/*											*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

fault_dump: proc;
      flt_flag = "1"b;
      if ^tolts_info.file_attach then
         call tolts_file_util_$open (error);
      if error ^= 0 then do;
         call com_err_ (error, exec, "encountered an error while attempting to open a point file for ^a", error);
         call tolts_abort ("$t1");
      end;
      if debugging then call probe (mtdsim_);
      if tolts_info.file_attach then do;
         call display_mc;
         call tolts_file_util_$wdump (execp);		/* go output entire dump */
         call tolts_file_util_$close;

         in_ccc = "0"b;
         call tolts_abort ("$t2");
      end;
   end fault_dump;



/* tolts_abort - internal procedure to set up abort vectors for the slave exec */

tolts_abort: proc (a_code);

dcl  a_code char (3);
dcl  tfc bit (18);

      call tolts_alm_util_$ascii_to_bcd_ (a_code, tfc);	/* convert fault code to bcd */
      spa.abort.code = tfc;				/* and store in spa */
      spa.abort.add = scu.ilc;			/* equals address of last mme */
      if spa.wrapup_add = "0"b			/* if we have not been thru mme pointit yet.. */
       | flt_flag then do;				/* or we have detected a fault */
         call clean_up;
         term = "1"b;				/* set terminate condition */
         go to term_lbl;				/* take non-local goto to get out of dispatcher */
      end;
      spa.enter.icivlu.ic = spa.wrapup_add;		/* set wrapup address */
      call wake_disp;				/* and wake up dispatcher */

   end tolts_abort;

/* display_mc - int proc to display machine conditions after a fault */

display_mc: proc;

dcl  cu_$stack_frame_ptr entry (ptr);
dcl  dump_machine_cond_ entry (ptr, ptr, char (32) aligned, fixed bin);
dcl  find_condition_frame_ entry (ptr) returns (ptr);
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  hran_$hranl entry (ptr, ptr, bit (1));
dcl  ioa_ entry () options (variable);
dcl  ioa_$ioa_switch entry () options (variable);
dcl  (faultsp, hreg_ptr, stackp) ptr;
dcl  code fixed bin (35);


      call cu_$stack_frame_ptr (stackp);		/* get current sstack ptr */
      faultsp = find_condition_frame_ (stackp);		/* is this the cond frame ? */
      if faultsp = null () then do;
         call ioa_ ("^a: Cannot find condition frame.", "exec_name");
         return;
      end;

      call find_condition_info_ (faultsp, addr (ci), code);
      if ci.mc_ptr = null () then do;
         call ioa_ ("^a: Cannot find condition frame.", "exec_name");
         return;
      end;


      call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/MACHINE CONDITIONS AT ^p:^/", ci.mc_ptr);
      call dump_machine_cond_ (addr (ci), faultsp, "err_file", 2); /* print the MC */

HREGS:
      if mcptr ^= null then hreg_ptr = addrel (mcptr, 96);
      if hreg_ptr = null then do;			/* no history regs to dump */
         call ioa_$ioa_switch (tolts_info.pf_iocbp, "History Registers are not available");
         return;
      end;
      else do;
         call ioa_$ioa_switch (tolts_info.pf_iocbp, "CPU HISTORY REGISTERS AT TIME OF FAULT");
         call hran_$hranl (hreg_ptr, tolts_info.pf_iocbp, "0"b);
      end;

      return;
   end display_mc;


%page;

/* set_sctwrk - internal procedure to set up the sct work area sctwrk */

set_sctwrk: proc (px);

dcl  px fixed bin;					/*  test page index */

/*
   output in sctwrk (12 words):

   18/devsct,6/0,12/xbicc
   18/altsct,6/g3typ,12/0
   18/cntsct,4/iotyp,4/cnttyp,1/pad,4/xiotyp,4/xcnttyp,1/pad
   18/cont. sct,18/mpc index (36/0 for non mpc)
   36/word +0 of .crcst entry for mpc
   36/word +1 of .crcst entry for mpc
   36/word +2 of .crcst entry for mpc
   36/word +3 of .crcst entry for mpc
   36/word +0 of sct entry
   36/word +1 of sct entry
   36/word +0 of alt sct
   36/word +1 of alt sct
*/
      genp = addrel (execp, mme_call_hf (2).upper);	/* get pointer to sctwrk */
      spa.regs.x (2), sctwrk = "0"b;			/* initialize sctwrk first */
      t_err = 0;
      call tolts_device_info_ (addrel (execp, mme_call_hf (1).upper), px, t_err); /* get type code */
      spa.regs.x (2) = bit (bin (t_err, 18));		/* set x2 to type_error if any */
      substr (sctwrk (2), 19, 6) = pages (px).devsct.type_code; /* set type code */
      if ^pages (px).devsct.com_prph then do;		/* if mpc subsystem */
         pages (px).sct_info.cntsct = bit (bin (px * 4 + 1024, 18)); /* set cont. sct (device sct + 1024) */
         sctwrk (3) = unspec (pages (px).sct_info);	/* fill word 3 of sct area */
         substr (sctwrk (4), 1, 18) = bit (bin (px * 4 + 1024, 18)); /* set cont. sct */
      end;
      sctwrk (5) = unspec (pages (px).crcst);		/* set crcst entry wrd 0 */
      sctwrk (6) = unspec (pages (px).crcst);		/* set crcst entry wrd 1 */
      sctwrk (9) = unspec (pages (px).devsct.w1);		/* set dev sct word 1 */
      sctwrk (10) = unspec (pages (px).devsct.w2);	/* and word 2 */
      substr (sctwrk (1), 1, 18) = bit (bin (px * 4, 18));	/* set test page index (mod 4) */

/*   The sct pointer and sct data for the alternate device must be passed back to cmlt, provided mtar is running   */

      if (pages (px).alt_dev_flag) then do;		/* alt. device exists return device info */
         sctwrk (11) = unspec (pages (px).altsct.w1);
         sctwrk (12) = unspec (pages (px).altsct.w2);
         substr (sctwrk (2), 1, 18) = bit (bin (px * 4 + 512, 18));
      end;

   end set_sctwrk;
%page;

/* mca_io_setup - internal procedure to set up the mca workspace for mca I/O */

mca_io_setup: proc;


      dcwp = addrel (execp, dcw_ptr);
      mca_work_space_ptr = io_info.workspace_ptr;		/* get a ptr to our workspace */
      unspec (mca_work_space) = "0"b;			/* clear it */
      c_len = 4;					/* want to xfer 4 words */
      mvp = addrel (execp, dcw_ptr - 1);		/* set move ptr to idcw */
      bufp = addr (mca_work_space.list_of_dcw);		/* set buf ptr to work space dcw list */
      workspace_move = mvp -> workspace_move;		/* move it */
      bufp = addr (io_info.dcw_list);			/* move the buf ptrto save the dcw list in io_info */
      workspace_move = mvp -> workspace_move;		/* move it */
      if dcw.tally = "0"b3 then c_len = 4096;		/* check for 4096 tally */
      else c_len = bin (dcw.tally);			/* else use as is */
      io_block_len = c_len + 4096 + 2;			/* set io block length to reflect the tally */
      mvp = addrel (execp, dcw.address);		/* set move ptr to data to be sent */
      bufp = addr (mca_work_space.data_header_1);		/* set buf ptr to data header area */
      workspace_move = mvp -> workspace_move;		/* move it */
      data_size_1 = fixed (data_header_1.dest_len_msb || data_header_1.dest_len_lsb, 16);
      io_info.icivlu.ic = io_entry.ccc_p;		/* set entry to call on io completion */
      io_info.icivlu.ind = "0"b;			/* initialize indicators */
      io_info.status_add = fixed (io_entry.stat_p);	/* save status storage ptr */
      exec_wd (io_info.status_add) = "0"b;		/* initialize test page status */
      exec_wd (io_info.status_add + 1) = "0"b;
      io_info.pcwa = pcwa;				/* save pcw */
      io_info.tio_off = 0;				/* save dcw list offset */
      io_info.rew_wait = "0"b;			/* not expecting special interrupt */
      io_info.io_in_progress = "1"b;			/* set flag for interrupt processing */
      io_info.num_connects = io_info.num_connects + 1;
      io_info.int_time = 0;				/* clear out interrupt time */

   end mca_io_setup;





/* io_setup - internal procedure to set up the ioi workspace for test I/O */

io_setup: proc;

dcl  (continue, first, idcw_io) bit (1);
dcl  (cbuf_add, lstloc, nxtloc) fixed bin;
dcl  dcwb fixed bin (18) uns;

      ioi_wksp = io_info.workspace_ptr;			/* get a ptr to our workspace */
      continue = "0"b;				/* reset continue flag */
      unspec (wks_init) = "0"b;			/* initialize workspace to zero */
      tolts_workspace.l_pad.e = "525252525252"b3;		/* set up our lower buffer pad */
      tolts_workspace.l_pad.o = "525252525252"b3;
      tio_off = fixed (rel (addr (tolts_workspace.p_idcw)));/* set default dcw list offset for ioi */
      idcwp = addr (tolts_workspace.p_idcw);		/* set up idcw ptr */
      idcw.code = "7"b3;				/* set in idcw type code */
      if io_entry.prim.io_cmd = "40"b3			/* if idcw I/O */
       | io_entry.prim.io_cmd = "24"b3
       & io_info.io_type = mhp_io_type then do;		/* | idcw I/O & hyper */
         idcw_io = "1"b;				/* set flag for idcw io */
         idcw.command = io_entry.prim.dev_cmd;		/* set up first idcw from io entry word 4 */
         if (idcw.command = "31"b3 & io_info.chan_suspended)/* if diagnostic mode control... */
	| io_entry.prim.dev ^= "00"b3 then		/* or punch indicator */
	  idcw.chan_cmd = "00"b3;			/* set data xfer chan command */
         else if io_entry.prim.io_cmd = "24"b3		/* if cmd = 24 */
	& io_info.io_type = mhp_io_type then		/* & hyper io */
	  idcw.chan_cmd = "00"b3;			/* set data xfer chan command */
         else if io_info.io_type = mtar_io_type then	/* if mtar  */
	  idcw.chan_cmd = "00"b3;			/* set data xfer chan command */
         else idcw.chan_cmd = "40"b3;			/* otherwise set special cont. cmd */
         idcw.count = io_entry.prim.record_count;		/* set record count */
         if idcw.count ^= "00"b3 & idcw.count ^= "01"b3 then do; /* if not single idcw */
	  idcw.control = "10"b;			/* set idcw continue bit */
	  continue = "1"b;				/* set continue flag */
         end;
         if idcw.command = "00"b3 then			/* if suspend command */
	  io_info.suspend_chan = "1"b;		/* set flag for mme tdio */
         if idcw.command = "20"b3 then			/* if release command */
	  io_info.release_chan = "1"b;		/* set flag for tolts_io_int_ */
      end;					/* note that device code is = 0 */
      else do;					/* not idcw I/O, single or dual I/O */
         idcw_io = "0"b;
         idcw.command = io_entry.second.dev_cmd;		/* get idcw from word 7 (same for single or dual I/O */
         idcw.chan_cmd = io_entry.second.io_cmd;
         idcw.count = io_entry.second.record_count;
         if io_info.io_type = itr_io_type		/* insure that release_chan is reset */
	then io_info.suspend_chan = "0"b;		/* in the event no special was returned */
         if io_entry.prim.dev_cmd ^= io_entry.second.dev_cmd then do; /* disk/dual I/O */
	  idcwp = addr (tolts_workspace.seek_idcw);	/* set up seek idcw */
	  idcw.command = io_entry.prim.dev_cmd;		/* set device command */
	  if bin (io_entry.sct_add, 13) >= 512
	   then idcw.device = io_info.altsct.device_no;
	  else idcw.device = io_info.devsct.device_no;
	  idcw.code = "7"b3;
	  idcw.control = "10"b;			/* set continue bit in idcw */
	  idcw.chan_cmd = io_entry.prim.io_cmd;
	  idcw.count = io_entry.prim.record_count;
	  dcwp = addr (tolts_workspace.seek_dcw);	/* set ptr to seek dcw */
	  string (dcw) = "0"b;			/* initialize */
	  dcw.address = rel (addr (tolts_workspace.seek_add)); /* set dcw address */
	  dcw.tally = "0001"b3;			/* set tally of one */
	  i = fixed (rel (addrel (execp, first_dcw.address))); /* compute index to seek add */
	  tolts_workspace.seek_add = exec_wd (i);	/* move seek address to workspace */
	  tio_off = fixed (rel (addr (tolts_workspace.seek_idcw))); /* set dcw list offset to seek idcw */
         end;
      end;

/* process dcw list */

      idcwp = addr (tolts_workspace.p_idcw);		/* set primary idcw ptr */

      if ^mpc_io then				/* if not controller io */
         if bin (io_entry.sct_add, 13) >= 512
	then idcw.device = io_info.altsct.device_no;
         else idcw.device = io_info.devsct.device_no;
      dcwp = addrel (execp, io_entry.dcw_ptr);		/* set dcw ptr to first dcw */
      if string (dcw) = "0"b then do;			/* if non data command */
         tolts_workspace.buf_size, c_len = 1;		/* set buffer size to 1 word */
         dcwp = addr (tolts_workspace.dcw_list (1));	/* set up iotd that should not be used */
         string (dcw) = "0"b;				/* initialize dcw */
         dcw.address = rel (addr (tolts_workspace.data_buf));
         dcw.tally = "0001"b3;			/* 1 word iotd */
         if continue then				/* if idcw continue bit set */
	  idcw.control = "00"b;			/* reset it now */
         go to non_data;				/* bypass dcw processing */
      end;
      io_info.page_base = bin (dcw.address);		/* set first dcw address as data buf base */
      first, found = "0"b;				/* reset terminate condition */
      unspec (io_info.dcw_list) = "0"b;			/* clear out saved dcw list */
      lstloc, nxtloc, j = 1;				/* set initial dcw copy index */
      bufp = addr (tolts_workspace.data_buf (1));		/* set intial buffer ptr */
      do i = 1 to hbound (tolts_workspace.dcw_list, 1) while (^found); /* go through dcw list */
         tolts_workspace.dcw_list (j) = string (dcw);	/* copy dcws (and idcws) to work space */
         io_info.dcw_list (j) = string (dcw);		/* and for interrupt processor */
         if dcw.char_pos = "7"b3 then do;		/* if idcw */
	  idcwp = addr (tolts_workspace.dcw_list (j));	/* set idcw ptr */
	  if idcw.control = "10"b then		/* if idcw continue bit set */
	     continue = "1"b;			/* set continue flag */
	  else continue = "0"b;			/* otherwise reset it */

	  if ^mpc_io then				/* if not controller io */
	     if bin (io_entry.sct_add, 13) >= 512
	      then idcw.device = io_info.altsct.device_no;/* set device code */
	     else idcw.device = io_info.devsct.device_no;
	  j = j + 1;				/* increment copy dcw index */
         end;
         else if dcw.type = "10"b then			/* if tdcw */
	  dcwp = addrel (execp, bin (dcw.address) - 1);	/* set dcwp to list -1 */
         else do;					/* data dcws */
	  if ^first then do;			/* if the first time through */
	     first = "1"b;				/* set flag, so we don't come back */
	     dcwb = bin (dcw.address);		/* set dcw base address */
	  end;
	  mvp = addrel (execp, dcw.address);		/* get ptr to data to move */
	  c_len = bin (dcw.tally);			/* get length of data */
	  if string (dcw) = "0"b then do;		/* if illegal zero dcw */
	     c_len = 1;				/* set length = 1 */
	     dcw.address = io_entry.stat_p;		/* set address to status word */
	     call tolts_qttyio_$rs			/* tell user */
	      (0, "Tolts: Last io_entry contains an illegal dcw. Please investigate");
	  end;
	  if c_len = 0 then c_len = 4096;		/* allow for a dcw tally of 4096 */
	  cbuf_add = bin (dcw.address) - dcwb;		/* compute relative address */
	  if cbuf_add = 0 then			/* if this dcw address is the same last */
	     cbuf_add = lstloc;			/* set the same index */
	  else cbuf_add = nxtloc;			/* otherwise use next avail address */
	  tolts_workspace.buf_size = cbuf_add;
	  bufp = addr (tolts_workspace.data_buf (cbuf_add)); /* set buffer ptr */
	  workspace_move = mvp -> workspace_move;	/* and move it */
	  mvp = addr (tolts_workspace.dcw_list (j));	/* set ptr to workspace dcw */
	  mvp -> dcw.address = rel (bufp);		/* set relative address */
	  lstloc = bin (mvp -> dcw.address) - bin (rel (addr (tolts_workspace.data_buf (1)))) + 1;
	  nxtloc = lstloc + c_len;			/* set next available location */
	  dcwb = bin (dcw.address);			/* set up to look at nxt dcw */
	  if idcw_io then do;			/* if running mdrs */
	     bufp = addrel (bufp, c_len);		/* set nxt buffer address for idcw io */
	     c_len = 0;				/* reset current length */
	  end;
	  j = j + 1;				/* increment copy dcw index */
	  if dcw.type = "00"b then			/* if iotd */
	     if ^continue then			/* and continue flag not set */
	        found = "1"b;			/* set terminate condition */
         end;
         dcwp = addrel (dcwp, 1);			/* increment dcw ptr to next one */
      end;
      tolts_workspace.buf_size = (bin (rel (bufp)) + c_len) - bin (rel (addr (tolts_workspace.data_buf (1))));
non_data:
      tolts_workspace.h_pad.e = "252525252525"b3;		/* set upper buffer pad */
      tolts_workspace.h_pad.o = "252525252525"b3;
      if io_info.devsct.com_prph then do;		/* if common prph channel */
         pcwa = tolts_workspace.p_idcw;			/* pick up first idcw */
         tio_off = fixed (rel (addr (tolts_workspace.dcw_list (1)))); /* can't execute idcw on com prph */
      end;
      else pcwa = "000000700000"b3;			/* otherwise set phony pcw for ioi */
      if substr (mme_call_w (4), 1, 1) = "1"b then do;	/* if user wants dcws traced */
         io_info.io_trc_flag = "1"b;			/* set io trace flag */
         call ioa_$rsnnl ("^/  ^/*** i/o trace ***^/", message, mesg_len);
         if io_entry.prim.dev_cmd ^= io_entry.second.dev_cmd & ^idcw_io then /* if disk io */
	  call ioa_$rsnnl ("^a^/seek idcw: - ^12.3b, seek dcw: - ^12.3b, seek address: - ^12.3b",
	   message, mesg_len, message, tolts_workspace.seek_idcw,
	   tolts_workspace.seek_dcw, tolts_workspace.seek_add);
         call ioa_$rsnnl ("^a^/^[pcw^;idcw^]: - ^12.3b^/dcw list:^/",
	message, mesg_len, message, io_info.devsct.com_prph, tolts_workspace.p_idcw);
         do i = 1 by 4 while (tolts_workspace.dcw_list (i) ^= "0"b); /* put out only valid dcws */
	  call ioa_$rsnnl ("^12.3b ", lginfo, mesg_len, tolts_workspace.dcw_list (i));
	  do j = 1 to 3 while (tolts_workspace.dcw_list (i + j) ^= "0"b); /* 4 wds per line */
	     call ioa_$rsnnl ("^a ^12.3b ", lginfo, mesg_len, lginfo, tolts_workspace.dcw_list (i + j));
	  end;
	  call ioa_$rsnnl ("^a^/", lginfo, mesg_len, lginfo);
	  message = rtrim (message) || lginfo;		/* add line to message */
         end;
         call tolts_qttyio_ (message, 10);
      end;
      else io_info.io_trc_flag = "0"b;			/* reset trace flag */
      io_info.ext_status_add = io_entry.ext_sts;		/* copy extended status store address */
      io_info.ignore_term = io_entry.second.ignore_term;	/* copy ignore term flag */
      io_info.icivlu.ic = io_entry.ccc_p;		/* set entry to call on io completion */
      io_info.icivlu.ind = "0"b;			/* initialize indicators */
      io_info.status_add = fixed (io_entry.stat_p);	/* save status storage ptr */
      exec_wd (io_info.status_add) = "0"b;		/* initialize test page status */
      exec_wd (io_info.status_add + 1) = "0"b;
      io_info.pcwa = pcwa;				/* save pcw */
      io_info.tio_off = tio_off;			/* save dcw list offset */
      io_info.rew_wait = "0"b;			/* not expecting special interrupt */
      io_info.io_in_progress = "1"b;			/* set flag for interrupt processing */
      io_info.num_connects = io_info.num_connects + 1;
      io_info.int_time = 0;				/* clear out interrupt time */

   end io_setup;
%page;
/* get_px_sct - subroutine to get the correct test page index, given entry index */
/* the globol variables io_sel, mpc_io and io_info_ptr are set up by this subroutine */

get_px_sct: proc (mname, px, ck_alloc);

dcl  mname char (6);
dcl  px fixed bin;
dcl  ck_alloc bit (1);

      if px >= 1024 then do;				/* ck for controller sct */
         mpc_io = "1"b;				/* set flag if controller sct */
         io_sel = px - 1024;				/* get device sct */
      end;
      else if px >= 512 then do;			/* check for alt. device sct */
         mpc_io = "0"b;
         io_sel = px - 512;				/* get primary device sct */
      end;
      else do;					/* not controller sct, it is device sct */
         mpc_io = "0"b;				/* reset controller io flag */
         io_sel = px;				/* test page index is correct as is */
      end;
      io_sel = divide (io_sel, 4, 17, 0);		/* Multics scts are mod 4 */
      if io_sel < 1 | io_sel > 8 | ^pages (io_sel).in_use |
       (ck_alloc & ^pages (io_sel).allocated) then do;	/* if error in sct */
         call tolts_qttyio_$rs (0, "^as: MME ^a; Invalid SCT - ^6.3b",
	exec, mname, bit (bin (px, 18)));
         call tolts_abort ("$a2");
      end;
      io_info_ptr = addr (pages (io_sel));		/* get ptr to this test page */

   end get_px_sct;

/* get_px_tcx - subroutine to get the correct page index, given the true channel index (ICC) */
/* the global variables io_sel and io_info_ptr are set up by this subroutine */

get_px_tcx: proc (mname, tci);

dcl  mname char (6);
dcl  tci bit (11);

      do io_sel = 1 to (hbound (pages, 1))
       while (tci ^= pages (io_sel).devsct.icc);		/* find correct page */
      end;
      if io_sel > (hbound (pages, 1)) then do;		/* no matching page */
         call tolts_qttyio_$rs (0, "^as: MME ^a; no matching page found for true chan. index - ^3.3b",
	exec, mname, tci);
         call tolts_abort ("$m1");
      end;
      else io_info_ptr = addr (pages (io_sel));		/* get ptr to this test page */

   end get_px_tcx;
%page;

/* output_status_code - internal procedure to queue up a status message */

output_status_code: proc (ecode, mess);

dcl  ecode fixed bin (35);
dcl  mess char (*);

      call convert_status_code_ (ecode, shortinfo, lginfo);
      call tolts_qttyio_$rs (0, "^as: ^a^/^a", tolts_info.exec, lginfo, mess);
   end output_status_code;

dealcp_sub: proc;

      dealc_err = 0;
      if io_info.p_att | io_info.alloc_wait then do;	/* if perp. device attached to this page */
         call ck_release;				/* go check mpc stae */
         if io_info.io_type = mca_io_type then do;
	  if io_info.ipc_attached then do;
	     call tolts_qttyio_$rs (0, "^a IPC ^a not reloaded.^/^a^/", io_info.test_hdr, io_info.ipc_number,
	      "Do you wish to quit leaving IPC unloaded?");
ask_again:     call tolts_qttyio_$rs (19, "Please answer yes or no. - ");
	     call message_wait;			/* wait for users answer */
	     if tolts_info.mult_ans = "yes"
	      | tolts_info.mult_ans = "y" then do;
	        io_info.suspend_chan = "1"b;
	        opr_query_info.q_sw = "0"b;
	        call ioa_$rsnnl ("^/^a Unrecoverable error running ipc ^a firmware.^/^-^a",
	         message, i, io_info.test_hdr, io_info.ipc_number,
	         "IPC will not be reloaded");
	        call opr_query_ (addr (opr_query_info),
	         substr (message, 1, i));		/* tell opr bad news */
	     end;
	     else if mult_ans = "no"
	      | mult_ans = "n" then do;
	        io_info.io_in_progress = "1"b;		/* set flag for interrupt processing */
	        io_info.num_connects = io_info.num_connects + 1;
	        call mca_$load_ipc (io_info.mca_ioi_idx, io_info.ipc_number,
	         "0"b, code);
	     end;
	     else goto ask_again;

	     call mca_$detach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx,
	      ^io_info.suspend_chan, code);
	     io_info.ipc_attached = "0"b;
	  end;
	  if io_info.mca_attach_state ^= MCA_NOT_CONFIGURED then do;
	     io_info.io_in_progress = "1"b;		/* set flag for interrupt processing */
	     io_info.num_connects = io_info.num_connects + 1;
	     call mca_$reset (io_info.mca_ioi_idx, "0"b, code);
	     io_info.io_in_progress = "1"b;		/* set flag for interrupt processing */
	     io_info.num_connects = io_info.num_connects + 1;
	     call mca_$detach_mca (io_info.mca_ioi_idx, code);
	  end;
         end;
         else call rcp_$detach (io_info.rcp_id, "0"b, 0, "T&D is detaching " || io_info.device_name, error);
         if error ^= 0 then do;			/* error detaching device */
	  dealc_err = 1;
	  call output_status_code (error, "unassign error");
         end;
      end;

/* This code will detach the alternate device for mtar (or anyother program). The alternate device attached
   flag (io_info.p2_att) is checked to see if an alternate device is attached. If so it is detached.   */

      if io_info.p2_att then do;			/* detach alternate device if attached */
         call rcp_$detach (io_info.alt_rcp_id, "0"b, 0, "t&d is detaching " || io_info.alt_device_name, error);
         if error ^= 0 then do;			/* handle detach error */
	  dealc_err = 1;
	  call output_status_code (error, "unassign  error");
         end;
      end;
      if io_info.ev_ch_ass then do;			/* if status event channel assigned to this page */
         call ipc_$delete_ev_chn (io_info.status_event, error);
         if error ^= 0 then do;			/* error deleting event channel */
	  dealc_err = 1;
	  call output_status_code (error, " deleting test io event channel ");
         end;
      end;
      unspec (io_info) = "0"b;			/* clear the test page data */
      tolts_info.exec_page_count = tolts_info.exec_page_count - 1; /* decrement total test page count */
   end dealcp_sub;

/*  rel_exec_chan - internal procedure to release the colts exec channel */

rel_exec_chan: proc (k);

dcl  k fixed bin (6);
      dmap = addr (tolts_info.fnp (k).dm_arg);		/* get addr of dial_manager arg	*/
      fnp (k).dm_arg.version = dial_manager_arg_version_2;
      fnp (k).dm_arg.dial_qualifier = substr (fnp (k).exec_chan, 1, 22);
      tolts_info.fnp (k).dm_arg.dial_channel = tolts_info.dm_event; /* set dial_channel to event channel */
      tolts_info.fnp (k).dm_arg.channel_name = fnp (k).exec_chan; /* get channel name	*/

      call dial_manager_$release_channel (dmap, code);
      if code ^= 0 then do;
         if debugging then call com_err_ (code, "mtdsim_", "Error releasing ^a.", dmap -> dial_manager_arg.channel_name);
         call convert_status_code_ (code, shortinfo, lginfo);
         call tolts_qttyio_$rs (0, "^as: ^a/ error doing exec channel release", tolts_info.exec, lginfo);
         call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */
         fatal_desc.version = 0;
         fatal_desc.fatal_code = error;
         if ^debugging
	then call terminate_process_ ("fatal_error", addr (fatal_desc));
         else signal tolts_error_;
      end;					/* no need to return, as we won't be back */
      cltp = fnp (k).fnp_execp;
      call close_sw (cltp);
      tolts_info.fnp (k).exec_active = "0"b;
      return;
   end rel_exec_chan;

/* rel_tst_chan - internal procedure to release the colts test channel */

rel_tst_chan: proc (k);

dcl  k fixed bin (6);

      dmap = addr (tolts_info.colts_pages (k).dm_arg);
      tolts_info.colts_pages (k).dm_arg.version = dial_manager_arg_version_2;
      tolts_info.colts_pages (k).dm_arg.dial_qualifier = substr (colts_pages (k).cdt_name, 1, 22);
      tolts_info.colts_pages (k).dm_arg.dial_channel = tolts_info.dm_event;
      tolts_info.colts_pages (k).dm_arg.channel_name = colts_pages (k).cdt_name;
      call tolts_qttyio_$rs (0, "Do you want to return the channel ^a to service?", tolts_info.colts_pages (k).cdt_name);
reask: call tolts_qttyio_$rs (19, "Please answer yes or no - ");
      call message_wait;
      if tolts_info.mult_ans = "yes" | mult_ans = "y" then
         call dial_manager_$release_channel (dmap, code);
      else if tolts_info.mult_ans = "no" | mult_ans = "n" then
         call dial_manager_$release_channel_no_listen (dmap, code);
      else goto reask;
      if code ^= 0 then do;
         if debugging then call com_err_ (code, "mdtsim_", "Error releasing channel ^a.", dmap -> dial_manager_arg.channel_name);
         call convert_status_code_ (code, shortinfo, lginfo);
         call tolts_qttyio_$rs (0, "^as: ^a/ error doing channel detach", tolts_info.exec, lginfo);
         call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */
         fatal_desc.version = 0;
         fatal_desc.fatal_code = error;
         if debugging
	then call terminate_process_ ("fatal_error", addr (fatal_desc));
         else signal tolts_error_;
      end;					/* no need to return, as we won't be back */
      cltp = colts_pages (k).chanp;
      call close_sw (cltp);
      colts_pages (k).in_use = "0"b;
      tolts_info.exec_page_count = tolts_info.exec_page_count - 1;
      return;
   end rel_tst_chan;

/* close_sw - internal procedure to close and detatch colts io switches */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/



close_sw: proc (cltp);

dcl  cltp ptr;
      call iox_$close (cltp, code);			/* close a switch */
      if code ^= 0 then do;				/* if erroe */
         call convert_status_code_ (code, shortinfo, lginfo); /* convert the status code */
         call tolts_qttyio_$rs (0, "^as: ^a/ doing iox_$close", tolts_info.exec, lginfo); /* and notify the user */
         call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */
         fatal_desc.version = 0;
         fatal_desc.fatal_code = error;
         if ^debugging
	then call terminate_process_ ("fatal_error", addr (fatal_desc));
         else signal tolts_error_;
      end;
      call iox_$detach_iocb (cltp, code);		/* detach the io switch */
      if code ^= 0 then do;				/* if error */
         call convert_status_code_ (code, shortinfo, lginfo); /* convert the error code */
         call tolts_qttyio_$rs (0, "^as: ^a/ doing iox_$detach", tolts_info.exec, lginfo); /* notify the user */
         call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */
         fatal_desc.version = 0;
         fatal_desc.fatal_code = error;
         if ^debugging
	then call terminate_process_ ("fatal_error", addr (fatal_desc));
         else signal tolts_error_;
      end;
      return;
   end close_sw;

/* ctime - internal function to return pl1 time string */

ctime: proc returns (char (16));

dcl  tim char (12);
dcl  ptime char (16);
dcl  plen fixed bin;

      tim = time;					/* get current time */
      call ioa_$rsnnl ("^2a:^2a:^2a.^6a:", ptime, plen, substr (tim, 1, 2), substr (tim, 3, 2),
       substr (tim, 5, 2), substr (tim, 7, 6));
      return (ptime);				/* return time string */

   end ctime;
%page;

/* clean_up - entry to clean_up - our enviornment before returning to tolts command level */

clean_up: entry;

      if exec = "colt" then do;
         do k = 1 to hbound (pages, 1);
	  if colts_pages (k).in_use then call rel_tst_chan (k);
         end;
         do k = 0 to hbound (fnp, 1);
	  if fnp (k).exec_active then call rel_exec_chan (k);
         end;
      end;
      do io_sel = 1 to hbound (pages, 1);		/* deallocate all perp. devices */
         io_info_ptr = addr (pages (io_sel));
         if io_info.in_use then
	  call dealcp_sub;
      end;
      if gicmp ^= null then free gicm;
      if ticmp ^= null then free ticm;
      term = "1"b;					/* set terminate condtion */
      if tolts_info.file_attach then do;		/* if print file attached... */
         call tolts_file_util_$wdump (addr (spa.regs));
         call tolts_file_util_$close;			/* go close it out */
      end;

      if tolts_info.term_io_req_cnt ^= 0 & ^tolts_info.finish_cond /* if we are still doing io */
       & ^q_flag then
         go to blk_lbl;
      call tolts_init_$clean_up;			/* go delete our event channels and our slave segment */
      tolts_active = "0"b;				/* reset active state for epilogue handler */

      return;


/* decode_den - int procedure to decode density info returned from rcp and put into sct entry */

decode_den: proc;

      tape_info_ptr = addr (io_info.rcp_area);		/* set tape info ptr */
      if substr (tape_info.density, 1, 6) = "00"b3 then do; /* rcp returned bad density information */
ask:
         call tolts_qttyio_$rs (0, " ^a RCP returned incorrect device info ^/^a^/", io_info.test_hdr,
	"Please input density capabilities of device to be tested");
         call tolts_qttyio_$rs (19, "Please input densities in the form: 200,556,800,1600,6250 ^-");
         call message_wait;
         if tolts_info.mult_ans = "200,556,800" then
	  io_info.devsct.w2.den_cap = "0001"b;
         else if tolts_info.mult_ans = "200,556,800,1600" then
	  io_info.devsct.w2.den_cap = "0100"b;
         else if tolts_info.mult_ans = "556,800,1600" then
	  io_info.devsct.w2.den_cap = "0101"b;
         else if tolts_info.mult_ans = "556,800" then
	  io_info.devsct.w2.den_cap = "1001"b;
         else if tolts_info.mult_ans = "800,1600" then
	  io_info.devsct.w2.den_cap = "1000"b;
         else if tolts_info.mult_ans = "1600" then
	  io_info.devsct.w2.den_cap = "1100"b;
         else if tolts_info.mult_ans = "1600,6250" then
	  io_info.devsct.w2.den_cap = "1011"b;
         else if tolts_info.mult_ans = "6250" then
	  io_info.devsct.w2.den_cap = "1010"b;
         else do;
	  call tolts_qttyio_$rs (0, "Incorrect reply. ^/ ^a ^/", /* If no match we fall thru */
	   "Do you want to run with default density");
	  call tolts_qttyio_$rs (19, "Please answer yes or no");
	  call message_wait;
	  if tolts_info.mult_ans = "no" | mult_ans = "n" then goto ask; /* ask for density again */
	  else if io_info.crcst.mtp610 then do;
	     io_info.devsct.w2.den_cap = "1100"b;	/* if mtp610 set density to 1600 only */
	     call tolts_qttyio_$rs (0, "Test will be run at 1600bpi ^/");
	  end;
	  else do;
	     io_info.devsct.w2.den_cap = "1000"b;	/* else run at 500/800bpi */
	     call tolts_qttyio_$rs (0, "Test will be run at 500/1600bpi ^/");
	  end;
         end;
      end;
      else if substr (tape_info.density, 1, 6) = "70"b3 then/* 200,556 and 800 bpi */
         io_info.devsct.w2.den_cap = "0001"b;
      else if substr (tape_info.density, 1, 6) = "74"b3 then/* 200,556,800 and 1600 bpi */
         io_info.devsct.w2.den_cap = "0100"b;
      else if substr (tape_info.density, 1, 6) = "30"b3 then/* 556 and 800 bpi */
         io_info.devsct.w2.den_cap = "1001"b;
      else if substr (tape_info.density, 1, 6) = "14"b3 then/* 800 and 1600 bpi */
         io_info.devsct.w2.den_cap = "1000"b;
      else if substr (tape_info.density, 1, 6) = "04"b3 then/* 1600 bpi only */
         io_info.devsct.w2.den_cap = "1100"b;
      else if substr (tape_info.density, 1, 6) = "06"b3 then/* 1600 and 6250 bpi */
         io_info.devsct.w2.den_cap = "1011"b;
      else if substr (tape_info.density, 1, 6) = "02"b3 then/* 6250 bpi only */
         io_info.devsct.w2.den_cap = "1010"b;
      else if substr (tape_info.density, 1, 6) = "34"b3 then/* 556, 800, and 1600bpi */
         io_info.devsct.w2.den_cap = "0101"b;
   end decode_den;

/* pop_isc - subroutine to pop the inter slave read queue and return data to slave exec */

pop_isc: proc (s_add, d_add);

dcl  (s_add, d_add) fixed bin;

      exec_wd (s_add) = "400000000000"b3;		/* set status to complete */
      exec_wd (d_add) = tolts_info.exec_dta (1).word (1);	/* move isc data from queue */
      exec_wd (d_add + 1) = tolts_info.exec_dta (1).word (2);
      exec_wd (d_add + 2) = tolts_info.exec_dta (1).word (3);
      tolts_info.exec_dta_cnt = tolts_info.exec_dta_cnt - 1;/* decrement count */
      do i = 1 to tolts_info.exec_dta_cnt;
         tolts_info.exec_dta (i) = tolts_info.exec_dta (i + 1); /* move queue down */
      end;

   end pop_isc;
%page;
/* ck_release - subroutine to check to see if mpc firmware has been destoryed and reload it */

ck_release: proc;

      if io_info.io_in_progress then do;		/* if some io outstanding */
         call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* Be sure no alarm already set */
         call ipc_$drain_chn (tolts_info.gewake_event, error); /* In case event occured */
         call timer_manager_$alarm_wakeup (10, "11"b, tolts_info.gewake_event); /* Set 10 second timer */
         tolts_info.gewake_active = "1"b;		/* set flag */
         do while (tolts_info.gewake_active);		/* wait for timer to go off or interrupt */
	  call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); /* Wait for a second */
         end;

         if io_info.chan_suspended then			/* if ioi_$suspend has been called */
	  if io_info.io_type = itr_io_type
	   | io_info.io_type = firm_ld_io_type then do;	/* and itrs have been run or attempted to load fw */
retry_ld:
	     call tolts_load_firmware_ (io_sel, error);	/* go reload firmware */
	     if error ^= 0 then do;			/* some problem, ask user what to do */
	        if tolts_info.finish_cond then		/* if we don't have a terminal... */
		 go to tell_opr;			/* just tell opr bad news */
	        call tolts_qttyio_$rs (0, "^a Error loading mpc firmware.^/^a^/", io_info.test_hdr,
	         "Do you wish to retry or quit leaving mpc suspended?");
retype:
	        call tolts_qttyio_$rs (19, "Please answer retry or quit. - ");
	        call message_wait;			/* wait for users answer */
	        if tolts_info.mult_ans = "retry" then go to retry_ld; /* go retry load again */
	        else if tolts_info.mult_ans = "quit" then do;
tell_opr:
		 opr_query_info.q_sw = "0"b;
		 call ioa_$rsnnl ("^/^a ^a^/^-^a", message, i, io_info.test_hdr,
		  "Unrecoverable error loading mpc firmware.", "I/O will remain suspended");
		 call opr_query_ (addr (opr_query_info), substr (message, 1, i)); /* tell opr bad news */
	        end;
	        else go to retype;			/* user gave wrong answer */
	     end;
	  end;

	  else if io_info.io_type ^= mca_io_type then do; /* must be suspended from mdr io */
	     ioi_wksp = io_info.workspace_ptr;		/* get a ptr to our workspace */
	     unspec (wks_init) = "0"b;		/* initialize workspace to zero */
	     idcwp = addr (tolts_workspace.p_idcw);	/* set up idcw ptr */
	     idcw.code = "7"b3;			/* set in idcw type code */
	     idcw.command = "20"b3;			/* set release command */
	     idcw.chan_cmd = "40"b3;			/* special cont. command */
	     pcwa = "000000700000"b3;			/* set up phony pcw */
	     tio_off = fixed (rel (addr (tolts_workspace.p_idcw)));
	     io_info.release_chan = "1"b;		/* set flag for interrupt processor */
	     call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* Be sure no alarm already set */
	     call ipc_$drain_chn (tolts_info.gewake_event, error); /* In case event occured */
	     call timer_manager_$alarm_wakeup (10, "11"b, tolts_info.gewake_event); /* Set 10 second timer */
	     tolts_info.gewake_active = "1"b;		/* set flag */
	     if pages (io_sel).p_att then do;
	        call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error);
	        if error ^= 0 then
		 call output_status_code (error, "cleanup io connect error");
	        tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1; /* increment global IO count */
	     end;
	     do while (tolts_info.gewake_active);	/* wait for timer to go off or interrupt */
	        call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); /* Wait for a second */
	     end;
	     if io_info.io_in_progress then do;		/* if we still got timeout... */
	        call ioa_$rsnnl ("^/^a ^a^/^-^a", message, i, io_info.test_hdr,
	         "Unable to release mpc,", "manually reset and branch to reinitialize mpc");
	        opr_query_info.q_sw = "0"b;
	        call opr_query_ (addr (opr_query_info), substr (message, 1, i));
	        call ioi_$release_devices (io_info.device_index, error); /* do it now */
	     end;
	  end;
      end;
   end ck_release;

/* message_wait - subroutine to wait for terminal message to complete */

message_wait: proc;

      do while (tolts_info.term_io_req_cnt > 0);		/* wait for all terminal io to complete */
         call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error);
      end;

   end message_wait;
%page;

/* set_gelbar - int procedure to set up information to enter gelbar mode */

set_gelbar: proc;

dcl  fwd bit (36);

dcl  1 acc_over based (addr (fwd)) aligned,		/* overlay of acc fault status */
       (2 bar bit (18),				/* BAR value from last mme gelbar */
       2 nu1 bit (1),
       2 fault bit (1),				/* "1"b = fault occurred */
       2 nu2 bit (1),
       2 overflow bit (1),				/* "1"b = fixed point overflow */
       2 ex_over bit (1),				/* "1"b = exponent overflow */
       2 ex_under bit (1),				/* "1"b = exponent underflow */
       2 ipr bit (1),				/* "1"b = eis data ipr fault */
       2 nu3 bit (4),
       2 dcf bit (1),				/* "1"b = divide check fault */
       2 f_type fixed bin (5)) unaligned;		/* fault type, (refer to gcos manual DD19) */

      fwd = "0"b;					/* reset all bits */
      acc_over.fault = "1"b;				/* valid gelbar fault,set the fault bit */
      acc_over.bar = substr (spa.acc_fault, 1, 18);	/* pick up the current bar setting */
      spa.acc_fault = fwd;				/* store accumlated ault status */
      spa.enter.lbar.bar = "000630"b3;			/* reset bar to 0 lal */
      spa.enter.icivlu.ic = rel (addr (spa.glbflt));	/* set ic to return to gelbar fault vector */
      call tolts_init_$gc_tod (gcos_tod);		/* get current time of day */
      spa.glbtmr = bit (fixed (gcos_tod, 35, 0) - fixed (string (spa.glbici), 35, 0), 36); /* delta time */
      spa.glbici.ic = bit (bin (scu.ilc, 17) + 1, 18);	/* store current ic + 1 */
      spa.glbici.ind = string (scu.ir);			/* and indicators */
      gelbar, in_ccc = "0"b;				/* reset gelbar mode, and in ccc  */
      glb_brk = "1"b;				/* and set gelbar break ind */
      call wake_disp;				/* go wake up dispatcher */

   end set_gelbar;



%page;
%include author_dcl;
%page;
%include cdt;
%page;
%include condition_info;
%page;
%include config_iom_card;
%page;
%include event_wait_info;
%page;
%include gload_data;
%page;
%include mc;
%page;
%include mca_data;
%page;
%include mca_data_area;
%page;
%include opr_query_info;
%page;
%include rcp_disk_info;
%page;
%include rcp_resource_types;
%page;
%include rcp_tape_info;
%page;
%include tolts_err_codes;
%page;
%include tolts_fpinfo;
%page;
%include tolts_info;
%page;
%include tolts_rspd_workspace;
%page;
%include tolts_workspace;





   end mtdsim_;





		    opr_query_.pl1                  12/09/86  1539.4rew 12/09/86  1521.7       57978



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* Initial coding by J. A. Bush 10/78.
   Modified 09/80 to clarify the operator reply expected. - R. Fakoury
   Modified 12/80 to use set_lock_ primitives  - P. B. Kelley
   Modified 03/83 by Rick Fakoury to restructure the operator message format.
   Modified 11/83 to correct a bug.
   Modified 1985-03-08, BIM: phcs_ --> tandd_
*/




/****^  HISTORY COMMENTS:
  1) change(86-08-21,Fakoury), approve(86-08-21,MCR7514),
     audit(86-11-24,Martinson), install(86-12-04,MR12.0-1235):
     to correct the alignment of the operator messages.
                                                   END HISTORY COMMENTS */




/* opr_query_ - subroutine to send message to the system operator and wait for his response */


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
opr_query_: proc (oqip);


dcl  oqip ptr;					/* ptr to opr_query_ info structure */
dcl  tandd_$ring_0_message entry (char (*));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1),
      fixed bin (2), ptr, fixed bin (35));
dcl  ipc_$block entry (ptr, 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  get_process_id_ entry returns (bit (36) aligned);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_count entry returns (fixed bin);
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned);
dcl  set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  set_lock_$unlock entry (bit (36) aligned, fixed bin (35));
dcl  (com_err_, ioa_$rsnnl) entry options (variable);
dcl  (error_table_$invalid_lock_reset, error_table_$locked_by_this_process) ext static fixed bin (35);

dcl  1 oq_info like opr_query_info based (oqip) aligned;

dcl  1 event_info aligned,
       2 cid fixed bin (71),
       2 message fixed bin (71),
       2 sender bit (36),
       2 origin,
         3 dev_signal bit (18) unaligned,
         3 ring bit (18) unaligned,
       2 cx fixed bin;

dcl  argp ptr;
dcl  code fixed bin (35);
dcl  mess char (80);
dcl  len fixed bin;
dcl  (addr, null) builtin;
dcl  cleanup condition;
dcl  sc_dir char (168) static options (constant) init
      (">system_control_1");

      on cleanup go to unlock;			/* unconditionaly unlock lock on cleanup condition */
      if oq_info.q_sw then do;			/* if user wants answer from operator */
         if oqdp = null then do;			/* if first reference in our process */
	  call hcs_$initiate (sc_dir, "opr_query_data", "", 0, 1, oqdp, code); /* initiate opr_query_data segment */
	  if oqdp = null then do;			/* if we can't initiate, tell user */
	     call com_err_ (code, "opr_query_", "attempting to initiate ^a>opr_query_data", sc_dir);
	     oq_info.err_code = code;			/* return error code to user */
	     return;
	  end;
         end;
         call set_lock_$lock (opr_query_data.lock_id, 60, code); /* set lock */
         if code = error_table_$invalid_lock_reset
	then call com_err_ (code, "opr_query_", "^/(referencing ^a>opr_query_data)", sc_dir);
         else if code = error_table_$locked_by_this_process
	then call com_err_ (code, "opr_query_", "^/The lock will remain set by this process.");
         else if code ^= 0 then do;
	  call com_err_ (code, "opr_query_", "^/The lock cannot be set by this process.");
	  oq_info.err_code = code;			/* indicate error to caller */
	  return;
         end;
         opr_query_data.process_id = get_process_id_ ();	/* fill in user's process id */

         call ipc_$create_ev_chn (opr_query_data.event_chan, code); /* create an event chan, for oprs response */
         if code ^= 0 then do;			/* some error */
	  call com_err_ (code, "opr_query_", "attempting to create event wait channel");
	  oq_info.err_code = code;			/* copy error code for caller */
	  go to unlock;				/* and go unlock lock */
         end;
         opr_query_data.nchan = 1;			/* set number of ipc channels to 1 */
         opr_query_data.answer = "";			/* set up the rest of the opr_query data structure */
         opr_query_data.prim = oq_info.prim;
         opr_query_data.alt = oq_info.alt;
         opr_query_data.q_sw = oq_info.q_sw;
         opr_query_data.r_comment = oq_info.r_comment;
      end;
      call cu_$arg_list_ptr (argp);			/* get ptr to our argument list */
      if cu_$arg_count () > 1 then do;			/* if message is to output to opr */
         call ioa_$general_rs (argp, 2, 3, mess, len, "0"b, "0"b); /* format message */
         if len > 80 then len = 80;			/* max length is 80 chars */
         call tandd_$ring_0_message (substr (mess, 1, len));/* and output to operator */
      end;
      if oq_info.q_sw then do;			/* if waiting for operator response */
         call ioa_$rsnnl (" ^[ ^a^;^s ^/ ^] ^[ ^/^3-respond: x oqr ^a^;^s^]^[ ^/^3-^5xor: x oqr ^a^;^s ^] ", mess, len,
	(oq_info.r_comment ^= ""), oq_info.r_comment, (oq_info.prim ^= ""), oq_info.prim, (oq_info.alt ^= ""),
	oq_info.alt);
         if len > 80 then len = 80;
         call tandd_$ring_0_message (substr (mess, 1, len));/* output expected response */
         call ipc_$block (addr (opr_query_data.wait_list), addr (event_info), code); /* wait */
         if code ^= 0 then do;			/* if some error */
	  call com_err_ (code, "opr_query_", "while blocked");
	  oq_info.err_code = code;			/* copy error code for caller */
         end;
         else oq_info.answer = opr_query_data.answer;	/* copy operators answer */
         call ipc_$delete_ev_chn (opr_query_data.event_chan, code);
unlock:
         call set_lock_$unlock (opr_query_data.lock_id, code); /* unlock our lock	*/
         if code ^= 0
	then call com_err_ (code, "opr_query_", "Attempting to unlock the opr_query_data lock.");

      end;
      oq_info.err_code = 0;				/* reset error code, and return */

%include opr_query_data;
%include opr_query_info;

   end opr_query_;




		    opr_query_response.pl1          12/05/86  0937.4r   12/05/86  0902.6       34173



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* format: style4 */
opr_query_response: proc;

/* opr_query_response - operator command interface to respond to an opr_query_ request */
/* initial coding by J. A. Bush 10/78.
   Modified 03/83 by Rick Fakoury to allow the operator to send a message in  responce to a question.
   Modified 08/83 by Rick Fakoury to correct an oversight.
*/

dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1),
	fixed bin (2), ptr, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);

dcl  arg char (al) based (ap);
dcl  (al, arg_cnt, i) fixed bin;
dcl  ap ptr;
dcl  msg char (80) varying init ("");
dcl  code fixed bin (35);
dcl  error_table_$wrong_no_of_args fixed bin (35) ext;
dcl  null builtin;
dcl  pname char (18) static options (constant) init ("opr_query_response");
dcl  sc_dir char (168) static options (constant) init
	(">system_control_1");


	msg = "";
	call cu_$arg_count (arg_cnt, code);
	do i = 1 to arg_cnt;
	     call cu_$arg_ptr (i, ap, al, code);	/* get the operators response */
	     if code ^= 0 then do;			/* some error, tell opr about it */
		call com_err_ (error_table_$wrong_no_of_args, pname, /* so tell him */
		     "Usage: ^a answer", pname);
		return;
	     end;
	     msg = msg || " " || arg;
	end;

	if oqdp = null then do;			/* if first reference in our process */
	     call hcs_$initiate (sc_dir, "opr_query_data", "", 0, 1, oqdp, code); /* initiate opr_query_data segment */
	     if oqdp = null then do;			/* if we can't initiate, tell user */
		call com_err_ (code, pname, "attempting to initiate ^a>opr_query_data", sc_dir);
		return;
	     end;
	end;
	if opr_query_data.lock_id = "0"b then do;	/* no response pending */
	     call com_err_ (0, pname, "No operator response pending");
	     return;
	end;
	if arg = opr_query_data.prim | arg = opr_query_data.alt then do; /* if valid response */
	     opr_query_data.answer = arg;		/* save answer and wakeup requesting process */
	     call hcs_$wakeup (opr_query_data.process_id, opr_query_data.event_chan, 0, code);
	     if code ^= 0 then do;			/* error on wakeup */
		call com_err_ (code, pname, "attempting to issue wakeup to process id ^12.3b",
		     opr_query_data.lock_id);
		return;
	     end;
	end;
	else if opr_query_data.q_sw then do;
	     opr_query_data.answer = msg;		/* save answer and wakeup requesting process */
	     call hcs_$wakeup (opr_query_data.process_id, opr_query_data.event_chan, 0, code);
	     if code ^= 0 then do;			/* error on wakeup */
		call com_err_ (code, pname, "attempting to issue wakeup to process id ^12.3b",
		     opr_query_data.lock_id);
		return;
	     end;
	end;
	else do;					/* if invalid response */
	     call com_err_ (0, pname, " ^[ ^a ^/ ^] ^[ respond: x oqr ^a^]^[ ^/^-^-^-or: x oqr ^a ^] ",
		(opr_query_data.r_comment ^= ""), opr_query_data.r_comment, (opr_query_data.prim ^= ""), opr_query_data.prim,
		(opr_query_data.alt ^= ""), opr_query_data.alt);
	     return;				/* tell opr what is expected and return */
	end;

%include opr_query_data;

     end opr_query_response;




		    tolts_.pl1                      12/09/86  1539.4rew 12/09/86  1521.8       61083



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* Rewritten 6/78 by J. A. Bush to conform to Multics programming standards
   Modified 79/02/08 by J. A. Bush to call the Multics T & D Slave Interface
   Module (mtdsim_) for Molts and Polts
   Modified 80/02/06 by J. A. Bush to handle the sus_ condition
   Modified 80/12/08 by R. E. Fakoury to handle a colts request.
   Modified 03/83 by Rick Fakoury to change the msg1 to msg and to call tolts_util_$opr_msg. Also added a
   check for user access to system data_bases and gates.
   Modified 10/83 to use access_mode_values.incl as recommended by the auditor.
   Modified 01/84 by R Fakoury to support new tolts debugger call.
   Modified 01/85 by R Fakoury to change the check for tandd.acs.
*/






/****^  HISTORY COMMENTS:
  1) change(85-10-21,Fakoury), approve(86-08-21,MCR7514),
     audit(86-12-01,Martinson), install(86-12-09,MR12.0-1235):
     to check for user access to mca gate & system mca data segs.
                                                   END HISTORY COMMENTS */





/* tolts_ - this is the TOLTS executive that controls execution of POLTS, MOLTS, COLTS, and ISOLTS */


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
tolts_: proc;

/* AUTOMATIC */

dcl  c_args (32) char (28) varying;
dcl  c_len fixed bin;
dcl  cardp ptr init (null);
dcl  code fixed bin (35);
dcl  com_string char (132) aligned;
dcl  cmd_cnt fixed bin;
dcl  entry_var entry variable;
dcl  tandd_ok bit (1);
dcl  term bit (1);
dcl  ttl_date char (6);
dcl  user_access fixed bin (5);


/*  BUILTINS */

dcl  null builtin;

/*  CONDITIONS */

dcl  linkage_error condition;


/*  CONSTANTS */

dcl  current_ring fixed bin int static options (constant) init (-1);
dcl  no_error_expected fixed bin (35) int static options (constant) init (0);
dcl  pname char (6) static options (constant) init ("tolts_");
dcl  ring_1 fixed bin int static options (constant) init (1);
dcl  sl_dir char (4) int static options (constant) init (">sl1");
dcl  sc_admin_dir char (14) int static options (constant) init (">sc1>admin_acs");
dcl  sc_dir char (4) int static options (constant) init (">sc1");


/* ENTRIES */

dcl  com_err_ entry () options (variable);
dcl  hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  isolts_ entry;
dcl  mca_$attach_mca entry;
dcl  mtdsim_ entry options (variable);
dcl  no_save_on_disconnect entry;
dcl  save_on_disconnect entry;
dcl  tandd_$ring_0_message entry;
dcl  tolts_util_$get_ttl_date entry (entry, char (6));
dcl  tolts_util_$on_off entry (char (6), char (3), char (6));
dcl  tolts_util_$opr_msg entry;
dcl  tolts_util_$query entry (char (*), char (132) aligned, fixed bin, (32) char (28) varying, fixed bin);


/* EXTERNAL */

dcl  error_table_$moderr fixed bin (35) ext static;
dcl  error_table_$noentry fixed bin (35) ext static;


%page;


      call no_save_on_disconnect;			/* do not want process saved on terminal disconnect */
      call tolts_util_$get_ttl_date (tolts_, ttl_date);
      call tolts_util_$on_off ("tolts", "on", ttl_date);	/* signon */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
/*											*/
/* Verify user access to system data and system gates.						*/
/*											*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


      call check_access (sc_dir, "opr_query_data",
       RW_ACCESS_BIN, no_error_expected, current_ring);

      call check_access (sc_admin_dir, "tandd.acs",
       RW_ACCESS_BIN, no_error_expected, current_ring);

      call check_access (sc_dir, "cdt",
       R_ACCESS_BIN, no_error_expected, current_ring);

      call check_access (sl_dir, "mca_data_seg",
       RW_ACCESS_BIN, error_table_$noentry, ring_1);


      on linkage_error begin;
         call com_err_ (error_table_$moderr, pname, "^[mca_^;tandd_^]", tandd_ok);
         goto t_off;				/* exit */
      end;

      tandd_ok = "0"b;
      entry_var = tandd_$ring_0_message;
      tandd_ok = "1"b;
      entry_var = mca_$attach_mca;
      revert linkage_error;


%page;


/* Now loop until user quits */

      term = "0"b;					/* reset terminate condition */
      do while (^term);
         call ioa_ (" ^/***enter ""polts"", ""molts"", ""colts"", ""isolts"", ""quit"", or ""msg""");
         call tolts_util_$query ("??? ", com_string, c_len, c_args, cmd_cnt);

/* Now see what user wants to do */

         if c_args (1) = "quit"
	| c_args (1) = "q" then			/* user wants to quit */
	  term = "1"b;
         else if c_args (1) = "polts" then		/* user wants to run polts */
	  call mtdsim_ ("polt");
         else if c_args (1) = "molts" then		/* user wants to run molts */
	  call mtdsim_ ("molt");
         else if c_args (1) = "colts" then		/* user wants to run colts */
	  call mtdsim_ ("colt");
         else if c_args (1) = "isolts" then		/* user wants to run isolts */
	  call isolts_;
         else if c_args (1) = "msg" then		/* user wants to send message to operator */
	  call tolts_util_$opr_msg;
         else call ioa_ ("^/invalid response - ^a", com_string);
      end;

/* User is all done, output Tolts wrap up message */

t_off: call tolts_util_$on_off ("tolts", "off", ttl_date);	/* signoff */
      call save_on_disconnect;			/* restore users save on disconnect state */

      return;

%page;

/* check_access - int proc that will check the user's access to system gates & data bases */

check_access: proc (dir, entry, lowest_access, error_expected, ring);

dcl  error_expected fixed bin (35);
dcl  dir char (*);
dcl  entry char (*);
dcl  lowest_access fixed bin (5);
dcl  ring fixed bin;

      call hcs_$get_user_effmode (dir, entry, "", ring, user_access, code);
      if code ^= 0 then do;
         if code = error_expected then return;
         call com_err_ (code, pname, "attemping to get user access to ^a>^a.",
	dir, entry);
         go to t_off;				/* exit */
      end;

      if user_access >= lowest_access then return;

      call com_err_ (error_table_$moderr, pname, "^a>^a", dir, entry);
      goto t_off;					/* exit */

   end check_access;

%page;

%include access_mode_values;


   end tolts_;					/* thats it */




		    tolts_alm_util_.alm             12/05/86  0937.4r w 12/05/86  0900.5       52605



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
" Modified by R. Fakoury 8102 to cumpute an icm checksum for colts. 
"
"  The entry point, ascii_to_bcd_, takes a character string
"  as input and produces a bit string of length divide (length (output),6,24)
"  as output. If the output string has more bcd char positions
"  than there are input chars to convert, then the output is blank filled.
"
"  PL/1 Usage:
"
"  dcl tolts_alm_util_$ascii_to_bcd_ entry (char (*), bit (*));
"  call tolts_alm_util_$ascii_to_bcd_ (input_chars, output_bits);
"
"  The entry point, ascii_to_bci_ is the same as ascii_to_bcd_ except
"  that the output string is zero filled.

"  PL/1 Usage:
"
"  dcl tolts_alm_util_$ascii_to_bci_ entry (char (*), bit (*));
"  call tolts_alm_util_$ascii_to_bci_ (input_chars, output_bits);
"
"
"  The entry point enter_slave_ is used to do a transfer into a gcos type object.
"  The single entry argument is a pointer to the desired entry address into the gcos object.
"  By convention this entry point is a 3 word program located in the slave prefix area,
"  at offset  32 (octal). This 3 word program contains:
"  
"  	lreg	<regs>		load safe stored registers
"  	lbar	<bar>,du		load desired base address setting
"  	ret	<saved_ic_and_i>	return to desired ic and i value
"  
"  The enter_slave_ entry merely does an indirect TRA instruction into this entry program.
"  The RET instruction will put the processor in slave mode and returns to the saved IC value
"  that is relative to the loaded BAR.
"
"
"  The entry point gen_ck_sum computes an icm cksum for colts icm's
"	   pl/1 usage:
"  dcl tolts_alm_util_$gen_ck_sum entry (ptr);
"  call tolts_alm_util_$gen_ck_sum entry (icm ptr);
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

	name	tolts_alm_util_
	entry	ascii_to_bcd_
	entry	ascii_to_bci_
	entry	enter_slave_
	entry	enter_ccc_req_
	entry	gen_ck_sum
	temp	temp

gen_ck_sum: 			"generate icm cksum
	epp1	ap|2,*		get ptr to icm
	ldx6	pr1|0,*		get the number of words
	ldx5	1,du		set word index
	ldx4	1,du
	lda	pr1|0,*5		load first word
	ana	-1,dl		exclude cksum bits
	sta	pr1|0,*4		store in cksum word
ck_sum2:
	adlx5	1,du		inc index
	sblx6	1,du		decrement wrod count
	tze	ck_sum3		tally exhausted
	lda	pr1|0,*5		load next word
	ersa	pr1|0,*4		include in checksum
	tra	ck_sum2		loop
ck_sum3:
	lda	pr1|0,*4
	als	18		reduce to 18 bits
	era	pr1|0,*4		store in checksum
	ana	-1,du
	sta	pr1|0,*4
	short_return

ascii_to_bcd_:			" ascii to bcd entry
	ldx5	1,du		set bcd indicator
	tra	*+2

ascii_to_bci_:			" ascii to bci entry
	ldx5	2,du		set bci indicator
	epp1	ap|2,*		address of source string to pr1
	epp3	ap|4,*		address of target string to pr3
	ldx3	0,du		set x3 not to skip parent pointer if none
	lxl2	ap|0		load arg list code value
	canx2	=o0000004,du	check for no parent pointer (code 4)
	tnz	*+2		transfer if no parent pointer
	ldx3	2,du		parent pointer, set x3 to skip it
	ldq	ap|8,x3*		load target string descriptor
	anq	mask		drop all but string size  bits
	div	6,dl		get length of target in BCD characters
	lda	ap|6,x3*		load source string descriptor
	ana	mask		drop all but string size bits
	cmpx5	2,du		test for bci conversion
	tze	cv_bci		tra if bci convert
	even			"EIS address must be even
	mvt	(pr,rl),(pr,rl),fill(040)	now do the ascii to bcd
	desc9a	1|0,al
	desc6a	3|0,ql
	arg	atb_tab
	short_return

	even			"EIS address must be even
cv_bci:
	mvt	(pr,rl),(pr,rl),fill(060)	now do the ascii to bci
	desc9a	1|0,al
	desc6a	3|0,ql
	arg	atb_tab
	short_return

	inhibit	on
enter_ccc_req_:
	push
"
"	pl1 definition of courtesy call queue:
"
"	dcl 1 ccc_queue,
"	    2 ccc_requests fixed bin,	/* number of courtesy call requests outstanding */
"	    2 icivlu (16) bit (36),	/* outstanding ic values (ind value is always 0) */
"
	eppbp	ap|2,*		get ptr to ccc queue
	eppbp	bp|0,*
	lda	bp|0		get ccc request count, current
	adla	1,dl		increment by 1
	sta	bp|0		store updated count
	ldq	ap|4,*		get  ic value to store
	stq	bp|0,al		store in correct queue entry
	anq	777777,du		save only ic value
	return

enter_slave_:
	push
	sprisp	sb|stack_header.bar_mode_sp save sp so signaller can reset
"				 it in case gcos uses adr6
	eppbp	ap|2,*		get the entry ptr
	eppbp	bp|0,*		..
	stz	sp|stack_frame.entry_ptr  make stack traces look nice
	stz	sp|stack_frame.entry_ptr+1
	tra	bp|0		transfer directly into to the entry program

	inhibit	off

mask:	oct	000077777777
	even
atb_tab:
" ascii chars 000 - 037 (8) - invalid bcd chars set to bcd "?" (ignore char)
	oct	017017017017,017017017017,017017017017,017017017017
	oct	017017017017,017017017017,017017017017,017017017017
" ascii chars 040 - 057 (8) = " !"#$%&'()*+,-./"
	oct	020077076013,053074032057,035055054060,073052033061
" ascii chars 060 - 077 (8) = "0123456789:semicolon<=>?"
	oct	000001002003,004005006007,010011015056,036075016017
" ascii chars 100 - 117 (8) = "@ABCDEFGHIJKLMNO"
	oct	014021022023,024025026027,030031041042,043044045046
" ascii chars 120 - 137 (8) = "PQRSTUVWXYZ[\]^_"
	oct	047050051062,063064065066,067070071012,037034040072
" ascii chars 140 - 157 (8) = "`abcdefghijklmno"
	oct	017021022023,024025026027,030031041042,043044045046
" ascii chars 160 - 177 (8) = "pqrstuvwxyz{|}~PAD"
	oct	047050051062,063064065066,067070071012,040034017017


	include	stack_header
	include	stack_frame
	end




		    tolts_alrm_util_.pl1            12/09/86  1539.4r w 12/09/86  1522.7       23058



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* format: style4 */
tolts_alrm_util_: proc;

/* tolts_alrm_util_ - a group of entries that are called by asyncronous timers  */

/* coded by J. A. Bush 2/3/79 */

dcl  tolts_qttyio_ entry (char (*), fixed bin);
dcl  hcs_$wakeup entry (bit (36) aligned,
	fixed bin (71), ptr, fixed bin (35));		/* arg 3 is suppose to be fixed bin (71) */
dcl  terminate_process_ entry (char (*), ptr);
dcl  com_err_ entry options (variable);

dcl  1 fatal_desc aligned,
       2 version fixed bin,
       2 fatal_code fixed bin (35);

dcl  error fixed bin (35);
dcl  null builtin;

quit: entry;

/* this entry is called by the tolts_quith event call channel when we are in a blocked state. It is
   used to syncronys the quit signal caused by a terminal break or interrupt key being depressed
   by the user */

	if tolts_info.exec_term_io_wait | tolts_info.term_io_in_prog then
	     tolts_info.optflag = tolts_info.optflag + 1; /* increment options request flag */
	else do;					/* no terminal io in prog, queue up exec read */
	     tolts_info.optflag = 0;			/* reset options request flag */
	     call tolts_qttyio_ ("???", 9);		/* issue exec read */
	end;
	return;

gewake: entry;

/* this entry is called by the gewake event channel when the asyncronous gewake alarm timer goes off
   It is used to wakeup the dispatcher after a specified time period has elapsed, if an io interrupt has
   not ocurred in the meantime. If an io interrupt has occurred, the alrarm timer will be reset
   in the interrupt processor */

	tolts_info.gewake_active = "0"b;		/* reset alarm flag */
	call hcs_$wakeup (tolts_info.process, tolts_info.wait_list.wait_event_id (1), null, error);
	if error ^= 0 then do;			/* if error on wakeup, terminate process */
	     call com_err_ (error, "tolts_alrm_util_", "fatal error, terminating process");
	     fatal_desc.version = 0;
	     fatal_desc.fatal_code = error;		/* copy error code */
	     call terminate_process_ ("fatal_error", addr (fatal_desc));
	end;
	return;					/* thats it */

%include tolts_info;

     end tolts_alrm_util_;




		    tolts_device_info_.pl1          12/09/86  1539.4rew 12/09/86  1520.9      359523



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* original coding by J. A. Bush 79/02/13.
   Modified by Michael R. Jordan 79/10/09 for new MPC card format.
   Modified by G. Haney & R. Fakoury 80/13/24 to set up secondary sct, rcp for alternate device.
   Modified by R. Fakoury 08/80 include 501 config card and to examine the entire chan config card
   Modified by R. Fakoury 09/80 to remove rcp_ area initialization.
   Modified by R.Fakoury 11/80 to allow mtar to run on 400 type devices
   Modified by R.Fakoury 12/80 to fix bug in chnl card interrupter.
   Modified by R.Fakoury 04/80 & 05/80 to fix a bug in the mpc card interrupter.
   Modified by M.R. Jordan 7/81 for changes in PRPH OPC card format.
   Modified by R. Fakoury 04/82 to add pr54 support and fix ccu bug.
   Modified by C. Horning 08/82 to support new tape config card.
   Modified by R. Fakoury 09/82 to allow booting the eurc from a non-lo order chan.
   Modified by R. Fakoury 11/82 to correct eurc problems and allow cp120 & 121 devices,
   allow mtg, mtc & mdc test request & 128 chan support.
   Modified by R. Fakoury 05/83 to allow mdr testing from non logical 0 chans.
   Modified by R. Fakoury 06/09/83 to corect a mpc attachment problem and answer TRs' 13296, 14742, 15343.
   Modified by R. Fakoury 06/15/83 to correct a problem caused by the changes made for the new tape prph card.
   Modified by R. Fakoury 08/19/83 to support the new opc config card and correct 128chan support bug.
   Modified by R. Fakoury 11/83 to support hyperchannel.
   Modified by R Fakoury 11/83 to make more corrections to support the tape config card.
   Modified by R Fakoury  12/83 to put back a conditional check for a com prph prior to checking for an mpc card.
   Also added changes to remove the restriction on running itrs on non-logical zero channels.
   Modified by R. Fakoury 01/84 to close a hole in an mpc601 and mth610 possible configuration.
   Modified by R Fakoury 04/84 to support the DAU.
   Modified by R Fakoury 10/84 to correct an extranous check to compare an mpc card to a mpc device string.
   Modified by R. Fakoury 10/84 to utilize the system prph card incls.
   Modified by R Fakoury 2/85 to fix a hyperchannel bug.
   Modified by R Fakoury 4/26 to fix a dau bug.
*/


/****^  HISTORY COMMENTS:
  1) change(86-06-04,Hartogs), approve(86-06-04,MCR7383),
     audit(86-06-05,Coppola), install(86-07-18,MR12.0-1098):
     Changed to use version constant in rcp_device_info.incl.pl1.
  2) change(86-08-21,Fakoury), approve(86-08-21,MCR7514),
     audit(86-12-01,Martinson), install(86-12-04,MR12.0-1235):
     to correct an error in attaching the mpc for disk and tape mdrs.
     to correct an extranous check to compare to a mpc device string.
     to utilize the system prph card incls.
     to support Dipper FIPS tape & disk
     to implement test nio request.
     to implement responder test request.
                                                   END HISTORY COMMENTS */


/* tolts_device_info_ - procedure to find a prph by IOM, channel and device and return info.


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
tolts_device_info_: proc (icdtp, px, type_error);


/* Entry parameters */

dcl  icdtp ptr;					/* ptr to iom, chan, & device info (see icdt structure below) */
dcl  px fixed bin;					/* test page index */
dcl  type_error fixed bin;				/* error code (returned) */

/* Automatic */


dcl  (IOM, CHAN, device2, device, di, MODEL, NDRIVES, i, k) fixed bin;
dcl  model_index fixed bin;
dcl  code fixed bin (35);
dcl  rs_mode fixed bin (5);
dcl  (spec_chan, term, term1, trm, urcitr) bit (1) init ("0"b);
dcl  rcpsp ptr;
dcl  (dname, altname) char (8);
dcl  mdr_cat char (5);
dcl  xregp ptr;
dcl  cont_cardp ptr;



/* Structures and based variables */

dcl  xreg3 bit (36) based (xregp);
dcl  1 cont_card aligned based (cont_cardp) like mpc_card;
dcl  1 icdt based (icdtp) aligned,			/* structure defining input  parameters */
       (2 ficcdd bit (18),				/* iom, chan and device */
       2 tt bit (6),				/* test type: 0 = polt, C = ITRs,  R = MDRs, T = MTAR */
       2 u_opt bit (6),				/* if = bcd "U", then set disk/tape to "T&D_Volume" */
       2 pad1 bit (6)) unaligned;


/* Static, builtins, and external entries */

dcl  ioa_$rsnnl entry options (variable);
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
dcl  tolts_util_$dev0_valid entry (ptr, fixed bin) returns (bit (1));
dcl  tolts_util_$find_card entry (char (4), ptr);

dcl  one_sec fixed bin (35) int static options (constant) init (1000000); /* in micro sec */
dcl  one_min fixed bin (35) int static options (constant) init (60000000); /* in micro sec */
dcl  five_min fixed bin (35) int static options (constant) init (300000000); /* in micro sec */
dcl  execute bit (5) int static options (constant) init ("00100"b);

dcl  tags (1:8) char (1) static options (constant) init
      ("a", "b", "c", "d", "e", "f", "g", "h");

dcl  (addr, addrel, bin, bit, fixed, hbound, mod, null, substr, unspec) builtin;


%page;


      if icdt.tt ^= "0"b & icdt.tt ^= "22"b3 & icdt.tt ^= "23"b3
       & icdt.tt ^= "24"b3 & icdt.tt ^= "25"b3 & icdt.tt ^= "30"b3
       & icdt.tt ^= "41"b3 & icdt.tt ^= "45"b3 & icdt.tt ^= "51"b3
       & icdt.tt ^= "63"b3 & icdt.tt ^= "71"b3 then goto t_err23; /* if invalid test type - set error */
      io_info_ptr = addr (pages (px));			/* get ptr to our page entry */
      unspec (io_info.devsct) = "0"b;			/* initilize device sct */
      io_info.cat_name, io_info.device_name = "";
      type_error = 0;				/* reset return error code */
      if icdt.tt = "71"b3 then do;
         prph_cardp = null;
         term = "0"b;
         do while (^term);
	  call tolts_util_$find_card ("prph", prph_cardp);
	  if prph_cardp = null then goto t_err0;
	  else if prph_card.name = "dia" || tags (io_info.fnp_num + 1) then do;
	     term = "1"b;
	     dname = prph_card.name;
	     IOM = prph_card.iom;
	     CHAN = prph_card.chan;
	     goto c_info;
	  end;
         end;
      end;
      else if substr (icdt.ficcdd, 4, 1) then do;		/* if new format */
         io_info.nff = "1"b;				/* set new format flag */
         xregp = addrel (execp, 33);			/* get ptr to chan number */
         CHAN = fixed (substr (xreg3, 28, 9));		/* save channel number */
         io_info.devsct.icc = "0"b || substr (icdt.ficcdd, 5, 2) /* save icc in devsct */
	|| substr (xreg3, 29, 8);
         IOM = fixed (substr (icdt.ficcdd, 5, 2));	/* set iom number */
      end;
      else do;					/* else old format */
         io_info.nff = "0"b;				/* not new format */
         substr (io_info.devsct.icc, 1, 9) = substr (icdt.ficcdd, 4, 9); /* save iom and channel */
         CHAN = fixed (substr (icdt.ficcdd, 7, 6));	/* and channel number */
         IOM = fixed (substr (icdt.ficcdd, 4, 3));	/* set iom number */
      end;
      device = fixed (substr (icdt.ficcdd, 13, 6));	/* and device number */
      io_info.devsct.device_no = substr (icdt.ficcdd, 13, 6); /* set device number in device sct */

/* first validate IOM number */

      chnl_cardp, iom_cardp, mpc_cardp = null;
      term = "0"b;					/* reset terminate condition */
      do while (^term);				/* find all iom cards */
         call tolts_util_$find_card ("iom ", iom_cardp);	/* find iom card */
         if iom_cardp = null then			/* didn't find iom card, get out of loop */
	  goto t_err0;				/* error, invalid IOM number */
         else if tag - 1 = IOM then do;			/* found right card */
	  if iom_card.state ^= "on " then goto t_err1;
	  if iom_card.model = "imu " then io_info.sct_info.ioc_type = "0001"b;
	  term = "1"b;
         end;
      end;
      if CHAN = 3 then do;
         if iom_card.model ^= "imu" then goto t_err23;
         else dname = "mca" || tags (iom_card.tag);
         goto c_info;
      end;
%page;

/* now validate channel with iom */

      prph_cardp = null;				/* reset prph_cardp to start at beginning of deck */
      term = "0"b;					/* reset terminate condition */
      do while (^term);				/* go thru prph cards to find chan, and iom */
         call tolts_util_$find_card ("prph", prph_cardp);	/* find next config card */
         if prph_cardp = null then term = "1"b;		/* if last card in deck passed */
         else do;
	  if prph_card.iom - 1 = IOM then		/* found iom number */
	     if prph_card.chan = CHAN then		/* and channel */
	        term = "1"b;			/* set terminate condition */
	     else if substr (prph_card.name, 1, 3) = "dsk" then do; /* if disk */
	        prph_dsk_cardp = prph_cardp;
	        if CHAN >= prph_dsk_card.chan
	         & CHAN < prph_dsk_card.chan + prph_dsk_card.nchan then
		 term = "1"b;			/* special case for disks */
	     end;
	     else if substr (prph_card.name, 1, 3) = "tap" then do; /* if tape */
	        prph_tap_cardp = prph_cardp;
	        if CHAN >= prph_tap_card.chan
	         & CHAN < prph_tap_card.chan + prph_tap_card.nchan then
		 term = "1"b;			/* special case for tapes */
	     end;
         end;
      end;
      term = "0"b;					/* reset terminate condition */
      if prph_cardp = null then do;
         do while (^term);				/* look at chanl cards */
	  call tolts_util_$find_card ("chnl", chnl_cardp);
	  if chnl_cardp = null then			/* if last card in deck passed */
	     goto t_err1;				/* channel not assignable */
	  else do i = 1 to 3 while (chnl_card.group (i).iom ^= -1 & ^term);
	     if IOM = chnl_card.group (i).iom - 1 then do;
	        if CHAN >= chnl_card.group (i).chan	/* found chan in range */
	         & CHAN <= (chnl_card.group (i).chan + chnl_card.group (i).nchan - 1) then do;
		 term = "1"b;
		 prph_cardp = chnl_cardp;
		 altname, dname = chnl_card.name;
	        end;
	     end;
	  end;
         end;

         if prph_cardp ^= null
	& icdt.tt = "51"b3 & ^io_info.p2_att then	/* if first attach request & mdr */
	  if substr (dname, 1, 3) = "tap" |		/* if tape or disk */
	   substr (dname, 1, 3) = "dsk" then do;
	     term = "0"b;				/* reset terminate condition */
	     mpc_cardp = null;			/* set config ptr to start at top */
	     do while (^term);
	        call tolts_util_$find_card ("mpc ", mpc_cardp); /* find mpc card */
	        if mpc_cardp = null () then		/* shouldn't happen */
		 goto t_err1;			/* channel unassignable */
	        do i = 1 to 4 while (mpc_card.port (i).iom ^= -1 & ^term); /* ck each field */
		 if mpc_card.port (i).iom - 1 = IOM then/* if match on iom */
		    if CHAN >= mpc_card.port (i).chan
		     & CHAN <= mpc_card.port (i).chan + (mpc_card.port (i).nchan - 1) /* match */
		     then term = "1"b;		/* set terminate condition */
		 device = 0;			/* want to atatch the mpc first */
	        end;
	     end;
	  end;


         term = "0"b;
         prph_cardp = null;
         do while (^term);				/* now find prph card that goes with chnl */
	  call tolts_util_$find_card ("prph", prph_cardp);
	  if prph_cardp = null then goto t_err1;
	  else if prph_card.name = dname then term = "1"b;/* found it */
         end;

         if prph_cardp = null then			/* if this is true, error */
	  goto t_err1;
      end;
      else do;
         dname, altname = prph_card.name;
         if icdt.tt = "51"b3 & ^io_info.p2_att then	/* if first attach request & mdr */
	  if substr (dname, 1, 3) = "tap" |		/* if tape or disk */
	   substr (dname, 1, 3) = "dsk" then device = 0;

      end;

      MODEL, NDRIVES = 0;				/* set device range  to 0 initialy */
      term = "0"b;

      if substr (dname, 1, 3) = "dsk" then do;
         call ioa_$rsnnl ("^a_^[0^]^d", dname, i,
	dname, (device < 10), device);		/* set in ascii device */

         prph_dsk_cardp = prph_cardp;
         if icdt.tt = "23"b3				/* if running itrs */
	| icdt.tt = "51"b3 then do;
	  do i = 1 to 5 while (prph_dsk_card (i).model ^= -1);
	     if prph_dsk_card.group (i).model > MODEL then/* if this model higher than prev */
	        MODEL = prph_dsk_card.group (i).model;	/* use this one */
	  end;
         end;
         else do;
	  do i = 1 to 5 while ((prph_dsk_card.group (i).model ^= -1) & ^term);
						/* go through each possible pair */
	     if prph_dsk_card.group (i).model ^= 0 then do; /* if not fence */
	        if device >= NDRIVES
	         & device <= NDRIVES + prph_dsk_card.group (i).ndrives then do;
		 MODEL = prph_dsk_card.group (i).model; /* found model */
		 if tolts_util_$dev0_valid (addr (config_data_$disk_drive_model_names), MODEL) then
		    io_info.sct_info.cnt_type = "0011"b;

		 if io_info.sct_info.cnt_type ^= "0011"b
		  & device = 0 then goto t_err2;

		 term = "1"b;
		 di = i;
	        end;
	        else NDRIVES = NDRIVES + prph_dsk_card.group (i).ndrives;
	     end;
	     else NDRIVES = NDRIVES + prph_dsk_card.group (i).ndrives;
	  end;
	  if ^term then goto t_err2;			/* invalid device */
         end;
      end;

      else if substr (dname, 1, 3) = "tap" then do;
         prph_tap_cardp = prph_cardp;
         call ioa_$rsnnl ("^a_^[0^]^d", dname, i,
	dname, (device < 10), device);		/* set in ascii device */
         if (device = 0) & (icdt.tt = "23"b3 | icdt.tt = "51"b3) then do;
	  do i = 1 to 5 while (prph_tap_card.group (i).model ^= -1);
	     if prph_tap_card.group (i).model > MODEL then
	        MODEL = prph_tap_card.group (i).model;
	  end;
         end;
         else do;

	  do i = 1 to 5 while ((prph_tap_card.group (i).model ^= -1) & ^term);
	     if prph_tap_card.group (i).model ^= 0 then do;
	        if (device >= NDRIVES)
	         & (device <= NDRIVES + prph_tap_card.group (i).ndrives) then do;
		 MODEL = prph_tap_card.group (i).model;
		 if tolts_util_$dev0_valid (addr (config_data_$tape_drive_model_names), MODEL) then
		    io_info.sct_info.cnt_type = "0011"b;

		 if io_info.sct_info.cnt_type ^= "0011"b
		  & device = 0 then goto t_err2;
		 term = "1"b;
	        end;
	        else NDRIVES = NDRIVES + prph_tap_card.group (i).ndrives;
	     end;
	     else NDRIVES = NDRIVES + prph_tap_card.group (i).ndrives;
	  end;
	  if ^term then goto t_err2;
         end;
      end;



%page;
/* at this point we have ptr to correct prph card */

c_info:
      mdr_cat = "card ";				/* set default mdr catalog suffix */
      io_info.lostit_time =				/* default lostit time is 1 sec (+ 1min from exec) */
       divide ((one_min + one_sec) * 64, 1000, 35);
      device_info_ptr = addr (io_info.rcp_area (1));	/* set general RCP info first */
      device_info.version_num = DEVICE_INFO_VERSION_1;	/* structure version DEVICE_INFO_VERSION_1 */
      device_info.version_num = 1;			/* structure version 1 */
      device_info.usage_time = 0;			/* T&D will use resource for an indefinite time */
      device_info.wait_time = 0;			/* T&D will not wait for the resource */
      device_info.system_flag = "0"b;			/* T&D is not a system process */
      if substr (dname, 1, 3) = "ccu" then call set_ccu;	/* if combined card unit */
      else if substr (dname, 1, 3) = "dsk" then call set_disk; /* if disk subsystem */
      else if substr (dname, 1, 3) = "dia" then call set_dia; /* if dia */
      else if substr (dname, 1, 3) = "hch" then call set_hch; /* if hyperchannel */
      else if substr (dname, 1, 3) = "mca" then call set_mca; /* if mca */
      else if substr (dname, 1, 3) = "opc" then call set_opc; /* if system console */
      else if substr (dname, 1, 3) = "prt" then call set_prt; /* if printer */
      else if substr (dname, 1, 3) = "pun" then call set_pun; /* if card punch */
      else if substr (dname, 1, 3) = "rdr" then call set_rdr; /* if card reader */
      else if substr (dname, 1, 3) = "tap" then call set_tape; /* if tape subsystem */
      else goto t_err1;				/* invalid prph */
      io_info.device_name = dname;			/* copy device name */
      io_info.devsct.com_prph = ck_com_prph ();
      if ^spec_chan
       & ^io_info.devsct.com_prph then call ck_mpc;	/* go check mpc card */
      device_info.device_name = io_info.device_name;	/* set device for rcp */
      if icdt.tt = "0"b then
         io_info.io_type = polt_io_type;		/* set io type (0 = POLT) */
      else if icdt.tt = "22"b3 then
         io_info.io_type = mtc_io_type;			/* MTC io */
      else if icdt.tt = "23"b3 then
         io_info.io_type = itr_io_type;			/* ITR io */
      else if icdt.tt = "24"b3 then
         io_info.io_type = mtg_io_type;			/* MTG io */
      else if icdt.tt = "25"b3 then
         io_info.io_type = mdc_io_type;			/* MDC io */
      else if icdt.tt = "30"b3 then
         io_info.io_type = mhp_io_type;			/* MHP io */
      else if icdt.tt = "41"b3 then
         io_info.io_type = mdc_io_type;			/* MFC io like MDC io */
      else if icdt.tt = "45"b3 then
         io_info.io_type = mca_io_type;			/* NIO io */
      else if icdt.tt = "51"b3 then
         io_info.io_type = mdr_io_type;			/* MDR io */
      else if icdt.tt = "63"b3 then
         io_info.io_type = mtar_io_type;		/* MTAR io */
      else if icdt.tt = "71"b3 then
         io_info.io_type = rspd_io_type;		/* RSPD io */

      io_info.test_hdr = "";				/* build ascii test header */
      call ioa_$rsnnl ("**^d(^[p^;itr^;mdr^;mtr^;itr^;mtc^;mtg^;mdc^;mhp^;nio^;rsp^]^d^[0^]^d^[^2s^;^[0^]^d^]):",
       io_info.test_hdr, i, px - 1, io_info.io_type + 1, IOM, (CHAN < 10),
       CHAN, (io_info.io_type = 1), (device < 10), device);
      return;

t_err0: type_error = m_iv_iom;			/* set error, invalid IOM number */
      return;
t_err1: type_error = ch_not_ass;			/* set error, unrecognized prph */
      return;
t_err2: type_error = iv_dev;				/* set error, invalid device */
      return;
t_err9: type_error = not_psia;			/* set error, not a psia channel */
      return;
t_err10: type_error = not_log_0;			/* set error, not logical channel 0 of mpc */
      return;
t_err21: type_error = dev_busy;			/* set error, device attached by system */
      return;
t_err23: type_error = inv_tt;				/* set error, invalid test type */
      return;
%page;

/* ck_com_prph - function to check if common prph and if molts in control, return "0"b,
   return "1"b if ok and set io_info.com_prph flag */


ck_com_prph: proc returns (bit (1));

      if spec_chan then return ("0"b);			/* special channel don't bother */
      term = "0"b;
      cont_cardp = null;
      do while (^term);
         if io_info.sct_info.cnt_type = "0011"b then
	  call tolts_util_$find_card ("ipc", cont_cardp);
         else call tolts_util_$find_card ("mpc ", cont_cardp);
         if cont_cardp = null () then return ("1"b);	/* If no mpc | ipc cards found */


         if io_info.sct_info.cnt_type = "0011"b then do;
	  ipc_cardp = cont_cardp;
	  if ipc_card.iom - 1 = IOM then		/* if match on iom */
	     if CHAN >= ipc_card.chan
	      & CHAN <= ipc_card.chan + (ipc_card.nchan - 1) then do; /* match */
	        term = "1"b;			/* set terminate condition */
	        return ("0"b);			/* must be an mpc device */
	     end;
         end;
         else do i = 1 to 4 while (cont_card.port (i).iom ^= -1 & ^term); /* ck each field */
	  mpc_cardp = cont_cardp;
	  if cont_card.port (i).iom - 1 = IOM then	/* if match on iom */
	     if CHAN >= cont_card.port (i).chan
	      & CHAN <= cont_card.port (i).chan + (cont_card.port (i).nchan - 1) then do; /* match */
	        term = "1"b;			/* set terminate condition */
	        return ("0"b);			/* must be an mpc device */
	     end;
         end;
      end;


   end ck_com_prph;


/* ck_mpc - internal procedure to check mpc cards */

ck_mpc: proc;

      if cont_card.model >= 8000
       & cont_card.model < 8005 then do;		/* must be a EURC */
         io_info.crcst.volatile = "0"b;			/* make it a eurc mpc */
         io_info.crcst.mpc = "1"b;			/* set mpc flag */
         io_info.sct_info.cnt_type = "0010"b;
         urcitr = "0"b;				/* reset urcitr flag as firmware is not needed */
      end;
      else do;
         io_info.crcst.mpc = "1"b;			/* set mpc flag */
         io_info.crcst.volatile = "1"b;			/* make it a old style mpc */
         if cont_card.model = 800 then
	  io_info.sct_info.cnt_type = "0001"b;
      end;
      if icdt.tt = "23"b3 & io_info.crcst.volatile	/* if running itrs */
       & CHAN ^= cont_card.port (1).chan		/* and not on log chan 0 */
       & ((substr (cont_card.name, 1, 3) = "msp" & cont_card.model < 600)
       | (substr (cont_card.name, 1, 3) = "msp" & cont_card.model = 800)
       | (substr (cont_card.name, 1, 3) = "mtp" & cont_card.model < 610))
       then goto t_err10;				/* error, not on log chan 0 */
      if icdt.tt = "23"b3 then call set_itr_cat;		/* go decode mpc card to determine itr catalog name */




      if urcitr then do;				/* if running itrs on urc, find all firmware */
         io_info.mpc_dev_cnt = mpc_card.port (1).nchan;	/* save number of log channels */
         prph_cardp = null;				/* start at beginning of deck */
         do i = 1 to io_info.mpc_dev_cnt;		/* get each device */
	  trm = "0"b;				/* reset terminate condition */
	  do while (^trm);				/* loop until we find right kind of card */
	     call tolts_util_$find_card ("prph", prph_cardp); /* find prph config card */
	     if prph_cardp = null then trm = "1"b;	/* this should not happen */
	     else if prph_card.iom - 1 = IOM		/* if on right iom */
	      & prph_card.chan >= mpc_card.port (1).chan
	      & prph_card.chan <= mpc_card.port (1).chan + (mpc_card.port (1).nchan - 1) then do; /* if in range */
	        trm = "1"b;				/* set terminate condition */
	        CHAN = prph_card.chan - mpc_card.port (1).chan + 1; /* get right log chan */
	        if substr (prph_card.name, 1, 3) = "rdr"	/* if reader */
	         | substr (prph_card.name, 1, 3) = "pun"	/* if punch */
	         | substr (prph_card.name, 1, 3) = "ccu" then /* if combined reader and punch */
		 call set_mask ("ucrp");
	        else if substr (prph_card.name, 1, 3) = "prt" then /* if printer */
		 call set_mask ("u400");
	     end;
	  end;
         end;
         do k = 1 to 4 while (io_info.dev_firm (k).mask ^= "0"b); /* get true device count */
         end;
         io_info.mpc_dev_cnt = k - 1;			/* set adjusted device count */
      end;
   end ck_mpc;


/* ck_urcd - fuction to check device code on urcmpc device */

ck_urcd: proc returns (bit (1));

      if icdt.tt = "0"b | icdt.tt = "51"b3 then		/* if polts or mdrs */
         if device ^= 1 then				/* device code must be device 1 */
	  return ("0"b);				/* return false */
      if icdt.tt = "51"b3 then			/* if mdrs to be run */
         io_info.cat_name = "mdr." || mdr_cat;		/* set mdr catalog name */
      else if icdt.tt = "23"b3 then do;			/* if itrs on urmpc */
         if device ^= 0 then				/* and device not 0 */
	  return ("0"b);
         urcitr = "1"b;				/* set flag to set up firmware */
      end;
      return ("1"b);

   end ck_urcd;


/*  The following function returns the 'console model index' given the console
   model number.  If the model number is not known, -1 is returned.   */

CONSOLE_MODEL_TO_INDEX_FCN: procedure (model_number) returns (fixed bin);

dcl  (i, model_number) fixed bin;

      do i = 1 to hbound (CONSOLE_MODEL_NUMBER, 1);
         if model_number = CONSOLE_MODEL_NUMBER (i)
	then return (CONSOLE_MODEL_INDEX (i));
      end;

      return (-1);

   end CONSOLE_MODEL_TO_INDEX_FCN;
%page;

/* set_ccu - internal procdure to set type codes for combined card (CCU) equitment */

set_ccu: proc;

%include config_prph_ccu_card;

      prph_ccu_cardp = prph_cardp;
      if model = 401 then do;				/* if correct model */
         io_info.devsct.type_code = "22"b3;		/* set correct type code */
         if ^ck_urcd () then				/* ck device number */
	  goto t_err2;				/* error, invalid device */
         if ^io_info.ccu_pun then do;			/* if mme setpun has not been called... */
	  io_info.rcp_name = DEVICE_TYPE (READER_DTYPEX); /* set default rcp type to reader */
	  substr (dname, 1, 3) = "rdr";
         end;
         else do;
	  io_info.rcp_name = DEVICE_TYPE (PUNCH_DTYPEX);	/* otherwise set for punch */
	  substr (dname, 1, 3) = "pun";
         end;
      end;
      else goto t_err1;				/* not supported */
   end set_ccu;
%page;

/* set_disk - internal procedure to set type codes for disk subsystems */

set_disk: proc;

/* ***************************************************
   *   if mtar 500/501, check for alternate device   *
   *************************************************** */

      if icdt.tt = "63"b3 & (MODEL = 500 | MODEL = 501) then do;
         io_info.alt_dev_flag = "1"b;
         if mod (device, 2) = 1			/* odd device */
	& device + 1 > prph_dsk_card.group (di).ndrives + NDRIVES then
	  goto t_err2;
         else if device - 1 < NDRIVES then goto t_err2;
      end;

      if MODEL = 181 then io_info.devsct.type_code = "60"b3;
      else if MODEL = 190 then io_info.devsct.type_code = "61"b3;
      else if MODEL = 191 | MODEL = 400 then io_info.devsct.type_code = "62"b3;
      else if MODEL = 451 then io_info.devsct.type_code = "65"b3;
      else if MODEL = 500 then io_info.devsct.type_code = "66"b3;
      else if MODEL = 501 then io_info.devsct.type_code = "67"b3;
      else if MODEL = 509 then io_info.devsct.type_code = "70"b3;
      else if MODEL = 3380 then io_info.devsct.type_code = "53"b3;
      else if MODEL = 3381 then io_info.devsct.type_code = "55"b3;
      else goto t_err1;				/* set error */
      if MODEL >= 500 & MODEL < 510 then io_info.crcst.ms500 = "1"b; /* set ms500 indicator */
      if icdt.tt = "51"b3 then			/* if running mdrs */
         io_info.cat_name = "mdr.disk";			/* set mdr catalog name */

      if icdt.tt = "23"b3				/* if running ITRs */
       | (icdt.tt = "51"b3 & ^io_info.p2_att) then	/* if running MDRs & the first attachment */
         io_info.rcp_name = DEVICE_TYPE (SPECIAL_DTYPEX);	/* set "special" designator */
      else do;					/* other wise set up specific info */
         disk_info_ptr = device_info_ptr;
         io_info.rcp_name = DEVICE_TYPE (DISK_DRIVE_DTYPEX);
         disk_info.write_flag = "1"b;
         if icdt.u_opt = "64"b3 then			/* if unload option in force... */
	  disk_info.volume_name = "T&D_Volume";		/* set special volume name */
         else disk_info.volume_name = "scratch";		/* otherwise have operator load and authenicate mount */
         disk_info.device_name = dname;
         disk_info.model = MODEL;



/* *************************************************
   *   set up alternate sct/rcp if mtar 500/501    *
   ************************************************* */

         if io_info.alt_dev_flag then do;
	  io_info.altsct = io_info.devsct;		/* copy sct */
	  if mod (device, 2) ^= 0 then
	     io_info.altsct.device_no = bit (bin (bin (io_info.devsct.device_no, 6) + 1, 6), 6); /* odd device */
	  else io_info.altsct.device_no = bit (bin (bin (io_info.devsct.device_no, 6) - 1, 6), 6);
	  io_info.alt_rcp_area = io_info.rcp_area;	/* build alternate device name */
	  device2 = fixed (io_info.altsct.device_no);
	  disk_info_ptr = addr (io_info.alt_rcp_area);
	  if icdt.u_opt = "64"b3 then
	     disk_info.volume_name = "T&D_Volume";
	  else disk_info.volume_name = "scratch";
	  call ioa_$rsnnl ("^a_^[0^]^d", altname, i, altname, (device2 < 10), device2);
	  disk_info.device_name = altname;		/* store alternate device name in rcp */
	  io_info.alt_device_name = altname;
	  disk_info.model = MODEL;
	  disk_info_ptr = addr (io_info.rcp_area);	/* restore pointer */
         end;

/* check users access to the rcp_sys_ gate. If he has access, make him a system process  */

         call hcs_$initiate (">system_library_1", "rcp_sys_", "", 0, 0, rcpsp, code);
         if rcpsp ^= null then do;
	  call hcs_$fs_get_mode (rcpsp, rs_mode, code);
	  if code = 0 then
	     if bit (rs_mode) & execute then
	        disk_info.system_flag = "1"b;		/* make him a system process */
	  disk_info_ptr = addr (io_info.alt_rcp_area);	/* set pointer to alternate rcp area */
	  disk_info.system_flag = "1"b;		/* set alternate system flag in case needed */
	  disk_info_ptr = addr (io_info.rcp_area);	/* restore pointer */
         end;
      end;

   end set_disk;
%page;

/* set_dia - internal procedure to set device info for a Colts RSPD request */

set_dia: proc;

      spec_chan = "1"b;
      io_info.rcp_name = DEVICE_TYPE (SPECIAL_DTYPEX);	/* set "special" designator */
      device_info.device_name = dname;
      device_info.model = 0;

   end set_dia;


/* set_hch - internal procedure to set type code for hyperchannels */

set_hch: proc;
      if substr (dname, 1, 3) = "hch" then do;
         spec_chan = "1"b;				/* special channel */
         io_info.devsct.type_code = "07"b3;
         io_info.rcp_name = DEVICE_TYPE (SPECIAL_DTYPEX);	/* set "special" designator */
      end;
      else goto t_err2;
   end set_hch;
%page;

/* set_itr_cat - int procedure to set up itr catalog name from mpc card info */

set_itr_cat: proc;

      if substr (mpc_card.name, 1, 3) = "urp" then	/* urmpc is easy */
         io_info.cat_name = "itr.urcmpc";
      else if substr (mpc_card.name, 1, 3) = "mtp" then do; /* mag tapes */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
/*
   /* Since we are here because we are running itrs and the correct mpc is located, the correct
   /* devsct.type_code will also be set.								*/
/*											*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


         if mpc_card.model >= 500 & mpc_card.model < 601	/* mtc500 type */
	then io_info.cat_name = "itr.mtc500";

         else if mpc_card.model = 601 | mpc_card.model = 602 then do; /* mtp601 */
	  io_info.cat_name = "itr.mtp601";
	  if io_info.devsct.type_code = "13"b3
	   then io_info.devsct.type_code = "15"b3;
	  else io_info.devsct.type_code = "16"b3;
	  io_info.crcst.mtp610 = "0"b;		/* if mpc601 there should not be any mth610 devices. */
         end;
         else if mpc_card.model = 610 | mpc_card.model = 611 then do; /* mtp610 */
	  io_info.cat_name = "itr.mtp610";
	  if io_info.devsct.type_code = "13"b3
	   then io_info.devsct.type_code = "15"b3;
	  else io_info.devsct.type_code = "16"b3;
         end;
         else goto t_err1;				/* should go to something for invalid mpc card */
      end;
      else if substr (mpc_card.name, 1, 3) = "msp" then do; /* disks */
         if mpc_card.model = 181 then			/* dsc181 */
	  io_info.cat_name = "itr.dsc181";
         else if mpc_card.model = 190 then		/* dsc190 */
	  io_info.cat_name = "itr.dsc190";
         else if mpc_card.model = 191
	| mpc_card.model = 400
	| mpc_card.model = 451
	| (mpc_card.model >= 600 & mpc_card.model <= 603) then
	  io_info.cat_name = "itr.dsc191";		/* dsc191 */
         else if mpc_card.model >= 604 & mpc_card.model <= 612 then do; /* dsc500 */
	  io_info.cat_name = "itr.dsc500";
	  io_info.crcst.ms500 = "1"b;
         end;
         else if mpc_card.model = 800 then do;		/* msp800 */
	  io_info.cat_name = "itr.msp800";
         end;
         else goto t_err1;
      end;
      else goto t_err1;

   end set_itr_cat;



/* set_mask - internal procedure to set device mask for urcmpc devices */

set_mask: proc (en);

dcl  en char (4);					/* device firmware edit name */

      term = "0"b;					/* reset terminate condition */
      do k = 1 to 4 while (^term);			/* go through all masks */
         if unspec (io_info.dev_firm (k).edit_name) = "0"b
	| io_info.dev_firm (k).edit_name = en then do;	/* if found match */
	  term = "1"b;
	  io_info.dev_firm (k).edit_name = en;		/* set edit name, in case it wasn't  set */
	  substr (io_info.dev_firm (k).mask, CHAN + 1, 1) = "1"b; /* set port mask */
         end;
      end;

   end set_mask;
%page;


/* set_mca - internal procedure to setup io_info for mca */

set_mca: proc;

      if substr (dname, 1, 3) = "mca" then do;
         io_info.lostit_time =			/*  lostit time for the mca is 5min + 1 sec */
	divide ((five_min + one_sec) * 64, 1000, 35);
         spec_chan = "1"b;				/* special channel */
         io_info.cat_name = "nio.IMU";
      end;
      else goto t_err2;
   end set_mca;
%page;

/* set_opc - internal procedure to set up type codes for  operators consoles */

set_opc: proc;

%include config_prph_opc_card;


      prph_opc_cardp = prph_cardp;
      if icdt.tt ^= "0"b then				/* if molts in control */
         goto t_err9;

      if state = "on " | state = "alt " then goto t_err21;

      model_index = CONSOLE_MODEL_TO_INDEX_FCN (prph_opc_card.model);
      if model_index < 0 then goto t_err1;

      io_info.devsct.type_code = CONSOLE_GCOS_TYPE (model_index);

      if CONSOLE_IS_BCD (model_index) then
         if device ^= 0 then				/* device 0 is only legal device code */
	  goto t_err2;
         else ;
      else if device ^= 1 then			/* device 1 is only legal device code */
         goto t_err2;

      spec_chan = "1"b;				/* special channel */
      io_info.rcp_name = DEVICE_TYPE (CONSOLE_DTYPEX);	/* set rcp designator */

   end set_opc;
%page;

/* set_prt - internal procedure to set type codes for printers */

set_prt: proc;

%include config_prph_prt_card;

      prph_prt_cardp = prph_cardp;
      if model = 301 then do;				/* if prt301 */
         if icdt.tt ^= "0"b then			/* if Molts in control... */
	  goto t_err9;				/* can't run Itrs or mdrs on com prph */
         if device ^= 0 then				/* common perp urc equip is device 0 */
	  goto t_err2;				/* error, invalid device */
         io_info.devsct.type_code = "25"b3;
      end;
      else if model = 1000 | model = 1200 | model = 1600 then /* if pru1200/1600 */
         io_info.devsct.type_code = "24"b3;
      else if model = 500 | model = 501
       | model = 901 | model = 1201 then do;		/* check for pr54 id */
         io_info.devsct.type_code = "24"b3;
         io_info.devsct.cr501_pr54 = "1"b;		/* set pr54 flag */
         io_info.crcst.volatile = "0"b;			/* make it a eurc mpc */
         io_info.crcst.mpc = "1"b;			/* set mpc flag */
         io_info.sct_info.cnt_type = "0010"b;
         spec_chan = "1"b;				/* and it is a special channel */
      end;
      else goto t_err1;				/* not supported */
      mdr_cat = "print";				/* set mdr catalog suffix */
      if model >= 900 then				/* if urcmpc device */
         if ^ck_urcd () then				/* ck device number */
	  goto t_err2;				/* error, invalid device */
      io_info.devsct.ptrain = train;			/* set print train number */
      if line_length = 160 then			/* if line length is 160 ... */
         io_info.devsct.ll160 = "1"b;			/* set it */
      printer_info_ptr = device_info_ptr;		/* set up rcp info */
      printer_info.line_length = line_length;
      printer_info.print_train = train;			/* set print train number */
      io_info.rcp_name = DEVICE_TYPE (PRINTER_DTYPEX);

   end set_prt;
%page;

/* set_pun  - internal procedure to set type codes for card punches */

set_pun: proc;

%include config_prph_pun_card;


      prph_pun_cardp = prph_cardp;
      if model = 201 then do;
         if icdt.tt ^= "0"b then			/* if Molts in control... */
	  goto t_err9;				/* can't run itrs or mdrs on com prph */
         if device ^= 0 then				/* common perp urc equip is device 0 */
	  goto t_err2;				/* error, invalid device */
         io_info.devsct.type_code = "23"b3;		/* set type code */
      end;
      else if model > 201 & ^ck_urcd () then		/* ck device number */
         goto t_err2;				/* error, invalid device */
      else if model = 300 | model = 120 | model = 121 then
         io_info.devsct.type_code = "32"b3;
      else if model = 301 then
         io_info.devsct.type_code = "33"b3;
      else if model = 401 then do;			/* if ccu goto ccu proc */
         call set_ccu;
         goto end_sp;
      end;
      else goto t_err1;				/* not supported */
      io_info.rcp_name = DEVICE_TYPE (PUNCH_DTYPEX);	/* set rcp designator */
end_sp: end set_pun;
%page;


/* set_rdr - internal procedure to set type codes for card readers */

set_rdr: proc;

%include config_prph_rdr_card;

      prph_rdr_cardp = prph_cardp;
      if model = 201 then do;				/* if type 201 reader */
         if icdt.tt ^= "0"b then			/* if Molts in control... */
	  goto t_err9;				/* can't run itrs or mdrs on com prph */
         if device ^= 0 then				/* common perp urc equip is device 0 */
	  goto t_err2;				/* error, invalid device */
         io_info.devsct.type_code = "21"b3;		/* set type code */
         if model = 500 | model = 501 then
	  io_info.devsct.cr501_pr54 = "1"b;		/* set cr500 flag */
      end;
      if model > 201				/* if urcmpc device */
       & ^ck_urcd () then goto t_err2;			/* ck device number- error invalid device */
      else do;
         if model = 301 | model = 500 | model = 501 then	/* if type 301 or 500/501 */
	  io_info.devsct.type_code = "34"b3;
         if model = 401 then				/* if ccu goto ccu proc */
	  call set_ccu;
         else goto t_err1;				/* not supported */
      end;
      io_info.rcp_name = DEVICE_TYPE (READER_DTYPEX);	/* set rcp designator */
   end set_rdr;
%page;


/* set_tape - internal procdure to set type codes for tapes */

set_tape: proc;

      if MODEL = 500 then io_info.devsct.type_code = "14"b3;
      else if MODEL = 507 then io_info.devsct.type_code = "13"b3;
      else if MODEL = 600 then io_info.devsct.type_code = "16"b3;
      else if MODEL = 610 then io_info.devsct.type_code = "16"b3;
      else if MODEL = 630 then io_info.devsct.type_code = "16"b3;

      else if io_info.sct_info.cnt_type = "0011"b then	/* if fips controler */
         io_info.devsct.type_code = "16"b3;		/* set type = 16 */
      else goto t_err1;

      if MODEL = 610 | MODEL = 630 then io_info.crcst.mtp610 = "1"b;
      io_info.devsct.den_cap = "0100"b;			/* set for nrzi, and 1600 for now */
      if icdt.tt = "51"b3 then			/* if running mdrs */

         io_info.cat_name = "mdr.tape";			/* set mdr catalog name */
      if icdt.tt = "23"b3				/* if running ITRs */
       | (icdt.tt = "51"b3 & ^io_info.p2_att) then	/* if running MDRs & the first attachment */
         io_info.rcp_name = DEVICE_TYPE (SPECIAL_DTYPEX);	/* set "special" designator */
      else do;					/* other wise set up specific info */
         tape_info_ptr = device_info_ptr;		/* set structure ptr */
         tape_info.version_num = tape_info_version_2;	/* set version 2 for tapes */
         io_info.rcp_name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX);
         tape_info.write_flag = "1"b;
         if icdt.u_opt = "64"b3 then			/* if unload option in force... */
	  tape_info.volume_name = "T&D_Volume";		/* set special volume name */
         else tape_info.volume_name = "scratch";		/* no, let opr load and authenticate mount */
         tape_info.device_name = dname;
         tape_info.model = MODEL;
         if MODEL = 507 then tape_info.tracks = 7;
         else tape_info.tracks = 9;
         io_info.lostit_time = 64000 * 180;		/* 3 min lostit time on tapes */
      end;

   end set_tape;
%page;

%include console_device_specs;
%page;
%include config_data_dcls;
%page;
%include config_chnl_card;
%page;
%include config_iom_card;
%page;
%include config_ipc_card;
%page;
%include config_mpc_card;
%page;
%include config_prph_card;
%page;
%include config_prph_dsk_card;
%page;
%include config_prph_tap_card;
%page;
%include rcp_device_info;
%page;
%include rcp_disk_info;
%page;
%include rcp_printer_info;
%page;
%include rcp_resource_types;
%page;
%include rcp_tape_info;
%page;
%include tolts_err_codes;
%page;
%include tolts_info;


   end tolts_device_info_;





		    tolts_file_util_.pl1            10/28/88  1413.0r w 10/28/88  1302.2       82962



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* orginal coding by J. A. Bush 79/03/22 */




/****^  HISTORY COMMENTS:
  1) change(85-03-16,Fakoury), approve(86-08-22,MCR7514),
     audit(86-11-24,Martinson), install(86-12-04,MR12.0-1235):
     change dump offset and correct a problem when wdump is called to force a
     dump.
                                                   END HISTORY COMMENTS */





/* tolts_file_util_ - subroutines to manage print file output for polts and molts */


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
tolts_file_util_: proc;
						/* Constants */

dcl  ds_format_1 bit (11) int static options (constant)
      init ("01000100000"b);				/* display address offset only & data in long format */
dcl  ds_format_2 bit (11) int static options (constant)
      init ("11000100000"b);				/* display address & offset & data in long format */

/* External entries */

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  date_time_ entry (fixed bin (71), char (*));
dcl  dprint_ entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  user_info_ entry (char (*), char (*), char (*));
dcl  dump_segment_ entry (ptr, ptr, fixed bin, fixed bin, fixed bin, bit (*));
dcl  (tolts_qttyio_$rs, ioa_$ioa_switch) entry options (variable);
dcl  clock_ entry returns (fixed bin (71));
dcl  tolts_util_$bci_to_ascii entry (bit (*), char (*) varying, fixed bin);

/* Automatic */

dcl  (i, first, c_len) fixed bin;			/* do loop cnters */
dcl  (uname, uproj, uacct) char (32);
dcl  out_str char (136) varying;
dcl  time_str char (24);
dcl  code fixed bin (35);
dcl  (dptr, genp) ptr;
dcl  format bit (11);

/* Entry parameters */

dcl  rcode fixed bin (35);				/* standard system error rcode */
dcl  a_dcwp ptr;
dcl  regp ptr;

/* Builtins */

dcl  (addr, fixed, floor, length, null, ptr, substr, rtrim) builtin;

/* Structures */

dcl  1 regs based (regp) aligned,			/* registers from sregs instruction */
       (2 x (0:7) bit (18),				/* index regs */
       2 a bit (36),				/* a register */
       2 qu fixed bin (18) unsigned,
       2 ql fixed bin (18) unsigned) unaligned;		/* q reg */

dcl  1 rcw based (genp),				/* structure for gcos sysout records with rcws */
       (2 dlen fixed bin,				/* number of words */
       2 pad fixed bin) unaligned,			/* reset of  rcw not used */
       2 data bit (rcw.dlen * 36),			/* bcd data as bit string */
       2 nxt_rcw bit (0);				/* used for getting next rcw */
%page;
/* open - entry to attach and open print file */

open: entry (rcode);

      rcode = 0;					/* initialize return code */
      tolts_info.pf_name = unique_chars_ (""b) || "." || tolts_info.exec || ".dump"; /* form unique name */
      call iox_$attach_name ("err_file", tolts_info.pf_iocbp, /* attach file */
       "vfile_ " || rtrim (tolts_info.hdir) || ">" || tolts_info.pf_name, null, code);
      if code ^= 0 then do;				/* if some problem with attach */
         rcode = code;				/* return error code */
         return;					/* get out now */
      end;
      tolts_info.file_attach = "1"b;			/* indicate our seg is attached */
      call iox_$open (tolts_info.pf_iocbp, 2, "0"b, code);	/* open for stream output */
      if code ^= 0 then do;
         rcode = code;				/* return error code */
         call clean_up;				/* go detach file */
         return;
      end;
      tolts_info.file_open = "1"b;
      call date_time_ ((clock_ ()), time_str);		/* get current time of day */
      call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/^2-^as print file ^a>^a opened at ^a^/",
       tolts_info.exec, tolts_info.hdir, tolts_info.pf_name, time_str);
      return;
%page;
/* close - entry to close and detach print file and queue up dprint */

close: entry;

      call date_time_ ((clock_ ()), time_str);		/* get current time of day */
      call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/^2-^as print file ^a>^a closed at ^a",
       tolts_info.exec, tolts_info.hdir, tolts_info.pf_name, time_str);
      call clean_up;				/* close and detach file */
      call user_info_ (uname, uproj, uacct);		/* get users name and project */
      out_str = rtrim (uname) || "." || rtrim (uproj);	/* form desc line */
      if length (out_str) < 10 then
         i = floor ((14 - length (out_str)) / 2);		/* form center index */
      else i = 1;					/* if name to long, start at collum 1 */
      dpap = addr (dprint_arg_buf);			/* set dprint arg ptr */
      dprint_arg.version = 1;				/* set appropriate args */
      dprint_arg.copies = 1;
      dprint_arg.delete = 1;
      dprint_arg.queue = 3;				/* probably should be queue 1 */
      dprint_arg.pt_pch = 1;
      dprint_arg.notify = 1;				/* might want to make this 0 */
      dprint_arg.output_module = 1;
      substr (dprint_arg.dest, i) = out_str;		/* set in person/project info */
      if tolts_info.exec = "polt" then			/* if polts dump */
         dprint_arg.heading = " for  POLTS DUMP";
      else if tolts_info.exec = "molt" then		/* if molts dump */
         dprint_arg.heading = " for  MOLTS DUMP";
      else if tolts_info.exec = "colt" then		/* if colts dump */
         dprint_arg.heading = " for  COLTS DUMP";
      call dprint_ (tolts_info.hdir, tolts_info.pf_name, dpap, code); /* queue it up */
      call tolts_qttyio_$rs (0, "^as dump file ^a>^a has been queued for printing",
       tolts_info.exec, tolts_info.hdir, tolts_info.pf_name);
      return;
%page;
/* snap - entry to output snap shot dumps */

snap: entry (a_dcwp);

      dcwp = a_dcwp;				/* copy dcw ptr */
      c_len = fixed (dcw.tally);			/* set dump length */
      first = fixed (dcw.address);			/* set first address */
      dptr = ptr (tolts_info.execp, first);		/* and start dump ptr */
      format = ds_format_1;				/* display address offset & data in long format */
      call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/");	/* output blank line */
      call dump_segment_ (tolts_info.pf_iocbp, dptr, 0, first, c_len, format); /* dump it */
      return;					/* thats it */
%page;
/* wdump - entry to output wrap up dumps and dumps with formatted register panal */

wdump: entry (regp);

      call date_time_ ((clock_ ()), time_str);		/* get current date/time */
      if regp ^= execp then do;
         call ioa_$ioa_switch (tolts_info.pf_iocbp,	/* put out dump header line */
	"^/^2-^as ^[master mode^;slave^] dump taken ^a^/",
	tolts_info.exec, (regs.x (2) = "442020"b3), time_str);
         dcwp = addr (regs.a);			/* get dcw ptr */
         c_len = fixed (dcw.tally);			/* get dcw length */
         i = 0;					/* reset word counter */
         genp = ptr (dcwp, dcw.address);		/* get ptr to first rcw */
         do while (i < c_len);			/* do until we are done */
	  i = i + rcw.dlen + 1;			/* add current rcw length + rcw */
	  call tolts_util_$bci_to_ascii (rcw.data, out_str, rcw.dlen * 6); /* convert to ascii */
	  call ioa_$ioa_switch (tolts_info.pf_iocbp, "^a", out_str);
	  genp = addr (rcw.nxt_rcw);			/* get next rcw address */
         end;
      end;
      else call ioa_$ioa_switch (tolts_info.pf_iocbp,	/* put out dump header line */
	  "^/^2-^as master mode dump taken ^a^/",
	  tolts_info.exec, time_str);

      call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/");	/* put out new line */
      if regp = execp | regs.x (2) = "442020"b3 then do;	/* if master mode dump */
         format = ds_format_2;			/* display address & offset & data long format */
         first = -72;
         c_len = 77777;				/* dump the entire seg */
         dptr = execp;				/* set ptr to beginning of seg */
      end;
      else do;
         format = ds_format_2;			/* display address & offset & data long format */
         first = -72;
         c_len = regs.ql;
         dptr = ptr (execp, regs.qu);
      end;
      call dump_segment_ (tolts_info.pf_iocbp, dptr, 0, first, c_len, format); /* dump it */
      return;					/* thats it */
%page;
/* clean_up - internal procedure to close and detach print file */

clean_up: proc;

      if tolts_info.file_open then do;			/* if file open */
         call iox_$close (tolts_info.pf_iocbp, code);
         tolts_info.file_open = "0"b;
      end;
      if tolts_info.file_attach then do;		/* if file attached */
         call iox_$detach_iocb (tolts_info.pf_iocbp, code);
         tolts_info.file_attach = "0"b;
         tolts_info.pf_iocbp = null;
      end;

   end clean_up;
%page;
%include dprint_arg;
%page;
%include mca_data_area;
%page;
%include tolts_info;


   end tolts_file_util_;




		    tolts_init_.pl1                 07/20/88  1306.3r w 07/19/88  1536.9      160470



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* Modified by R.Fakoury 01/81 & 09/81 for colts implementation.
   Modified by R. Fakoury 09/81 to increase wks_sz for mtar.
*/




/****^  HISTORY COMMENTS:
  1) change(86-08-21,Fakoury), approve(86-08-21,MCR7514),
     audit(86-11-11,Martinson), install(86-12-04,MR12.0-1235):
      2/85 to MCA cleanup,
      1/86 for colts RSPD to get a correct workspace size.
                                                   END HISTORY COMMENTS */





/*   The function of the external procedure "tolts_init_" is to perform certain initialization actions for the test
   system. There are three functions to be performed for this initialization:

   1.  Creating a temporary "slave" segment.

   2.  Initializing static variables.

   3.  Creating event channels to handle service requests.

   Creating a temporary "slave" segment:

   A temporary segment of the name of "<exec>_slave", is created, where <exec> is the input parameter by the same
   name  and  can  be "polt", "molt" or "colt". This temporary segment will be used to load the core image of the
   target slave mode exec.

   Initializing static variables:

   "tolts_init_" will initialize static variables in the static structure "tolts_info".

   Creating event channels to handle service requests:

   The following event channels are created by "tolts_init_":

   1.  tolts_info.tty_ccc_event:  (call channel)

   This event channel is used by the routine "term_io_sim_comp_" whenever the simulated tty io termination timer  calls
   "term_io_sim_comp_" to indicate that the tty io should be complete (see "term_io_sim_comp_" for information on this). When
   "term_io_sim_comp_" is called, it will issue a wakeup to the "tolts_info.tty_ccc_event" event channel. The purpose
   of this is to convert the process asychronous timer signal used to indicate that the tty io has been completed
   to a process "sychronous" IPC call channel. In that way, the tty io termination service will only  occur  when
   the process goes blocked for some reason rather than at any time that might not be desirable such as at a time
   when a data base is being altered by the interrupted procedure where "tty_ccc" must also alter that data  data
   base. "tty_ccc" is the procedure called by signalling "tolts_info.tty_ccc_event".

   2.  tolts_info.tty_issue_event:  (call channel)

   This event channel is used to actually issue the tty io. Whenever tty io is buffered for output, this  channel
   is  signalled  and  whenever it is called, the tty io will be issued. By having this channel masked wherever a
   tty io is already in progress, and unmasking it when the current io is complete, tty  io  will  be  issued  in
   succesion as they are requested rather than overlapped.


   3.  tolts_info.request_event:  (call channel)

   This event channel is used to signal the procedure "test_request" for every operator solicited input (after  a
   "???" typeout due to a quit condition and the original input data after "test" that starts the test process).


   4.  tolts_info.wait_list.wait_event_id:  (wait channel)

   This event wait channel is used to allow breaking the test systems only "block" whenever processing is  to  be
   done  other than "call event" type processing. Such "non-call" processing is either dispatching to a test page
   via the "main_dispatcher" or test system termination (either normal or forced).


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */

tolts_init_:   proc (exec, a_error);
  

/* input parameters */

dcl  exec char (4);					/* can be "polt", "molt" or "colt" */
dcl  (a_error, a_err) fixed bin (35);			/* return error codes */
dcl  event_ch fixed bin (71);				/* event channel id to create */
dcl  call bit (1);					/* = "1"b if call channel is to be created */
dcl  call_entry entry;				/* entry to call for call channels */
dcl  odp ptr;					/* ptr to region for data to be pssed */
dcl  prior fixed bin;				/* relative priority of call channel */
dcl  g_time bit (36);				/* return parameter for gc_tod entry */
dcl  slave_exec char (10);


/* external entries */

dcl  add_epilogue_handler_ entry (entry, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  get_process_id_ entry returns (bit (36));
dcl  get_default_wdir_ entry returns (char (168) aligned);
dcl  hcs_$assign_channel entry (fixed bin (71), fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$set_call_prior entry (fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  mca_$detach_mca entry (fixed bin, fixed bin (35));
dcl  mtdsim_$mme_fault entry;
dcl  mtdsim_$epilogue entry;
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  sct_manager_$get entry (fixed bin, ptr, fixed bin (35));
dcl  sct_manager_$set entry (fixed bin, ptr, fixed bin (35));
dcl  tolts_alm_util_$ascii_to_bcd_ entry (char (*), bit (*));
dcl  tolts_alrm_util_$gewake entry;
dcl  tolts_alrm_util_$quit entry;
dcl  tolts_file_util_$wdump entry (ptr);
dcl  tolts_ttyio_display_ entry (ptr);
dcl  tolts_ttyio_display_$nxt_line entry (ptr);
dcl  tolts_ttyio_end_ entry;

/* automatic */

dcl  code fixed bin (35);
dcl  data char (36) varying;
dcl  date_str char (8);
dcl  delta fixed bin (71);
dcl  error fixed bin (35);
dcl  gc_date bit (36);
dcl  i fixed bin;

/* constants */

dcl  small_workspace fixed bin int static options (constant) init (4096);
dcl  large_workspace fixed bin int static options (constant) init (9000);
dcl  gewake_prior fixed bin int static options (constant) init (11);
dcl  old_mme1 ptr int static init (null);
dcl  pname char (11) int static options (constant) init ("tolts_init_");
dcl  quith_prior fixed bin int static options (constant) init (8);
dcl  sec_per_day fixed bin (37) int static options (constant) init (86400000000);
dcl  tty_ccc_prior fixed bin int static options (constant) init (9);
dcl  tty_issue_prior fixed bin int static options (constant) init (10);
dcl  sc_dir char (168) static options (constant) init (">system_control_1");
dcl  (addr, clock, date, null, unspec) builtin;
%page;
      a_error = 0;					/* preset return code good */
      tolts_infop = null;				/* preset our info ptr to null */
      call get_temp_segment_ ("tolts_info", tolts_infop, error); /* get a ptr to our info segment */
      if error ^= 0 then do;				/* problem creating info seg */
         call com_err_ (error, pname, "getting temporary segment for tolts_info");
         a_error = error;
         return;
      end;
      unspec (tolts_info) = "0"b;			/* clear entire structure first */
      tolts_info.execp = null;			/* preset exec ptr to null */
      tolts_info.exec = exec;				/* store exec name */
      tolts_info.df_iocbp = null;			/* preset deckfile iocb ptr to null */
      tolts_info.pf_iocbp = null;			/* preset print file iocb ptr to null */
      tolts_info.hdir = get_default_wdir_ ();		/* get users home dir pathname */
      tolts_info.pf_name = "";			/* initialize print file name  to blanks */

/* get a temporary segment for <exec>_slave */

      slave_exec = exec || "_slave";
      call get_temp_segment_ (slave_exec, execp, error);
      if error ^= 0 then do;				/* can't get temporary segment */
         call com_err_ (error, pname, "getting temporary segment for ^a_slave", exec);
         a_error = error;				/* copy error code */
         return;
      end;
      unspec (slave_exec) = "0"b;			/* clear entire slave exec temp seg */

/* initialize the rest of tolts_info */

      fnp (*).cdt_name = "empty";
      tolts_info.process = get_process_id_ ();		/* get our process id */
      tolts_info.wait_list.nchan = 1;
      tolts_info.mess_buf.first, tolts_info.mess_buf.nxt = addr (tolts_info.mess_buf.term_queue); /* set tty io ptrs */
      if exec = "polt"				/* if running polts */
       | exec = "colt" then tolts_info.wks_sz = small_workspace;  /* or colts set workspace for 4K */
      else tolts_info.wks_sz = large_workspace;			/* if molts set it for 9k */

/* set up mme1 condition static handler */

      call sct_manager_$get (mme1_sct_index, old_mme1, error); /* save old mme  sct index */
      if error = 0 then
         call sct_manager_$set (mme1_sct_index, addr (mtdsim_$mme_fault), error); /* and set up static mme handler */
      if error ^= 0 then do;
         call com_err_ (error, pname, "setting up static mme1 handler");
         call clean_up;
         a_error = error;
         return;
      end;

/* set up epilogue handler for process hangups */

      call add_epilogue_handler_ (mtdsim_$epilogue, error); /* add epilogue entry */
      if error ^= 0 then do;
         call com_err_ (error, pname, "setting up epilgue handler");
         call clean_up;
         a_error = error;
         return;
      end;

/* i~\nitialize date time constants in tolts_info */

      call init_time (error);
      if error ^= 0 then do;
         call com_err_ (error, pname, "error from convert_date_to_binary_");
         call clean_up;
         a_error = error;
         return;
      end;
%page;

/* create an event call channel for tty io termination requests */

      data = "original message data";
      call cr_event_chan (tolts_info.tty_ccc_event, "1"b, tolts_ttyio_end_,
       addr (data), tty_ccc_prior, error);
      if error ^= 0 then do;				/* trouble creating event call channel... */
         a_error = error;				/* copy error code */
         call clean_up;				/* go delete event channels already created */
         return;					/* and return */
      end;

/* create an event call channel for tty io initiation requests */

      call cr_event_chan (tolts_info.tty_issue_event, "1"b, tolts_ttyio_display_,
       addr (data), tty_issue_prior, error);
      if error ^= 0 then do;				/* trouble creating event call channel... */
         a_error = error;				/* copy error code */
         call clean_up;				/* go delete event channels already created */
         return;					/* and return */
      end;

/* create an event call channel for tty io display requests */

      call cr_event_chan (tolts_info.tty_display_event, "1"b, tolts_ttyio_display_$nxt_line,
       addr (data), tty_issue_prior, error);
      if error ^= 0 then do;				/* trouble creating event call channel... */
         a_error = error;				/* copy error code */
         call clean_up;				/* go delete event channels already created */
         return;					/* and return */
      end;

/* create an event call channel for user requests (quit condition) */

      call cr_event_chan (tolts_info.quith_event, "1"b, tolts_alrm_util_$quit,
       addr (data), quith_prior, error);
      if error ^= 0 then do;				/* trouble creating event call channel... */
         a_error = error;				/* copy error code */
         call clean_up;				/* go delete event channels already created */
         return;					/* and return */
      end;
%page;

/* create an event call channel for gewake events */

      call cr_event_chan (tolts_info.gewake_event, "1"b, tolts_alrm_util_$gewake,
       addr (data), gewake_prior, error);
      if error ^= 0 then do;				/* trouble creating event call channel... */
         a_error = error;				/* copy error code */
         call clean_up;				/* go delete event channels already created */
         return;					/* and return */
      end;

/* create a "fast" event wait channel for waking up the dispatcher */

      call hcs_$assign_channel (tolts_info.wait_list.wait_event_id (1), error);
      if error ^= 0 then do;				/* trouble creating event wait channel... */
         a_error = error;				/* copy error code */
         call clean_up;				/* go delete event channels already created */
         return;					/* and return */
      end;


/* create an event-wait channel for dial_manger */
      if exec = "colt" then do;
         call ipc_$create_ev_chn (tolts_info.dm_event, code);
         if code ^= 0 then do;
	  a_error = code;
	  call com_err_ (code, pname, "creating an event channel");
	  call clean_up;
         end;

         call hcs_$initiate (sc_dir, "cdt", "", 0, 1, cdtp, code); /* initiate cdt seg */
         if cdtp = null then do;			/* if we can't initiate tell user */
	  call com_err_ (code, " Tolts", "attempting to initiate ^a>cdt", sc_dir);
         end;
         cdtptr = cdtp;
      end;
      return;
%page;

/* cr_event_chan - external entry to create ipc wait or call channels */

cr_event_chan: entry (event_ch, call, call_entry, odp, prior, a_err);

      a_err = 0;					/* preset good return code */

      call ipc_$create_ev_chn (event_ch, code);		/* create requested event channel */
      if code ^= 0 then do;				/* error creating event channel */
         a_err = code;				/* copy return code */
         call com_err_ (code, pname, "creating event channel");
         return;
      end;
      if call then do;				/* if user wants an event call channel */
         call ipc_$decl_ev_call_chn (event_ch, call_entry, odp, prior, code); /* change wait into call chan */
         if code ^= 0 then do;			/* error */
	  a_err = code;				/* copy return error code */
	  call com_err_ (code, pname, "changing wait channel into call channel");
	  return;
         end;
         call ipc_$set_call_prior (code);		/* set call channel with priority over wait channel */
         if code ^= 0 then do;			/* error */
	  a_err = code;				/* copy error code */
	  call com_err_ (code, pname, "setting call channels with priority over wait channels");
	  return;
         end;
      end;
      return;					/* return with no error */
%page;

/* clean_up - external entry to delete event channels and <exec>_slave segment */

clean_up: entry;

/* delete event channels if they exist */

      if tolts_info.dm_event ^= 0 then
         call ipc_$delete_ev_chn (tolts_info.dm_event, code); /* if dial_manager event channel $delete it */
      if tolts_infop ^= null then do;			/* if our info seg exists */
         if tolts_info.wait_list.wait_event_id (1) ^= 0 then/* if event channel exists */
	  call ipc_$delete_ev_chn (tolts_info.wait_list.wait_event_id (1), code);
         if tolts_info.tty_issue_event ^= 0 then		/* if event channel exists */
	  call ipc_$delete_ev_chn (tolts_info.tty_issue_event, code);
         if tolts_info.quith_event ^= 0 then		/* if event channel exists */
	  call ipc_$delete_ev_chn (tolts_info.quith_event, code);
         if tolts_info.gewake_event ^= 0 then		/* if event channel exists */
	  call ipc_$delete_ev_chn (tolts_info.gewake_event, code);
         if tolts_info.tty_ccc_event ^= 0 then		/* if event channel exists */
	  call ipc_$delete_ev_chn (tolts_info.tty_ccc_event, code);
         if tolts_info.tty_display_event ^= 0 then	/* if event channel exists */
	  call ipc_$delete_ev_chn (tolts_info.tty_display_event, code);
         do i = lbound (tolts_info.pages, 1) to hbound (tolts_info.pages, 1);
	  if pages (i).in_use then do;
	     if pages (i).mca_ioi_idx ^= 0 then do;
	        call mca_$detach_mca (pages (i).mca_ioi_idx, 0);
	        pages (i).mca_ioi_idx = 0;
	     end;
	  end;
         end;


         if tolts_info.execp ^= null then		/* if temporary segment exists */
	  call release_temp_segment_ (tolts_info.exec || "_slave", execp, code); /* release temp seg */
         if tolts_info.df_iocbp ^= null then do;		/* detach deck file if attached */
	  call iox_$close (tolts_info.df_iocbp, code);
	  call iox_$detach_iocb (tolts_info.df_iocbp, code);
	  tolts_info.df_iocbp = null;
         end;
         call release_temp_segment_ ("tolts_info", tolts_infop, code); /* release our info seg */
      end;
      if old_mme1 ^= null then			/* if  static handler is set... */
         call sct_manager_$set (mme1_sct_index, old_mme1, error); /* reset it */
      return;
%page;
/* gc_tod - entry to compute gcos time of day (in 1/64th milliseconds since midnight */

gc_tod: entry (g_time);

get_delta:
      delta = clock () - tolts_info.micro_time;		/* get delta usecs since midnight */
      if delta > sec_per_day then do;			/* check for day rollover (86400000000 usec/day) */
         call init_time (error);			/* go reinitialize clock time and date */
         go to get_delta;
      end;
      g_time = bit (multiply (delta, .064, 36, 0), 36);
      return;

/* init_time - subroutine to compute the clock time at midnight and the current date and save in tolts_info */

init_time: proc (code);

dcl  code fixed bin (35);

      call date_time_ (clock (), date_str);		/* get current date in form for convert_date_to_binary_ */
      call convert_date_to_binary_ (date_str || " 0000.001", tolts_info.micro_time, code);
      call tolts_alm_util_$ascii_to_bcd_ (date (), gc_date);
      tolts_info.gc_date = gc_date;
   end init_time;
%page;
%include tolts_info;
%include static_handlers;
%include cdt;
%include author_dcl;
   end tolts_init_;




		    tolts_io_int_.pl1               12/09/86  1539.4rew 12/09/86  1520.9      222093



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* Original coding by J. K. Rhodes 4Q/77
   Modified by J. A. Bush 78/9/25 to conform to Multics programming standards
   Modified by J. A. Bush 79/02/28 to handle ITR and MDR I/O interrupts
   Modified by G. Haney & R. Fakoury 80/03/24 to treat mtar i/o as polts i/o with no special modes,
   and to handle the second device alocation.
   Modified by R. Fakoury 80/06/03 to reverse the data and status store sequence for polts disk io security
   (iontp string used with finial iotd to status  words)
   Modified 07/30/80 by R. Fakoury to handle a dcw tally of zero and a dcw residue correctly.
   Modified 9/30/82 by R. Fakoury to change an illegal zero dcw to a valid do nothing dcw.
   Modified 12/83 by R. Fakoury to support hypercannel interrupts.
*/




/****^  HISTORY COMMENTS:
  1) change(85-02-01,Fakoury), approve(86-08-21,MCR7514),
     audit(86-11-25,Martinson), install(86-12-04,MR12.0-1235):
     to implement the test nio request
     to implement extended status store,
     to fix a bug handling itr special interrupts for a suspend channel,
     to add changes for responder interrupts.
                                                   END HISTORY COMMENTS */





/* tolts_io_int_ - I/O interrupt processor for POLTS and MOLTS */


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
tolts_io_int_: proc (event_ptr);


/*  External entries */

dcl  com_err_ entry () options (variable);
dcl  com_err_$convert_status_code_ entry (fixed bin (35), char (*), char (*));
dcl  free_area area based (get_system_free_area_ ());
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$wakeup entry (bit (36) aligned,
      fixed bin (71), ptr, fixed bin (35));		/* arg 3 is suppose to be fixed bin (71) */
dcl  ioi_$connect_pcw entry (fixed bin (12), fixed bin (18), bit (36) aligned, fixed bin (35));
dcl  ioi_$get_detailed_status entry (fixed bin (12), bit (1) aligned, bit (*), fixed bin (35));
dcl  ioi_$release_devices entry (fixed bin (12), fixed bin (35));
dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl  mca_$process_io_event entry (fixed bin, ptr, ptr, fixed bin (35));
dcl  rcp_$check_attach entry (bit (36) aligned, ptr, char (*), fixed bin (12), fixed bin (19) aligned,
      fixed bin (71) aligned, fixed bin, fixed bin (35));
dcl  terminate_process_ entry (char (*), ptr);
dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
dcl  tolts_alm_util_$enter_ccc_req_ entry (ptr, bit (36));
dcl  tolts_init_$gc_tod entry (bit (36));
dcl  tolts_qttyio_$rs entry options (variable);

/* Structures */

dcl  detailed_status bit (288) based;

dcl  1 event_info based (event_ptr),
       2 causing_event fixed bin (71),
       2 message,					/* event message */
         (3 pad1 bit (15),
         3 lv fixed bin (3) unsigned,			/* interrupt level */
         3 pad2 bit (18),
         3 istat bit (36)) unaligned,			/* first word of iom status (or special status) */
       2 sender bit (36),
       2 origin bit (36),				/*  upper 18 bits = signal, lower 18 bits = ring */
       2 in_data_pointer ptr;

dcl  1 fatal_desc aligned,
       2 version fixed bin,
       2 fatal_code fixed bin (35);

dcl  workspace_move char (c_len * 4) based (mvp);		/* move data as char string for effiency */

/* Builtins, Constants, and Static */

dcl  (addr, addrel, bin, bit, fixed, hbound, ptr, rel, string, substr, unspec) builtin;
dcl  (bufp, event_ptr, mvp, wakeup_ptr) ptr;
dcl  code fixed bin (35);
dcl  (c_len, i) fixed bin, error fixed bin (35), stata fixed bin (18);
dcl  (found, continue, read) bit (1);
dcl  g_time bit (36);
dcl  longinfo char (100), shortinfo char (8);
%page;
      io_info_ptr = in_data_pointer;			/* get io_info_ptr from event info */
      if ^io_info.io_in_progress then do;		/* no interrupt expected, lets see if */
         if ^io_info.allocated & io_info.alloc_wait then do;/* allocation waiting, check RCP */

	  if io_info.io_type = mca_io_type then do;
	     allocate mca_area in (free_area) set (mca_area_ptr);
	     call mca_$process_io_event (io_info.mca_ioi_idx, addr (event_info), addr (mca_area), io_info.attach_err);
	     io_info.mca_attach_state = mca_area.mca_attach_state;
	     if io_info.mca_attach_state = MCA_ATTACHING then call signal;
	  end;
	  else if io_info.p_att & ^io_info.p2_att
	   & (io_info.io_type = mdr_io_type
	   | io_info.io_type = mtar_io_type) then	/* if second attach */
	     call rcp_$check_attach (io_info.alt_rcp_id, addr (io_info.alt_rcp_area (1)),
	      longinfo, io_info.alt_device_index, tolts_info.max_wks_sz,
	      tolts_info.max_to, io_info.rcp_state, io_info.attach_err);

	  else call rcp_$check_attach (io_info.rcp_id, addr (io_info.rcp_area (1)),
	        longinfo, io_info.device_index, tolts_info.max_wks_sz, tolts_info.max_to,
	        io_info.rcp_state, io_info.attach_err);

	  if (io_info.io_type ^= mca_io_type
	   & io_info.rcp_state = 0)			/* or attach done */
	   | (io_info.io_type = mca_io_type
	   & io_info.mca_attach_state = MCA_ATTACHED)
	   | io_info.attach_err ^= 0 then do;		/* if attach err */
	     io_info.alloc_wait = "0"b;		/* turn off allocation wait flag */
	     if tolts_info.glob_int_cnt ^= 0 then
	        tolts_info.glob_int_cnt = tolts_info.glob_int_cnt - 1; /* decrement global IO count */
	     call queue_and_signal;			/* go queue up ccc request and issue wakeup */
	  end;
	  if io_info.io_type = mca_io_type then
	     free mca_area_ptr -> mca_area in (free_area);
         end;
         return;					/* and return */
      end;





      if tolts_info.glob_int_cnt ^= 0 then
         tolts_info.glob_int_cnt = tolts_info.glob_int_cnt - 1; /* decrement global IO count */
      if io_info.io_type = mca_io_type then		/* if mca test */
         mca_work_space_ptr = io_info.workspace_ptr;
      if io_info.io_type = rspd_io_type			/* if rspd test */
       then tolts_rspd_wksp = io_info.tolts_rspd_wksp;

      else ioi_wksp = io_info.workspace_ptr;
      go to ilv (event_info.message.lv);		/* process correct interrupt level */

ilv (1):						/* Level 1, IOM fault */
ilv (0): ilv (2): ilv (4): ilv (6):			/* Levels 0, 2, 4 & 6, Illegal */
      call tolts_qttyio_$rs (0, "^as: ^[IOM fault^s^;Illegal Interrupt level - ^d^], IOM status = ^12.3b ^12.3b",
       tolts_info.exec, (tolts_workspace.status.level = 1), tolts_workspace.status.level,
       substr (tolts_workspace.iom_status, 1, 36), substr (tolts_workspace.iom_status, 37, 36));

ilv (5):						/* Level 5, marker interrupt (not expected) */
      if io_info.io_type ^= firm_ld_io_type then do;	/* if not loading firmware... */
         call move_status;				/* go move status to test page */
         status.channel_stat, status.central_stat = "7"b3;	/* phony up iom status */
         status.initiate = "1"b;			/* set initiate */
         status.soft = "01"b;				/* set "timeout" */
         call queue_and_signal;			/* go enter courtesy call request */
      end;
      else call signal;				/* if loading firmware, just wakeup dispatcher */
      return;

ilv (3):						/* Level 3, terminate interrupt */
      if io_info.io_type = mca_io_type then call mca_term;
      else if io_info.io_type = rspd_io_type then call rspd_term;
      else do;
         statp = addr (tolts_workspace.iom_status);	/* set ptr to examine status  */
         if io_info.io_type = polt_io_type		/* if polt io type  terminate interrupt */
	| io_info.io_type = mtar_io_type		/* or mtar, treat like Polts */
	| io_info.io_type = mtc_io_type		/* or mtc, treat like Polts */
	| io_info.io_type = mtg_io_type		/* or mtg, treat like Polts */
	| io_info.io_type = mdc_io_type then		/* or mtg, treat like Polts */
	  call polt_term;

         else if io_info.io_type = itr_io_type		/* if itr io type terminate interrupt */
	| io_info.io_type = mhp_io_type then		/* or mhp io_type then treat like itr */
	  call itr_term;

         else if io_info.io_type = mdr_io_type then	/* if mdr terminate interrupt */
	  call mdr_term;

         else if io_info.io_type = firm_ld_io_type then
	  call signal;				/* if terminate interrupt while loading firmware */
      end;
      return;

ilv (7):						/* Level 7, special interrupt, get special status */
      if io_info.io_type = rspd_io_type then call rspd_spec;

      else do;
         io_info.sp_status = event_info.message.istat;	/* extract special status from event message */
         io_info.sp_flag = "1"b;			/* set availablity flag */
         if io_info.io_type = polt_io_type		/* if polts special interrupt */
	| io_info.io_type = mtc_io_type
	| io_info.io_type = mtg_io_type
	| io_info.io_type = mdc_io_type then
	  call polt_spec;

         else if io_info.io_type = itr_io_type		/* if itr special interrupt */
	| io_info.io_type = mhp_io_type then
	  call itr_spec;

         else if io_info.io_type = mdr_io_type then
	  call mdr_spec;				/* if mdr special interrupt */

         else if io_info.io_type = firm_ld_io_type then
	  call signal;				/* if special interrupt while loading firmware */
      end;

      return;

%page;

/* check_copy - internal procedure to copy data back to test page if reading */

check_copy: proc;

      if status.r then do;				/* if reading copy data, otherwise don't */
         read = "1"b;				/* set read flag */
         idcwp = addr (tolts_workspace.p_idcw);		/* get ptr to primary idcw */
         if idcw.control = "10"b then			/* if continue but set */
	  continue = "1"b;				/* set flag */
         else continue = "0"b;			/* otherwise stop at first iotd */
         found = "0"b;				/* reset terminate condition */
         do i = 1 to hbound (io_info.dcw_list, 1) while (^found); /* go through dcw list */
	  dcwp = addr (io_info.dcw_list (i));		/* set test page dcw ptr */
	  if dcw.char_pos = "7"b3 then do;		/* if idcw */
	     if dcwp -> idcw.control = "10"b then	/* if idcw continue bit set */
	        continue = "1"b;			/* set continue flag */
	     else continue = "0"b;			/* otherwise reset it */
	     if substr (dcwp -> idcw.command, 3, 1) = "0"b then /* if read operation */
	        read = "1"b;			/* set read flag */
	     else read = "0"b;			/* otherwise reset it */
	  end;
	  else if read & dcw.type ^= "11"b then do;	/* if read and not iontp */
	     if dcw.type = "00"b then			/* if iotd */
	        if ^continue then			/* and continue flag not set */
		 found = "1"b;			/* set terminate condition */
	     tdcwp = addr (tolts_workspace.dcw_list (i)); /* set workspace dcw ptr */
	     mvp = addrel (execp, dcw.address);		/* get ptr to data to move */
	     c_len = bin (dcw.tally);			/* get length of data */
	     if c_len = 0 then c_len = 4096;		/* if tally is zero force tally equal to 4096 */
	     if string (dcw) = "0"b then do;		/* if zero dcw then  fake out dcw */
	        c_len = 1;				/* set tally = 1 */
	        mvp = addrel (execp, io_info.status_add); /* set mvp to status_word */
	     end;
	     if found & status.tally ^= "0000"b3 then	/* if last dcw and tally residue */
	        c_len = c_len - bin (status.tally);	/* subtract tally residue */
	     if c_len > 0 then do;			/* if <0 then error and skip */
	        bufp = ptr (ioi_wksp, tdcwp -> dcw.address); /* get ptr to workspace buffer address */
	        workspace_move = bufp -> workspace_move;	/* and move it */
	     end;
	  end;
         end;
      end;
   end check_copy;
%page;

/* itr_spec - interrupt processor for Molt/ITR special interrupts */

itr_spec: proc;

      statp = addrel (execp, io_info.status_add);		/* get ptr to test page status storage */
      string (special_status) = io_info.sp_status;
      if io_info.io_type = mhp_io_type then		/* if hyper leave staus */
         substr (unspec (special_status), 1, 1) = "0"b;	/* just zero the first bit */
      else substr (unspec (special_status), 1, 9) = "0"b;	/* else zero first 9 bits */
      if io_info.release_chan then			/* if special from a release cmd */
         call release_dev;				/* go call ioi_$release_devices */
      else if ^io_info.suspend_chan then
         call queue_and_signal;			/* go enter courtesy call request */

   end itr_spec;

/* itr_term - interrupt processor for Molt/ITR terminate interrupts */

itr_term: proc;

      if tolts_workspace.status.timeout then do;		/* if ioi timeout */
         if ^io_info.to_no_cc then do;			/* if not executing IPCW */
	  statp = addrel (execp, io_info.status_add);	/* get ptr to test page status storage */
	  substr (unspec (status), 1, 18) = "510006"b3;	/* set time out status */
	  call queue_and_signal;			/* go queue up cc request */
         end;
         else io_info.to_no_cc = "0"b;			/* reset flag if set */
      end;
      else if status.power then do;			/* if power off status */
         if io_info.suspend_chan then			/* if this is from suspend channel */
	  io_info.suspend_chan = "0"b;		/* this is the only int we will get */
         call move_status;				/* move status to test page */
         call queue_and_signal;			/* go queue up cc request */
      end;
      else if ^io_info.ignore_term then do;		/* if we are not ignoring terminates */
         call check_copy;				/* go copy data if reading */
         call move_status;				/* move the status to test page */
         call queue_and_signal;			/* queue up cc request */
      end;

   end itr_term;

%page;

/* mca_term - interrupt processor for Molt/MCA terminate interrupts */

mca_term: proc;

      allocate mca_area in (free_area) set (mca_area_ptr);
      call mca_$process_io_event (io_info.mca_ioi_idx, addr (event_info), addr (mca_area), error);
      if error ^= 0 then do;
         if ^substr (unspec (error), 1, 1) then do;
	  call com_err_ (error, "tolts_io_int_", "fatal error, terminating process");
	  fatal_desc.version = 0;
	  fatal_desc.fatal_code = error;		/* copy error code */
	  call terminate_process_ ("fatal_error", addr (fatal_desc));
         end;
      end;
      if mca_work_space.list_of_dcw.idcw1.command = "03"b3 then do;
         data_header_ptr = addr (mca_work_space.data_header_1);
         io_param_blk_ptr = addr (mca_work_space.data_header_1.io_param_blk);
         data_size_1 = fixed (io_parameter_block.source_len_msb || io_parameter_block.source_len_lsb, 16);
         dcwp = addr (io_info.dcw_list (2));
         bufp = addr (mca_work_space.data_header_1);
      end;
      else do;
         io_param_blk_ptr = addr (mca_work_space.data_header_1.io_param_blk);
         data_size_1 = fixed (io_parameter_block.dest_len_msb || io_parameter_block.dest_len_lsb, 16);
         dcwp = addr (io_info.dcw_list (4));
         bufp = addr (mca_work_space.data_header_2);
      end;
      data_header_ptr = addr (mca_work_space.data_header_2);
      io_param_blk_ptr = addr (mca_work_space.data_header_2.io_param_blk);
      data_size_2 = fixed (io_parameter_block.source_len_msb || io_parameter_block.source_len_lsb, 16);
      if string (dcw) = "0"b then do;
         c_len = 1;
         mvp = addrel (execp, io_info.status_add);
      end;
      else do;
         mvp = addrel (execp, dcw.address);
         if dcw.tally = "0"b then c_len = 4096;
         else c_len = bin (dcw.tally);
      end;
      workspace_move = bufp -> workspace_move;
      statp = addrel (execp, io_info.status_add);
      unspec (status) = mca_area.mca_status;
      free mca_area_ptr -> mca_area in (free_area);
      call queue_and_signal;
   end mca_term;
%page;

/* mdr_spec - interrupt processor for Molt/MDR special interrupts */

mdr_spec: proc;

      statp = addrel (execp, io_info.status_add);		/* get ptr to test page status storage */
      string (special_status) = io_info.sp_status;
      if io_info.io_type ^= mhp_io_type then
         substr (unspec (special_status), 1, 9) = "0"b;
      if io_info.suspend_chan then			/* if this is a special from suspend cmd */
         io_info.suspend_chan = "0"b;			/* reset flag */
      if io_info.release_chan then			/* if special from a release cmd */
         call release_dev;				/* go call ioi_$release_devices */

   end mdr_spec;

/* mdr_term - interrupt processor for Molt/MDR terminate interrupts */

mdr_term: proc;

      if tolts_workspace.timeout | status.power | status.major | status.sub |
       status.channel_stat | status.central_stat then do;	/* debug trap */
         c_len = 0;
      end;
      if tolts_workspace.status.timeout then do;		/* if ioi timeout */
         statp = addrel (execp, io_info.status_add);	/* get ptr to test page status storage */
         substr (unspec (status), 1, 18) = "510006"b3;	/* set time out status */
         call queue_and_signal;			/* go queue up cc request */
      end;
      else if status.power then do;			/* if power off status */
         call move_status;				/* move status to test page */
         call queue_and_signal;			/* go queue up cc request */
      end;
      else do;					/* good terminate */

         call check_copy;				/* go copy data if reading */
         call move_status;				/* move iom status to test page */
         call queue_and_signal;			/* go enter courtesy call request */
         if io_info.release_chan then			/* if special from a release cmd */
	  call release_dev;				/* go call ioi_$release_devices */
      end;

   end mdr_term;

%page;

/* move_status - internal procedure to move term status to test page and correct dcw residue address */

move_status: proc;

      if io_info.ext_status_add ^= 0 then
         call ioi_$get_detailed_status (io_info.device_index, "1"b,
	addrel (execp, io_info.ext_status_add) -> detailed_status, code);
      statp = addrel (execp, io_info.status_add);		/* get ptr to test page status storage */
      string (status) = tolts_workspace.iom_status;	/* move the status to the test page */
      if substr (tolts_workspace.iom_status, 37, 36) = "777777777777"b3 then /* if garbage */
         substr (string (status), 37, 36) = "0"b;		/* set to zero */
      else do;					/* otherwise move it */
         i = bin (rel (addr (tolts_workspace.dcw_list (1)))); /* get offset of dcw list */
         if tolts_workspace.offset >= i then do;		/* if we have processed dcws */
	  i = tolts_workspace.offset - i + 1;		/* get array index of last dcw */
	  dcwp = addr (io_info.dcw_list (i));		/* get ptr to unaltered dcw */
	  stata = bin (dcw.address) + bin (dcw.tally);	/* add address and tally */
	  stata = stata - bin (status.tally);		/* and subtract tally residue */
	  status.address = bit (stata);		/* correct test page dcw residue add */
         end;
      end;
   end move_status;

%page;
/* polt_spec - interrupt processor for Polt special interrupts */

polt_spec: proc;

      if io_info.rew_wait then do;			/* special expected? ignore if not */
         io_info.rew_wait = "0"b;			/* yes, reset flag */

/* reconnect original dcw list, this will occur if device was busy before */

         call ioi_$connect_pcw (io_info.device_index, io_info.tio_off, io_info.pcwa, error);
         if error ^= 0 then do;			/* error on connect */
	  call com_err_$convert_status_code_ (error, shortinfo, longinfo);
	  call tolts_qttyio_$rs (0, "^as: Error on connect after special interrupt:^/^a",
	   tolts_info.exec, longinfo);
	  tolts_info.special_fault = "1"b;		/* set special int fault flag */
	  call signal;				/* wakeup dispatcher, but do not queue up cc */
         end;
      end;

   end polt_spec;

/* polt_term - interrupt processor for Polt terminate interrupts */

polt_term: proc;

      if status.major | status.channel_stat | status.central_stat then do; /* debug trap */
         c_len = 0;
      end;
      if tolts_workspace.status.timeout then do;		/* if ioi timeout */
         statp = addrel (execp, io_info.status_add);	/* get ptr to test page status storage */
         unspec (status) = "0"b;			/* clear status first */
         substr (unspec (status), 1, 18) = "510006"b3;	/* set time out status */
         call queue_and_signal;			/* go queue up cc request */
      end;
      else if status.major = "0001"b & io_info.rcp_name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then /* else if tape device and */
         io_info.rew_wait = "1"b;			/* device busy, wait for rewind complete */
      else do;					/* normal terminate */

         call check_copy;				/* go copy data if reading */
         call move_status;				/* move iom status to test page */
         call queue_and_signal;			/* go enter courtesy call request */
      end;

   end polt_term;

%page;

/* queue_and_signal - subroutine to enter cc request for io completion (or alloc wait completion) and wakeup the dispatcher */

queue_and_signal: proc;

      call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
       string (io_info.icivlu));			/* enter ccc request */

signal: entry;					/* wakeup the dispatcher */
      io_info.io_in_progress = "0"b;			/* reset io in progress flag */
      wakeup_ptr = in_data_pointer;
      call tolts_init_$gc_tod (g_time);			/* get current time */
      io_info.int_time = bin (g_time, 35);		/* set current interrupt time */
      io_info.chan_time = io_info.chan_time + (io_info.int_time - io_info.con_time); /* delta chan time */
      if tolts_info.gewake_active then do;		/* if gewake alarm set */
         call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* reset it */
         call ipc_$drain_chn (tolts_info.gewake_event, error); /* make sure no alarms queue up */
         tolts_info.gewake_active = "0"b;		/* reset flag */
      end;
      call hcs_$wakeup (tolts_info.process, tolts_info.wait_list.wait_event_id (1), wakeup_ptr, error);
      if error ^= 0 then do;				/* error on wakeup, terminate proc */
         call com_err_ (error, "tolts_io_int_", "fatal error, terminating process");
         fatal_desc.version = 0;
         fatal_desc.fatal_code = error;			/* copy error code */
         call terminate_process_ ("fatal_error", addr (fatal_desc));
      end;
   end queue_and_signal;


/* release_dev - internal procedure to call ioi_$release_devices and reset release_chan flag */

release_dev: proc;

      io_info.release_chan = "0"b;			/* reset flag */
      call ioi_$release_devices (io_info.device_index, error); /* let ioi have a turn */
      if error ^= 0 then do;				/* error, abort */
         call com_err_$convert_status_code_ (error, shortinfo, longinfo);
         call tolts_qttyio_$rs (0, "^as: Error from ioi_$release_devices:^/^a", tolts_info.exec, longinfo);
         tolts_info.special_fault = "1"b;		/* set special int fault flag */
         call signal;				/* wakeup dispatcher, but do not queue up cc */
      end;
   end release_dev;


/* rspd_spec - interrupt processor for Colt/RSPD special interrupts */

rspd_spec: proc;

      tolts_rspd_workspace.mailbox.lvl7 =
       tolts_rspd_workspace.mailbox.lvl7 + 1;		/* bump spec int count */
      direct_channel_pcw_ptr = addr (io_info.pcwa);
      tolts_rspd_workspace.mailbox.status_word = event_info.message.istat;

      if direct_channel_pcw.operation = "75"b3 then do;	/* if read pcw move data */
         c_len = tolts_rspd_workspace.tcw.host_word_count;
         bufp = addr (tolts_rspd_workspace.data_buf);
         mvp = addrel (execp, direct_channel_pcw.tcw_address + 1);
         workspace_move = bufp -> workspace_move;
      end;
      call signal;
   end rspd_spec;


/* rspd_term - interrupt processor for Colt/RSPD terminate interrupts */

rspd_term: proc;
      tolts_rspd_workspace.mailbox.lvl3 =
       tolts_rspd_workspace.mailbox.lvl3 + 1;		/* inc term int count */
      direct_channel_pcw_ptr = addr (io_info.pcwa);
      tolts_rspd_workspace.mailbox.status_word = event_info.message.istat;
      if direct_channel_pcw.operation = "75"b3 then do;	/* if read pcw read data */
         c_len = tolts_rspd_workspace.tcw.host_word_count;
         bufp = addr (tolts_rspd_workspace.data_buf);
         mvp = addrel (execp, direct_channel_pcw.tcw_address + 1);
         workspace_move = bufp -> workspace_move;
      end;
      call signal;
   end rspd_term;


%page;
%include iom_stat;
%page;
%include mca_area;
%page;
%include mca_data;
%page;
%include mca_data_area;
%page;
%include rcp_resource_types;
%page;
%include tolts_info;
%page;
%include tolts_rspd_workspace;
%page;
%include tolts_workspace;



   end tolts_io_int_;




		    tolts_load_firmware_.pl1        12/09/86  1539.4rew 12/09/86  1520.9      177462



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/*   Initial coding 79/03/05 By J. A. Bush
   Modified 10/84 to add delay for a dc_reset of the DAU.
*/




/****^  HISTORY COMMENTS:
  1) change(85-08-01,Fakoury), approve(86-08-22,MCR7514),
     audit(86-11-25,Martinson), install(86-12-04,MR12.0-1235):
     to correct a stringrange error.
                                                   END HISTORY COMMENTS */





/* tolts_load_firmware_ - subroutine to load mpc firmware for all mpc types,
   after ITRs have been run on that mpc, and is called from MME RELEAS   */


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
tolts_load_firmware_: proc (px, a_error);


/* Entry parameters */

dcl  px fixed bin;					/* test page index */
dcl  a_error fixed bin (35);				/* return error code */

/* External entries */

dcl  ioi_$connect_pcw entry (fixed bin (12), fixed bin (18), bit (36), fixed bin (35));
dcl  ioi_$release_devices entry (fixed bin (12), fixed bin (35));
dcl  ioi_$workspace entry (fixed bin (12), ptr, fixed bin, fixed bin (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl  (ioa_$rsnnl, tolts_qttyio_$rs, opr_query_) entry options (variable);
dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));
dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
dcl  tolts_util_$search entry (ptr, char (32), ptr, fixed bin, fixed bin (35));
dcl  gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35));
dcl  tolts_qttyio_ entry (char (*), fixed bin);
dcl  com_err_$convert_status_code_ entry (fixed bin (35), char (*), char (*));

/* Automatic */

dcl  (catx, cxs, i, j, l, c_len, css, csl, rws, rwl) fixed bin;
dcl  tio_off fixed bin (18);
dcl  error fixed bin (35);
dcl  (err, term) bit (1);
dcl  (t_ptr, l_ptr, idbp, top) ptr;
dcl  shortinfo char (8);
dcl  ov_name char (17);
dcl  longinfo char (100);

/* structures and based variables */

dcl  1 event_out static,
       2 causing_event fixed bin (71),
       2 message fixed bin (71),
       2 sender bit (36),
       2 origin,
         3 signal bit (18) unaligned,
         3 ring bit (18) unaligned,
       2 in_data_pointer ptr;

dcl  1 cata based (io_info.catp) aligned,		/* template for deckfile catalog */
       2 n fixed bin,				/* number of entries */
       2 key (1 refer (cata.n)) char (24);		/* array of key names */

dcl  1 id_blk based (idbp) aligned,			/* template for an mpc deck id block */
       (2 id_name bit (36),				/* BCD id name */
       2 rev_level bit (36),				/* BCD revision */
       2 dk_purpose bit (36),				/* BCD deck purpose */
       2 pad1 bit (36),
       2 rw_start fixed bin (18) unsigned,		/* offset of read/write overlay */
       2 pad2 bit (18),
       2 hx_cs_st fixed bin (18) unsigned,		/* rel. start of control store in hex words */
       2 hx_rw_st fixed bin (18) unsigned,		/* rel. start of read/write overlay in hex words */
       2 pad3 (3) bit (36),
       2 mpcbot bit (36)) unaligned;			/* = "MPCBOT" in BCD */

dcl  buffer (fixed (gload_data.text_len)) bit (36) based (top); /* for moving data to ioi buffer */
dcl  f_wd (10240) bit (36) based (l_ptr);		/* for moving data from temp buffer */

/* constants */

dcl  (addr, addrel, bin, bit, fixed, index, rel, string, substr) builtin;
dcl  error_table_$action_not_performed fixed bin (35) ext;
dcl  ipcw bit (36) int static options (constant) init ("000000770000"b3);
dcl  pcwa bit (36) int static options (constant) init ("000000700000"b3);
%page;
      a_error = 0;					/* preset return code to 0 */
      io_info_ptr = addr (pages (px));			/* get ptr to this test page */
      io_info.io_type = 4;				/* set type for interrupt processor */
      ioi_wksp = io_info.workspace_ptr;			/* get ptr to our workspace */
      tio_off = fixed (rel (addr (tolts_workspace.p_idcw)));/* get buffer offset for ioi */
      l_ptr = addr (tolts_info.firm_buf);		/* place to temp load firmware */
      top = addr (tolts_workspace.data_buf);		/* set ptr to move firmware */
      do catx = 1 to cata.n while (index (cata.key (catx), ".") < 6); /* find first fw module */
      end;
      call fw_load;					/* go load deck in temp buffer */
      if error ^= 0 then do;				/* if some problem, return */
err_1:   a_error = error;
         return;
      end;
      call dc_reset;				/* go send initialize pcw to mpc */
      if error ^= 0 then go to err_1;
      call copy_cs (0, err);				/* copy control store overlay */
      if err then do;				/* if any error ocurred */
err_2:   a_error = error_table_$action_not_performed;	/* set an apropriate error code */
         return;
      end;
      call run_dcw;					/* execute dcw list */
      if error ^= 0 then go to err_1;
      call copy_rw (err);				/* copy read/write overlay */
      if err then go to err_2;
      call run_dcw;					/* execute dcw list */
      if error ^= 0 then go to err_1;			/* get out on error */
      call fw_load_mess;				/* let user and operator know what has been loaded */
      if io_info.mpc_dev_cnt ^= 0 then do;		/* if urcmpc, load device overlays  */
         cxs = catx + 1;				/* save catalog index + 1 */
         do l = 1 to io_info.mpc_dev_cnt;		/* load each overlay type */
	  term = "0"b;				/* reset terminate condition */
	  do catx = cxs to cata.n while (^term);	/* find each key */
	     if substr (cata.key (catx), 15, 4) = io_info.dev_firm (l).edit_name then do; /* found it */
	        term = "1"b;			/* set terminate condition */
	        call fw_load;			/* go copy firmware overlay into temp storage */
	        if error ^= 0 then go to err_1;
	        call copy_cs (1, err);		/* copy control store (offset by 1 word */
	        if err then go to err_2;
	        idcw.command = "36"b3;		/* set overlay command */
	        idcw.device = "01"b3;			/* device code of 1 for device overlays */
	        idcw.chan_cmd = "40"b3;		/* special controller command */
	        buffer (1) = io_info.dev_firm (l).mask;	/* set in port mask */
	        call run_dcw;			/* execute overlay */
	        if error ^= 0 then go to err_1;
	        call fw_load_mess;			/* let user and operator know what has been loaded */
	     end;
	  end;
         end;
      end;
      call ioi_$release_devices (io_info.device_index, error); /* can let ioi do other io now */
      if error ^= 0 then do;				/* can't win */
         call output_status_code (error, "calling ioi_$release_devices");
         go to err_1;
      end;
      io_info.chan_suspended = "0"b;			/* channel is no longer suspended */
      return;
%page;

/* fw_load - internal procedure to find requested deck in deckfile and load core image */

fw_load: proc;

/* find firmware deck in the deckfile */

      call tolts_util_$search (tolts_info.df_iocbp, (cata.key (catx)), t_ptr, c_len, error);
      if error ^= 0 then do;				/* if we couldn't find module */
         call output_status_code (error, "searching for " || cata.key (catx));
         return;
      end;

/* now load core image into temp buffer */

      call gload_ (t_ptr, l_ptr, 0, addr (gload_data), error); /* load it */
      if error ^= 0 then do;
         call output_status_code (error, gload_data.diagnostic || " loading module " || cata.key (catx));
         return;					/* and return */
      end;
      idbp = addrel (l_ptr, fixed (gload_data.text_len) - 10); /* get ptr to id blk */
      css = 1;					/* control store starts at 1 */
      rws = id_blk.rw_start;				/* set start of read/write memory */
      if rws = 0 then do;				/* if read/write overlay non-existant... */
         csl = fixed (gload_data.text_len) - 10;		/* set cs length to loaded blk minus id blk */
         rwl = 0;					/* no read/write overlay */
      end;
      else do;
         csl = rws;
         rwl = fixed (gload_data.text_len) - rws - 10;	/* set lengths */
         rws = rws + 1;
      end;

   end fw_load;


/* output_status_code - internal procedure to queue up a status message */

output_status_code: proc (ecode, mess);

dcl  ecode fixed bin (35);
dcl  mess char (*);

      call com_err_$convert_status_code_ (ecode, shortinfo, longinfo);
      call tolts_qttyio_$rs (0, "^as: ^a^/^a", tolts_info.exec, longinfo, mess);
   end output_status_code;
%page;
/* Procedure to dc reset of an mpc by isuing a reset pcw */

dc_reset: proc;

      idcwp = addr (tolts_workspace.p_idcw);		/* Set up IDCW, although it wont be executed */
      string (idcw) = "0"b;
      idcw.code = "7"b3;
      idcw.chan_cmd = "02"b3;

      call ioi_$connect_pcw (io_info.device_index, tio_off, ipcw, error); /* Do connect */
      if error ^= 0 then do;
         call output_status_code (error, "issuing initialize pcw");
         return;
      end;
      tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1;/* increment global IO count */
      io_info.io_in_progress = "1"b;			/* set flag */
      do while (io_info.io_in_progress);		/* make sure we only take interrupt wakeup */
         call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error);
         if error ^= 0 then do;
	  call output_status_code (error, "waiting for ioi timeout from initialize pcw");
	  return;
         end;
      end;
      if tolts_workspace.status.level ^= 3 | ^tolts_workspace.status.timeout then do;
         call tolts_qttyio_$rs (0, "^a No ioi timeout after issuing initialize pcw", io_info.test_hdr);
         error = error_table_$action_not_performed;	/* set phony error */
         return;
      end;

/* Since time out was only simulated by ioi, a real delay must be done to allow the mpc to reset */

      call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* Be sure no alarm already set */
      call ipc_$drain_chn (tolts_info.gewake_event, error); /* In case event occured */
      if error ^= 0 then do;
         call output_status_code (error, "calling ipc_$drain_chn durring dc_reset");
         return;
      end;
      if io_info.cat_name = "itr.msp800" then
         call timer_manager_$alarm_wakeup (20, "11"b, tolts_info.gewake_event); /* Set 1 second timer */
      else call timer_manager_$alarm_wakeup (1, "11"b, tolts_info.gewake_event); /* Set 1 second timer */
      tolts_info.gewake_active = "1"b;			/* set flag */
      do while (tolts_info.gewake_active);		/* make sure we only take alarm wakeup */
         call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); /* Wait for a second */
         if error ^= 0 then do;
	  call output_status_code (error, "waiting for dc_reset");
	  return;
         end;
      end;

   end dc_reset;
%page;
/* run_dcw - subroutine to do the actual I/O */

run_dcw: proc;

      call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error); /* Do connect */
      if error ^= 0 then do;
         call output_status_code (error, "attempting connect");
         return;
      end;
      tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1;/* increment global IO count */
      io_info.io_in_progress = "1"b;			/* set flag */
      do while (io_info.io_in_progress);		/* make sure we only take interrupt wakeup */
         call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error);
         if error ^= 0 then do;
	  call output_status_code (error, "waiting for terminate interrupt");
	  return;
         end;
      end;
      if tolts_workspace.status.level ^= 3 then do;	/* looking for terminate */
         call tolts_qttyio_$rs (0, "^a Unexpected level ^d interrupt while waiting for terminate",
	io_info.test_hdr, tolts_workspace.status.level);
         error = error_table_$action_not_performed;	/* set phony error code */
         return;
      end;
      if tolts_workspace.status.timeout then do;		/* not good */
         call tolts_qttyio_$rs (0, "^a ioi timeout while waiting for terminate", io_info.test_hdr);
         error = error_table_$action_not_performed;	/* set phony error code */
         return;
      end;
      statp = addr (tolts_workspace.status.iom_status);	/* set status ptr */
      if status.power then do;			/* power off status */
         call tolts_qttyio_$rs (0, "^a Unexpected power off status, check MPC",
	io_info.test_hdr);
         error = error_table_$action_not_performed;
         return;
      end;
      if status.major | status.sub | status.channel_stat | status.central_stat then do; /* If any other error */
         call tolts_qttyio_$rs (0, "^a Unexpected IOM status: ^12.3b ^12.3b",
	io_info.test_hdr, substr (tolts_workspace.iom_status, 1, 36),
	substr (tolts_workspace.iom_status, 37, 36));
         error = error_table_$action_not_performed;	/* set phoney error code */
         return;
      end;

   end run_dcw;
%page;
/* copy_cs - subroutine to copy control store overlay from temp buf to ioi workspace */

copy_cs: proc (buf_off, err_bit);

dcl  err_bit bit (1);
dcl  buf_off fixed bin;

      err_bit = "0"b;				/* reset error flag */
      ov_name = "control store";			/* set overlay name */
      call make_dcw ("10"b3, (csl - css + 1) + buf_off, err_bit); /* set up dcw list */
      if ^err_bit then				/* if no error... */
         call copy (css, csl, buf_off, err_bit);		/* go copy the data */

   end copy_cs;

/* copy_rw - subroutine to copy read/write memory overlay from temp buf to ioi workspace */

copy_rw: proc (err_bit);

dcl  err_bit bit (1);

      err_bit = "0"b;				/* reset error flag */
      ov_name = "read/write memory";
      call make_dcw ("11"b3, rwl, err_bit);		/* set up dcw list */
      if ^err_bit then				/* if no error... */
         call copy (rws, rws + rwl - 1, 0, err_bit);	/* go copy the data */

   end copy_rw;

/* fw_load_mess - subroutine to put out message telling the operator and user that firmware has been loaded */

fw_load_mess: proc;

      call ioa_$rsnnl ("^/^a ^as has loaded ^a firmware ^a rev. ^a", longinfo, c_len,
       io_info.test_hdr, tolts_info.exec, substr (cata.key (catx), 8, 6),
       substr (cata.key (catx), 15, 4), substr (cata.key (catx), 20, 2));
      opr_query_info.q_sw = "0"b;			/* we don't want operator response */
      call opr_query_ (addr (opr_query_info), substr (longinfo, 1, c_len)); /* tell operator */
      if ^tolts_info.finish_cond then do;		/* only output message if we still have terminal */
         call tolts_qttyio_ (substr (longinfo, 1, c_len), 0); /* and ourselves what we are loading */
         do while (tolts_info.term_io_req_cnt ^= 0);	/* wait for message to be output */
	  call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); /* Wait for a second */
	  if error ^= 0 then do;
	     call output_status_code (error, "waiting for firmware load message");
	     return;
	  end;
         end;
      end;

   end fw_load_mess;
%page;
/* make_dcw - subroutine to set up dcw list */

make_dcw: proc (op_code, dlen, err_bit);

dcl  op_code bit (6);
dcl  (dlen, dleft, ovh) fixed bin;
dcl  err_bit bit (1);

      ovh = bin (rel (addr (tolts_workspace.data_buf))) + 2;/* compute overhead length of ioi buf */
      idcwp = addr (tolts_workspace.p_idcw);		/* get ptr to primary idcw loc */
      string (idcw) = "0"b;				/* initialize */
      idcw.command = op_code;				/* copy command */
      idcw.code = "7"b3;				/* this must be set for an idcw */
      dcwp = addr (tolts_workspace.dcw_list (1));		/* set up 1st dcw */
      string (dcw) = "0"b;				/* initialize 1st dcw */
      dcw.address = rel (addr (tolts_workspace.data_buf));	/* set dcw address */
      dleft = dlen;					/* start with entire length */
      do while (dleft > 4096);			/* set up as many dcws as neccessary */
         dcw.type = "01"b;				/* set type to iotp */
         dcw.tally = "0000"b3;			/* 0 = tally of 4096 */
         if io_info.cur_wks_sz < dlen + ovh then		/* if our workspace is to small */
	  if tolts_info.max_wks_sz < dlen + ovh then do;	/* and we can't get enough */
	     err_bit = "1"b;			/* set error indicator */
	     call tolts_qttyio_$rs (0, "^a max workspace size of ^d is less than ^a overlay length of ^d",
	      io_info.test_hdr, tolts_info.max_wks_sz, ov_name, dlen);
	     return;				/* return and report error */
	  end;
	  else do;
	     if io_info.cur_wks_sz + 4096 > tolts_info.max_wks_sz then /* if current + 4k is > max */
	        io_info.cur_wks_sz = tolts_info.max_wks_sz; /* set current size to max */
	     else io_info.cur_wks_sz = io_info.cur_wks_sz + 4096; /* increse by 4k */
	     call ioi_$workspace (io_info.device_index, ioi_wksp, io_info.cur_wks_sz, error);
	     if error ^= 0 then do;			/* ioi_ didn't like it */
	        call output_status_code (error, "setting max workspace size");
	        err_bit = "1"b;			/* set error indicator */
	        return;
	     end;
	  end;
         tdcwp = dcwp;				/* save current dcw ptr */
         dcwp = addrel (dcwp, 1);			/* go to next dcw */
         string (dcw) = "0"b;				/* initialize dcw */
         dcw.address = bit (bin (bin (tdcwp -> dcw.address) + 4096, 18));
         dleft = dleft - 4096;			/* decrement data left */
      end;
      dcw.type = "00"b;				/* last dcw is iotd */
      dcw.tally = bit (bin (dleft, 12));		/* set tally */
      tolts_workspace.buf_size = dlen;			/* set buffer size */

   end make_dcw;
%page;
/* This procedure actually copies the firmware data */

copy: proc (start, stop, b_off, err_bit);

dcl  (start, stop, b_off) fixed bin;			/* The range of words to be copied */
dcl  err_bit bit (1);				/* An error code */
dcl  ck_sum fixed bin (35) init (0);			/* To do check sum calculations */
dcl  ck_bit bit (36) based (addr (ck_sum));		/* Another way of looking at ck_sum */

      j = 1 + b_off;				/* start at one plus offset */
      do i = start to stop;				/* Copy it all */
         buffer (j) = f_wd (i);			/* This moves a word */
         if i < stop then do;				/* If not last word, do checksum calc */
	  call ch_add (ck_sum, bin (substr (f_wd (i), 2, 8) || substr (f_wd (i), 11, 8)));
	  call ch_add (ck_sum, bin (substr (f_wd (i), 20, 8) || substr (f_wd (i), 29, 8)));
         end;
         j = j + 1;
      end;

      ck_sum = -ck_sum;				/* Get complement of check sum */

      if "0"b || substr (ck_bit, 21, 8) || "0"b || substr (ck_bit, 29, 8) ^=
       substr (f_wd (stop), 1, 18) then do;
         call tolts_qttyio_$rs (0, "^a check sum error detected in ^a overlay of ^a firmware - ^a",
	io_info.test_hdr, ov_name, substr (cata.key (catx), 8, 6),
	substr (cata.key (catx), 15, 4));
         err_bit = "1"b;
      end;

      return;

   end copy;


/* This subroutine does 16 bit addition with end around carry to validate check sums */

ch_add: proc (sum, add_val);

dcl  sum fixed bin (35);				/* The accumulated sum */
dcl  add_val fixed bin (16);				/* New value to add */

      sum = sum + add_val;				/* Do the add */
carry: if sum > 1111111111111111b then do;		/* If overflow into 17th bit */
         sum = sum - 10000000000000000b;		/* Subtract it out */
         sum = sum + 1;				/* Do end-around carry */
         go to carry;				/* Check again */
      end;
      return;

   end ch_add;
%page;
%include gload_data;
%page;
%include iom_stat;
%page;
%include mca_data_area;
%page;
%include opr_query_info;
%page;
%include tolts_info;
%page;
%include tolts_workspace;


   end tolts_load_firmware_;




		    tolts_pcd_.pl1                  07/20/88  1306.3r w 07/19/88  1536.9      283743



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* tolts_pcd_ subroutine to output the configuration deck for polts and molts
   Coded 79/03/12 by J. A. Bush
   Modified 79/10/09 by Michael R. Jordan for new MPC card.
   Modified 08/80 by R. Fakoury to correctly interrupt chnl cards and to identify bootload chan in the config printout.
   Modified 11/80 by R.Fakoury to handle new config deck channel card utilization
   Modified 1/81 by R Fakoury to output fnp config info for colts.
   Modified 4/81 by R Fakoury to print the cpu and mem config.
   Modified 8/81 by M.R. Jordan for new PRPH OPC card format.
   Modified October 1982 by C. Hornig for new PRPH TAP format.
   Modified 03/17/83 by Rick Fakoury to print hyperchannel config.
   Modified 08/12/83 by Rick Fakoury for the new cpu & console config cards.
   Modified 08/16/83 by Rick Fakoury to allow user to specify device type on config requests.
   and to add support for the iom and hyperchannel config card.
   Modified 10/84 by R Fakoury to use system config card incls.
*/




/****^  HISTORY COMMENTS:
  1) change(84-10-01,Fakoury), approve(86-08-21,MCR7514),
     audit(86-11-25,Martinson), install(86-12-04,MR12.0-1235):
     to use system config card incls,
     for Dipper to print the MCA config,
     for colts rspd request to print the DIA config.
                                                   END HISTORY COMMENTS */




/* tolts_pcd_ subroutine to output the configuration deck for polts and molts */


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
tolts_pcd_: proc (exec, eq_type);

/* tolts_pcd_ subroutine to output the configuration deck for polts & molts */

/* Builtins */

dcl  (addr, addrel, hbound, null, rtrim, substr) builtin;

/* Conditions  */

dcl  cleanup condition;
dcl  linkage_error condition;


/* Constants */

dcl  ADAPTER_FAILURE bit (2) unal init ("01"b) int static options (constant);
dcl  con_types (0:4) char (3) int static options (constant) init
      ("   ", "IBM", "EMC", "SCC", "LCC");
dcl  fnp_state (0:4) char (7) int static options (constant) init
      ("free   ", "unknown", "down   ", "booting", "up     ");
dcl  MAINT_ABNORMAL_TERM bit (2) unal init ("11"b) int static options (constant);
dcl  MAINT_NORMAL_TERM bit (2) unal init ("10"b) int static options (constant);
dcl  max_imu_channels fixed bin init (15) int static options (constant);
dcl  tags (1:26) char (1) static options (constant) init
      ("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n",
      "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z");
dcl  types (1:3) char (6) int static options (constant) init
      ("dn355 ", "l6    ", "dn6670");



/* External Static */

dcl  error_table_$moderr fixed bin (35) ext static;
dcl  error_table_$timeout fixed bin (35) ext static;


/* External Entries */

dcl  add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible;
dcl  com_err_ entry () options (variable);
dcl  find_config_card_$prph_for_channel entry (fixed bin (3), fixed bin (6), ptr);
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$rsnnl entry () options (variable);
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  mca_$attach_mca entry (char (*), fixed bin (71), fixed bin, fixed bin (35));
dcl  mca_$config entry (fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35));
dcl  mca_$detach_mca entry (fixed bin, fixed bin (35));
dcl  mca_$read_data entry (fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35));
dcl  mtdsim_$clean_up entry;
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  tolts_qttyio_$rs entry options (variable);
dcl  tolts_qttyio_ entry (char (*), fixed bin);
dcl  tolts_util_$dev0_valid entry (ptr, fixed bin) returns (bit (1));
dcl  tolts_util_$find_card entry (char (4), ptr);

/* Internal Static */

dcl  code fixed bin (35) init (0);
dcl  CHAN_NUM fixed bin (6);
dcl  c_sw bit (1) init ("0"b);
dcl  data_ptr ptr int static;
dcl  d_sw bit (1) init ("0"b);
dcl  data_present bit (1) init ("0"b);
dcl  entry_var entry variable;
dcl  exec char (6);
dcl  eq_type char (*);
dcl  fips bit (1) init ("0"b);
dcl  i fixed bin init (0);
dcl  iom_num fixed bin (3);
dcl  ipc_type char (9);
dcl  j fixed bin init (0);
dcl  k fixed bin init (0);
dcl  mca_data char (4000) init ("");
dcl  mca_ev_chn fixed bin (71) int static init (0);
dcl  mca_ioi_idx fixed bin int static init (0);
dcl  mca_name char (4) init ("");
dcl  model_index fixed bin;
dcl  NAME char (4) aligned;
dcl  nchn fixed bin;
dcl  ndevices fixed bin;
dcl  od char (136);
dcl  ol fixed bin;
dcl  out_data char (10000);
dcl  prph_name char (4) aligned;
dcl  p99 pic "99" based;
dcl  ret_len fixed bin (21);
dcl  retry_sw bit (1);
dcl  str_info bit (1) init ("0"b);
dcl  ss_info bit (1) init ("0"b);
dcl  session_over bit (1) init ("0"b);
dcl  static_config_ptr ptr int static init (null ());
dcl  status_a bit (72) init ("0"b);
dcl  sub_ptr ptr int static;
dcl  subsys bit (1) init ("0"b);
dcl  term bit (1) init ("0"b);
dcl  total_chars_read fixed bin (21);
dcl  trm bit (1) init ("0"b);


/* Structures */

dcl  1 mca_sub based (sub_ptr) unal,
       2 data_p bit (1) unal,
       2 mbz bit (3) unal,
       2 term_state bit (2) unal;





%page;

      if eq_type ^= "" then do;			/* if equip type = some type user wants partial config */
         if length (eq_type) = 4 then str_info = "1"b;	/* user wants info on a device */
         else if length (eq_type) = 3 then ss_info = "1"b;	/* user wants all info on a device */
         else do;					/* must be invalid arg */
	  if exec = "isolts" then			/* if isolts use ioa */
	     call ioa_ ("tolts_pcd_: Invalid length ARG received");
	  else call tolts_qttyio_$rs (0, "tolts_pcd_: Invalid lenght ARG received");
	  return;
         end;

         call ioa_$rsnnl ("^/   ^/^a configuration:^/   ^/", out_data, ol, substr (eq_type, 1, 3));
         if substr (eq_type, 1, 3) = "cpu" |		/* if cpu or mem */
	substr (eq_type, 1, 3) = "mem" then do;
	  if substr (eq_type, 1, 3) = "cpu" then call cpu_fig;
	  else if substr (eq_type, 1, 3) = "mem" then call mem_fig;
	  call ioa_ ("^a", out_data);
	  return;
         end;
         else if substr (eq_type, 1, 3) = "fnp" then call fnp_fig;
         else if substr (eq_type, 1, 3) = "dia" then call dia_fig;
         else if substr (eq_type, 1, 3) = "iom"
	| substr (eq_type, 1, 3) = "imu" then call iom_fig;
         else if substr (eq_type, 1, 3) = "mca" then do;
	  if str_info then call mca_fig ("mca" || substr (eq_type, 4));
	  else call mca_fig ("");
         end;
         else if substr (eq_type, 1, 3) = "ccu" |
	substr (eq_type, 1, 3) = "hch" |
	substr (eq_type, 1, 3) = "opc" |
	substr (eq_type, 1, 3) = "prt" |
	substr (eq_type, 1, 3) = "pun" |
	substr (eq_type, 1, 3) = "rdr" then call sing_fig;
         else if substr (eq_type, 1, 3) = "dsk" then call disk_fig;
         else if substr (eq_type, 1, 3) = "tap" then call tape_fig;
         else do;					/* can't find a match */
	  if exec = "isolts" then
	     call ioa_ ("tolts_pcd_: Unreconizable ARG received.");
	  else call tolts_qttyio_$rs (0, "tolts_pcd_: Unreconizable ARG received.");
	  return;
         end;
         out_data = rtrim (out_data) || rtrim (mca_data);
         call tolts_qttyio_ (out_data, 10);
         return;
      end;

      else str_info, ss_info = "0"b;			/* user wants config */

      call ioa_$rsnnl ("^/   ^/^a configuration:^/   ^/", out_data, ol, exec);

      if exec = "colt  " then do;
         call dia_fig;				/* output dia configuration first */
         call fnp_fig;				/* now  output fnp configuration */
      end;


      if exec = "isolts" then do;
         call cpu_fig;
         call mem_fig;
         call ioa_ ("^a", out_data);
         return;
      end;
      if exec = "polt  " | exec = "molt  " then do;
         call iom_fig;				/* output iom configuration second */
         call disk_fig;				/* output disk configuration second */
         call tape_fig;				/* followed by tape configuration */
         call sing_fig;				/* and all other peripherals */
         call mca_fig ("");
      end;
      out_data = rtrim (out_data) || rtrim (mca_data);
      call tolts_qttyio_ (out_data, 10);		/* output config */
      return;					/* thats it folks */
%page;

/* dia_fig - internal procedure to format dia configuration for the DN8 FEP */

dia_fig: proc;

declare  dia_number fixed bin;


      prph_cardp = null;				/* start at the beginning of the config deck */
      term = "0"b;					/* reset terminate condition */
      do while (^term);				/* check all cards */
         call tolts_util_$find_card ("prph", prph_cardp);	/* get pointer to fnp config card */
         if prph_cardp = null then term = "1"b;		/* no card found */
         else if (str_info & prph_card.name = eq_type)
	| (substr (prph_card.name, 1, 3) = "dia" & ^str_info) then do;

	  dia_number = rank (substr (prph_card.name, 4, 1))
	   - rank ("a") + 1;			/* dia a is 1 */
	  call ioa_$rsnnl ("dia ^a (^d) on iom ^a ^d",
	   od, ol, tags (dia_number), dia_number - 1, tags (iom), chan);
	  call ioa_$rsnnl ("^a^/", od, ol, od);		/* add new line to output */
	  out_data = rtrim (out_data) || od;		/* add to to output */
	  if str_info then term = "1"b;
         end;
      end;
   end dia_fig;

%page;

/* fnp_fig - internal procedure to format fnp configuration */


fnp_fig: proc;

declare  fnp_number fixed bin;

%include config_prph_fnp_card;

      prph_fnp_cardp = null;				/* start at the beginning of the config deck */
      term = "0"b;					/* reset terminate condition */
      call hcs_$initiate (">sc1", "cdt", "", 0, 0, cdtp, code);
      do while (^term);				/* check all cards */
         call tolts_util_$find_card ("prph", prph_fnp_cardp); /* get pointer to fnp config card */
         if prph_fnp_cardp = null then term = "1"b;	/* no card found */
         else if (str_info & name = eq_type)
	| (substr (name, 1, 3) = "fnp" & ^str_info) then do;

	  fnp_number = rank (substr (name, 4, 1)) - rank ("a") + 1; /* fnp a is 1 */
	  fnpep = addr (cdt.fnp_entry (fnp_number));
	  call ioa_$rsnnl ("fnp ^a (^d) on iom ^a ^d is a ^6a with ^d k of memory and ^d hslas is ^a",
	   od, ol, tags (fnp_number), fnp_number - 1,
	   tags (iom), chan, types (fnpe.type), fnpe.memory, fnpe.nhslas, fnp_state (fnpe.mpxe.state));
	  call ioa_$rsnnl ("^a^/", od, ol, od);		/* add new line to output */
	  out_data = rtrim (out_data) || od;		/* add to to output */
	  if str_info then term = "1"b;
         end;
      end;
   end fnp_fig;

%page;
/* cpu_fig - internal procedure to format cpu configuration */

cpu_fig: proc;


%include config_cpu_card;


      term = "0"b;
      cpu_cardp = null;				/* set config ptr to null */
      do while (^term);				/* loop through all cpu cards first */
         call tolts_util_$find_card ("cpu ", cpu_cardp);
         if cpu_cardp = null then term = "1"b;		/* the last card */

         else if (str_info & (string (rtrim (word)) || tags (tag)) = eq_type)
	| (word = "cpu" & ^str_info) then do;

	  call ioa_$rsnnl ("cpu ^a a^[ ^dK cache ^; ^s^]^a/^d cpu on scu port ^d is ^[on-line & unavailable for test ^;^[off-line & available for test ^;^[currently under test ^]^]^] ",
	   od, ol, tags (tag), (cache_size > 0), (cache_size), type, model,
	   port, (state = "on "), (state = "off "), (state = "test "));
	  call ioa_$rsnnl ("^a^/", od, ol, od);		/* add a new line to output */
	  out_data = rtrim (out_data) || od;
	  if str_info then term = "1"b;
         end;
      end;
   end cpu_fig;

%page;

/* mem_fig - internal procedure to format mem configuration */

mem_fig: proc;

%include config_mem_card;


      term = "0"b;
      mem_cardp = null;				/* set config ptr to null */
      do while (^term);				/* loop through all cpu cards first */
         call tolts_util_$find_card ("mem ", mem_cardp);
         if mem_cardp = null then term = "1"b;		/* the last card */
         else if (str_info & (string (rtrim (word)) || tags (tag)) = eq_type)
	| (word = "mem" & ^str_info) then do;

	  call ioa_$rsnnl ("scu ^a has ^4dk words of memory & is ^[the bootload scu & is unavailable ^;^[on-line & available ^;^[off-line & unavailable ^]^]for test",
	   od, ol, tags (tag), size, (state = "on " & k = 0),
	   (state = "on " & k > 0), (state = "off "));
	  k = k + 1;
	  call ioa_$rsnnl ("^a^/", od, ol, od);		/* add a new line to output */
	  out_data = rtrim (out_data) || od;
	  if str_info then term = "1"b;
         end;
      end;
   end mem_fig;
%page;
/* iom_fig - internal procedure to formatiom configuration */

iom_fig: proc;


%include config_iom_card;


      term = "0"b;
      iom_cardp = null;				/* set config ptr to null */
      do while (^term);				/* loop through all iom cards first */
         call tolts_util_$find_card ("iom ", iom_cardp);
         if iom_cardp = null then term = "1"b;		/* the last card */

         else if (str_info & (string (rtrim (word)) || tags (tag)) = eq_type)
	| (word = "iom" & ^str_info) then do;

	  call ioa_$rsnnl ("iom ^a a ^a iom on scu port ^d is ^[on-line ^;^[off-line ^;^[currently under test ^]^]^] ",
	   od, ol, tags (tag), model, port, (state = "on "),
	   (state = "off "), (state = "test "));
	  call ioa_$rsnnl ("^a^/", od, ol, od);		/* add a new line to output */
	  out_data = rtrim (out_data) || od;
	  if str_info then term = "1"b;
         end;
      end;
   end iom_fig;
%page;

/* disk_fig - internal procedure to format disk configuration */

disk_fig: proc;

%include config_prph_dsk_card;


      term = "0"b;
      prph_dsk_cardp = null;				/* start at beginning of config deck */

      do while (^term);				/* get all disk subsystems */
         call tolts_util_$find_card ("prph", prph_dsk_cardp); /* get next config card */
         if prph_dsk_cardp = null then term = "1"b;	/* if last card, thats it */
         else if (str_info & name = eq_type)
	| (substr (name, 1, 3) = "dsk" & ^str_info) then do;

	  ndevices = 0;
	  fips, subsys = "0"b;
	  do i = 1 to hbound (prph_dsk_card.group, 1)
	   while (prph_dsk_card.group (i).model ^= -1);	/* loop thru all dev pairs */
	     if prph_dsk_card.group (i).model ^= 0 then do; /* if not 0 devices */
	        fips = tolts_util_$dev0_valid
	         (addr (config_data_$disk_drive_model_names), prph_dsk_card.group (i).model);
	        if ^fips & ^subsys then ndevices = ndevices + 1;
	        call ioa_$rsnnl ("^[^a^;^s    ^] ^3d ^2d units;^-starting with device no. ^d^/",
	         od, ol, ^subsys, name, prph_dsk_card.group (i).model, prph_dsk_card.group (i).ndrives, ndevices);
	        out_data = rtrim (out_data) || od;	/* at line to output */
	        subsys = "1"b;			/* indicate we have output subsystem */
	     end;
	     ndevices = ndevices + prph_dsk_card.group (i).ndrives; /* add incremental device numbers */
	  end;
	  NAME = name;
	  call find_mpc (iom, chan, nchan, fips);	/* get mpc card for this prph */
	  call find_chnl (fips);			/* go output associated chnl cards if present */
	  if str_info then term = "1"b;
         end;
      end;

   end disk_fig;
%page;

/* tape_fig - internal procedure to format tape configuration */

tape_fig: proc;

%include config_prph_tap_card;


      term = "0"b;
      prph_tap_cardp = null;				/* start at beginning of tolts_util_$find_card deck */

      do while (^term);				/* get all tape subsystems */
         call tolts_util_$find_card ("prph", prph_tap_cardp); /* get next config card */
         if prph_tap_cardp = null then term = "1"b;	/* if last card, thats it */
         else if (str_info & name = eq_type)
	| (substr (name, 1, 3) = "tap" & ^str_info) then do;

	  ndevices = 0;
	  subsys = "0"b;				/* start by outputting subsystem */
	  do i = 1 to hbound (prph_tap_card.group, 1)
	   while (prph_tap_card.group (i).model ^= -1);	/* loop thru all dev pairs */
	     if prph_tap_card.group (i).model ^= 0 then do; /* if not 0 devices */
	        fips = tolts_util_$dev0_valid
	         (addr (config_data_$tape_drive_model_names), prph_tap_card.group (i).model);
	        if ^fips & ^subsys then ndevices = ndevices + 1;
	        call ioa_$rsnnl ("^[^a^;^s    ^] ^3d ^2d units;^-starting with device no. ^d^/",
	         od, ol, ^subsys, name, prph_tap_card.group (i).model, prph_tap_card.group (i).ndrives, ndevices);
	        out_data = rtrim (out_data) || od;	/* at line to output */
	        subsys = "1"b;			/* indicate we have output subsystem */
	     end;
	     ndevices = ndevices + prph_tap_card.group (i).ndrives; /* add incremental device numbers */
	  end;
	  NAME = name;
	  call find_mpc (iom, chan, nchan, fips);	/* get mpc card for this prph */
	  call find_chnl (fips);			/* go output associated chnl cards if present */
	  if str_info then term = "1"b;
         end;
      end;

   end tape_fig;
%page;

/* sing_fig - internal procedure to format all single line peripherals (rdr,pun,opc,prt) */

sing_fig: proc;

%include config_prph_opc_card;
%include config_prph_prt_card;

dcl  (term, term1, trm) bit (1) init ("0"b);
      nchn = 1;
      prph_cardp = null;				/* start at beginning of config deck */

      do while (^term);				/* get all other peripherals */
         fips, trm = "0"b;
         if ss_info then term1 = "0"b;
         call tolts_util_$find_card ("prph", prph_cardp);	/* get next config card */
         if prph_cardp = null then term = "1"b;		/* if last card, thats it */
         else if str_info & eq_type = (substr (prph_card.name, 1, 4)) then term1 = "1"b;
         else if ss_info & eq_type = (substr (prph_card.name, 1, 3)) then term1 = "1"b;

         else if exec = "polt" & (^str_info & ^ss_info) then do;
	  if substr (prph_card.name, 1, 3) = "prt"	/* if printer */
	   | substr (prph_card.name, 1, 3) = "pun"	/* or punch */
	   | substr (prph_card.name, 1, 3) = "rdr"	/* or reader */
	   | substr (prph_card.name, 1, 3) = "opc"	/* or console */
	   | substr (prph_card.name, 1, 3) = "ccu"	/* or combined card unit */
	   then trm = "1"b;				/* display it */
         end;
         else if exec = "molt" & (^str_info & ^ss_info) then do;
	  if substr (prph_card.name, 1, 3) = "prt"	/* if printer */
	   | substr (prph_card.name, 1, 3) = "pun"	/* or punch */
	   | substr (prph_card.name, 1, 3) = "rdr"	/* or reader */
	   | substr (prph_card.name, 1, 3) = "hch"	/* or hyperchannel */
	   | substr (prph_card.name, 1, 3) = "ccu"	/* or combined card unit */
	   then trm = "1"b;				/* display it */
         end;

         if ^term & trm & ^str_info
	| ^term & ^trm & (str_info | ss_info) & term1 then do;

	  prph_opc_cardp, prph_prt_cardp = prph_cardp;
	  model_index = 0;
	  d_sw = "1"b;				/* device 1 in most cases */
	  if substr (prph_card.name, 1, 3) = "opc " then do; /* if console */
	     model_index = CONSOLE_MODEL_TO_INDEX_FCN (prph_opc_card.model);
	     if model_index > 0
	      then d_sw = ^CONSOLE_IS_BCD (model_index);
	  end;
	  if substr (prph_card.name, 1, 3) = "hch" then d_sw = "0"b;
	  call ioa_$rsnnl ("^4a ^d^[0^]^d^[01^;00^] model ^d ^[^a ^[is available for test ^;is the^[ alternate^]^[^s^] system console ^]^s ^;^4s^a^] ^[with ^d columns and a ^d print belt ^]",
	   od, ol, prph_card.name, prph_card.iom - 1, (prph_card.chan < 10), prph_card.chan,
	   d_sw, prph_card.model, (model_index > 0), con_types (model_index), (prph_opc_card.state = "io") | (prph_opc_card.state = "inop"),
	   (prph_opc_card.state = "alt "), (prph_opc_card.state = "on"),
	   (substr (prph_card.name, 1, 3)), (substr (prph_card.name, 1, 3) = "prt"), line_length, train);

	  call ioa_$rsnnl ("^a^/", od, ol, od);		/* add new line */
	  out_data = rtrim (out_data) || od;		/* add to line */
	  if substr (prph_card.name, 1, 3) ^= "opc"
	   | substr (prph_card.name, 1, 3) ^= "hch" then do; /* might be mpc device */
	     NAME = prph_card.name;
	     call find_mpc (prph_card.iom, prph_card.chan, nchn, fips); /* get mpc card for this perph */
	     call find_chnl (fips);			/* find chnl cards if present */
	  end;
	  else call set_cline (prph_card.iom - 1, prph_card.chan, 0, "", -1); /* tell them no mpc card found */
	  if str_info then term = "1"b;
         end;
      end;

   end sing_fig;
%page;

/* find_mpc - internal procedure to find mpc card given iom and channel, and return mpc number */

find_mpc: proc (iom, a_chan, a_nchan, fips);

%include config_ipc_card;
%include config_mpc_card;
dcl  fips bit (1);
dcl  (chan, a_chan) fixed bin (8);
dcl  iom fixed bin (3);
dcl  (i, j, a_nchan, nchan) fixed bin;
dcl  cont_cardp ptr;
dcl  1 cont_card aligned based (cont_cardp) like mpc_card;


      chan = a_chan;				/* copy parameters */
      nchan = a_nchan;
      cont_cardp = null ();				/* start at beginning of deck */
      trm = "0"b;					/* reset terminate condition */
      do while (^trm);				/* find mpc card */
         if ^fips then call tolts_util_$find_card ("mpc ", cont_cardp);
         else call tolts_util_$find_card ("ipc", cont_cardp); /* look for an fips card */
         if cont_cardp = null () then trm = "1"b;
         else if fips then do;
	  ipc_cardp = cont_cardp;
	  j = 1;
	  if ipc_card.iom = iom then			/* if match on iom number */
	     if (chan >= ipc_card.chan
	      & chan <= ipc_card.chan + (ipc_card.nchan - 1)) then do;
	        if chan ^= ipc_card.chan then j = 2;
	        call set_cline (iom - 1, (chan), ipc_card.nchan,
	         ipc_card.type, j);			/* output chan line */
	        if nchan <= ipc_card.nchan then		/* if this is all chanels */
		 trm = "1"b;			/* and chan number, this is it */
	        else do;				/* more channels on diffent mpc cards */
		 chan = chan + ipc_card.nchan;	/* add in channels processed */
		 nchan = nchan - ipc_card.nchan;	/* and subtract number of chans */
	        end;
	     end;

         end;
         else do i = 1 to hbound (cont_card.port, 1) while (cont_card.port (i).iom ^= -1 & ^trm);
	  j = i;
	  if cont_card.port (i).iom = iom then		/* if match on iom number */
	     if (chan >= cont_card.port (i).chan
	      & chan <= cont_card.port (i).chan + (cont_card.port (i).nchan - 1)) then do;
	        if chan ^= cont_card.port (i).chan then j = 2;
	        call set_cline (iom - 1, (chan), cont_card.port (i).nchan, cont_card.name, j); /* output chan line */
	        if nchan <= cont_card.port (i).nchan then /* if this is all chanels */
		 trm = "1"b;			/* and chan number, this is it */
	        else do;				/* more channels on diffent mpc cards */
		 chan = chan + cont_card.port (i).nchan;/* add in channels processed */
		 nchan = nchan - cont_card.port (i).nchan; /* and subtract number of chans */
	        end;
	     end;

         end;
      end;
      if cont_cardp = null () then			/* if we didn't find an mpc */
         call set_cline (iom - 1, chan, 0, "", -1);	/* tell them no mpc card found */

   end find_mpc;
%page;

/* find_chnl - internal procdure to find chnl card associated with prph card and output info */

find_chnl: proc (fips);

%include config_chnl_card;
dcl  fips bit (1);

      chnl_cardp = null;				/* start at beginning */
      trm = "0"b;					/* and find possible chnl card */
      do while (^trm);
         call tolts_util_$find_card ("chnl", chnl_cardp);
         if chnl_cardp = null then trm = "1"b;		/* if last card, no chnl card */
         else if name = NAME then do;			/* if for right subsystem */
	  trm = "1"b;				/* set terminate condition */
	  do i = 1 to 3 while (chnl_card.group (i).iom ^= -1); /* loop through all fields of chnl card */
	     call find_mpc (chnl_card.group (i).iom, chnl_card.group (i).chan, chnl_card.group (i).nchan, fips); /* find mpc card */
	  end;
         end;
      end;

   end find_chnl;
%page;
/* mca_fig - int proc to attach a MCA, reads its config table and add the info to the out_data buffer. */

mca_fig: proc (MCA_NAME);

%include config_iom_card;


dcl  MCA_NAME char (4);

      mca_config_file_ptr = null;
      iom_cardp = null;				/* set config ptr to null */

      on linkage_error begin;
         call com_err_ (error_table_$moderr, "mca_fig", "mca_");
         goto mca_fig_end;				/* exit */
      end;


      on cleanup begin;
         if mca_config_file_ptr ^= null then
	  call release_temp_segment_ ("tolts_pcd_", mca_config_file_ptr, code);

         call mtdsim_$clean_up ();			/* call our normal handler */
         goto mca_fig_end;
      end;

      entry_var = mca_$attach_mca;
      revert linkage_error;

      call get_temp_segment_ ("tolts_pcd_", mca_config_file_ptr, code);
      data_ptr, static_config_ptr = mca_config_file_ptr;
next:
      if MCA_NAME = "" then do;			/* loop through all iom cards first */
         call tolts_util_$find_card ("iom ", iom_cardp);
         if iom_cardp = null then return;		/* the last card */
         if iom_card.model = "imu" then
	  mca_name = "mca" || tags (iom_card.tag);
         else goto next;
      end;
      else mca_name = MCA_NAME;
      retry_sw = "1"b;

retry_attach:

      call ioa_ ("attaching ^a for configuration read", mca_name); /* let the user know */
      call mca_$attach_mca (mca_name, mca_ev_chn, mca_ioi_idx, code);
      if code ^= 0 then do;
         if code = error_table_$timeout then do;
	  if retry_sw then do;
	     retry_sw = "0"b;
	     call com_err_ (code, "tolts_pcd_", "Attaching ^a, will retry..", mca_name);
	     goto retry_attach;
	  end;
         end;
         if addr (code) -> status.t & addr (code) -> status.major = "0"b
	then call com_err_ (0, "mca_$attach_mca", "status ^w", code);
         else call com_err_ (code, "tolts_pcd_",
	     "Attempting to attach ^a", mca_name);
         return;
      end;
      call ioa_ ("^a attached for configuration read", mca_name);
      call rd_config;

DONE:
      if mca_ioi_idx ^= -1 then
         call mca_$detach_mca (mca_ioi_idx, code);
      if code ^= 0 then do;
         call com_err_ (code, "tolts_pcd_", "Attempting to detach ^a", mca_name);
      end;
      if mca_config_file_ptr ^= null () then
         call release_temp_segment_
	("tolts_pcd_", mca_config_file_ptr, code);
      if MCA_NAME = "" & iom_cardp ^= null then goto next;

      revert cleanup;				/* re-enable previous cleanup handler */

mca_fig_end:

   end mca_fig;
%page;

/* rd_config - int proc that actually reads the MCA config & formats the data */
rd_config: proc;

      total_chars_read = 0;
      call mca_$config ((mca_ioi_idx), mca_config_file_ptr,
       (4 * size (mca_config_file)), ret_len, status_a, code);
      if code ^= 0 then do;
         call com_err_ (code, "mca_$config", "status_a ^w", status_a);
      end;
      else do;
         call read_more (mca_config_file_ptr);		/* go read the rest of the data */
         if code ^= 0 then return;
         iom_num = index ("abcd", substr (mca_name, 4, 1));
         do i = 0 to max_imu_channels;
	  CHAN_NUM = channel_data (i).prim_ch_num;
	  call find_config_card_$prph_for_channel (iom_num, CHAN_NUM, prph_cardp);
	  if prph_cardp = null () then prph_name = "";
	  else prph_name = prph_card.name;
	  ipc_type = TYPE (channel_data (i).lvl_1_id_type);
	  if channel_data (i).fw_id = "00001000"b
	   then ipc_type = rtrim (ipc_type) || "_tape";
	  if channel_data (i).fw_id = "00001001"b
	   then ipc_type = rtrim (ipc_type) || "_disk";
	  if channel_data (i).lvl_1_state ^= 1 then do;
	     call ioa_$rsnnl
	      ("^2xIPC_^2a ^9a ch ^2d for ^2d ^4a state = ^d dt ^d ^[fw_rev ^a^]^/",
	      od, ol, convert (p99, i), ipc_type, channel_data (i).prim_ch_num,
	      channel_data (i).num_of_log_ch, prph_name,
	      channel_data (i).lvl_1_state, channel_data (i).disk_tab,
	      (channel_data (i).fw_id ^= "0000"b), channel_data (i).fw_rev);
	     mca_data = rtrim (mca_data) || od;		/* at line to output */
	  end;
         end;
      end;
   end rd_config;

%page;

/* read_more - int proc to contine to read the mca config data until it is all read */

read_more: proc (start_ptr);
dcl  start_ptr ptr;
dcl  read_ptr ptr;

      read_ptr = start_ptr;
one_more_time:
      total_chars_read = ret_len + total_chars_read;
      if ^check_status_ok () then return;
      if data_present then
         read_ptr = add_char_offset_ (read_ptr, ret_len);
      if ^session_over then do;
         call mca_$read_data (mca_ioi_idx, read_ptr,
	(16 * 1024), ret_len, status_a, code);
         if code ^= 0 then do;
	  call com_err_ (code, "mca_$read_data", "status_a ^w", status_a);
	  return;
         end;
         goto one_more_time;
      end;
   end read_more;

%page;

/* check_status_ok -  int proc to examine the MCA status & return the state */

check_status_ok: proc () returns (bit (1));

dcl  state bit (1) init ("1"b);			/* assume the return status is ok */

      data_present = "0"b;
      session_over = "0"b;

      statp = addr (status_a);
      if ^status.t then do;
         call ioa_ ("Returned status was no good. (^w)", unspec (status));
         state = "0"b;
         goto return_state;
      end;

      if status.power then do;
         state = "0"b;
         goto return_state;
      end;

      if (status.channel_stat | status.central_stat) ^= "0"b then do;
         state = "0"b;
         goto return_state;
      end;

      sub_ptr = addr (status.sub);
      data_present = mca_sub.data_p;

      if status.major ^= ""b then do;
         state = "0"b;
      end;

      if mca_sub.mbz ^= ""b then do;
         state = "0"b;
      end;

      if mca_sub.term_state = MAINT_ABNORMAL_TERM then do;
         session_over = "1"b;
         state = "0"b;
      end;
      if mca_sub.term_state = MAINT_NORMAL_TERM then session_over = "1"b;
return_state:
      return (state);
   end check_status_ok;


%page;
/*

   The following function returns the 'console model index' given the console
   model number.  If the model number is not known, -1 is returned.

*/

CONSOLE_MODEL_TO_INDEX_FCN: procedure (model_number) returns (fixed bin);


dcl  model_number fixed bin;
dcl  i fixed bin;


      do i = 1 to hbound (CONSOLE_MODEL_NUMBER, 1);
         if model_number = CONSOLE_MODEL_NUMBER (i)
	then return (CONSOLE_MODEL_INDEX (i));
      end;

      return (-1);


   end CONSOLE_MODEL_TO_INDEX_FCN;

%page;

/* set_cline - internal procedure to add channel line to output */

set_cline: proc (iom, chan, lchan, mpcnm, fldno);

dcl  iom fixed bin (3);
dcl  chan fixed bin (8);
dcl  (lchan, fldno) fixed bin;
dcl  mpcnm char (4) aligned;

      call ioa_$rsnnl ("     ^d^[0^]^dxx^-^[ special purpose chan ^3s^;^[primary^]^[secondary^] channel of ^d logical channel^[s^] on mpc card ^a ^]^/",
       od, ol, (iom), (chan < 10), (chan), (mpcnm = ""), (fldno = 1), (fldno > 1), (lchan), (lchan > 1), mpcnm);
      out_data = rtrim (out_data) || od;		/* add to end of line */

   end set_cline;

%page;
%include author_dcl;
%page;
%include cdt;
%page;
%include config_data_dcls;
%page;
%include config_prph_card;
%page;
%include console_device_specs;
%page;
%include mca_area;
%page;
%include mca_config_file;
%page;
%include mca_constants;
%page;
%include iom_stat;


   end tolts_pcd_;




		    tolts_qttyio_.pl1               12/09/86  1539.4r w 12/09/86  1522.8       92169



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* format: style4 */
tolts_qttyio_: proc (message, a_page);

/* tolts_qttyio_ - procedure and related entries to queue up terminal io for tolts, 1 line at a time */
/* the page numbers have the following meaning:
   page = 0 = output to users terminal
   page = 1 - 8 = output from 1 of the test pages, routed to users terminal or print file (see dcw_lp struct)
   page = 9 = output message on users terminal and then read input from user
   page = 10 = output to user terminal or print file, if print file attached (tolts_info.file_attach = "1"b)
*/

/* External Entries */

dcl  hcs_$wakeup entry (bit (36) aligned,
	fixed bin (71), ptr, fixed bin (35));		/* arg 3 is suppose to be fixed bin (71) */
dcl  com_err_ entry options (variable);
dcl  terminate_process_ entry (char (*), ptr);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned);
dcl  tolts_util_$bci_to_ascii entry (bit (*), char (*) varying, fixed bin);

/* Entry Parameters */

dcl  message char (*);
dcl  (a_page, np) fixed bin;
dcl  a_dcwp ptr;

/* Automatic */

dcl  (genp, argp, dcwptr) ptr;
dcl  mep ptr;
dcl  (page, lp, lb, c_len, i) fixed bin;
dcl  (found, pline) bit (1);
dcl  NLFF char (2);
dcl  rs_data char (136);

/* structures and based variables */

dcl  bcd_str bit (c_len * 6) based (genp);

dcl  1 fatal_desc aligned,
       2 version fixed bin,
       2 fatal_code fixed bin (35);

dcl  1 mes_buf based (mep) aligned,			/* template for a message queue entry */
       2 page fixed bin,				/* test page number issuing io */
       2 nlines fixed bin,				/* number of array elements in message */
       2 cline fixed bin,				/* line number currently being displayed */
       2 lines (nlines) char (136),			/* array of message lines */
       2 nxt_mes char (1);				/* method to get to next message */

dcl  1 rcw based (genp),				/* structure for gcos sysout records with rcws */
       (2 dlen fixed bin,				/* number of words */
       2 pad fixed bin) unaligned,			/* reset of  rcw not used */
       2 data bit (rcw.dlen * 36),			/* bcd data as bit string */
       2 nxt_rcw bit (0);				/* used for getting next rcw */

dcl  1 dcw_lp based (dcwptr) aligned,			/* template for tadio dcw ptr */
       (2 add fixed bin (18) unsigned,			/* address of tadio dcw */
       2 type,					/* dcw type */
         3 e bit (1),				/* select terminal/print file by option */
         3 r bit (1),				/* write then read */
         3 m bit (1),				/* master console output */
         3 s bit (1),				/* slaved terminal output */
         3 c bit (1),				/* controlling terminal output */
         3 p bit (1),				/* output to print file */
       2 wc fixed bin (12) unsigned) unaligned;		/* total message word count */

/* Builtins */

dcl  (addr, addrel, length, rel, rtrim, search, substr, unspec, verify) builtin;


	page = a_page;				/* copy test page number */
	if page = 9 then tolts_info.term_io_in_prog = "1"b;
	call que_setup;				/* go set up queue entry */
	if tolts_info.file_attach then		/* if print file attached.... */
	     if page > 0 & page ^= 9 & page ^= 19 then	/* and if exec I/O... */
		pline = "1"b;			/* set print flag */
	c_len = length (rtrim (message));		/* get rtrim(message) length */
	call parse_mess (addr (message), c_len);	/* go parse up message into individual lines */
	call wakeup;				/* go wakeup display event */
	return;					/* thats all folks */


/* dcw_ptr - entry to queue up message given a list of dcw ptrs (for MME TADIOD) */

dcw_ptr: entry (a_dcwp, np, a_page);

	page = a_page;
	dcwptr = a_dcwp;
	do i = 1 to np;				/* process all dcw ptrs */
	     call que_setup;			/* go set up our message queue entry */
	     dcwp = ptr (dcwptr, dcw_lp.add);		/* get ptr to next dcw */
	     if tolts_info.file_attach then		/* if print file attached... */
		if dcw_lp.type.e | dcw_lp.type.p then	/* and line to be printed */
		     pline = "1"b;			/* set flag */
	     call pdcw_list;			/* go process dcw list */
	     call wakeup;				/* go wakeup display event */
	     dcwptr = addrel (dcwptr, 1);		/* increment to next ptr */
	end;
	return;					/* thats all folks */


/* dcw_list - entry to queue up a message given a dcw list */

dcw_list: entry (a_dcwp, a_page);

	page = a_page;				/* copy test page number */
	call que_setup;				/* go get the next avail buffer and initialize */
	dcwp = a_dcwp;				/* copy dcw ptr */
	call pdcw_list;				/* go process the dcw list */
	call wakeup;				/* issue wakeup to tolts_ttyio_display_ */
	return;					/* thats all folks */


/* rs - entry to pass in short messages with ioa_ control args */

rs:  entry (a_page);

	page = a_page;				/* set test page */
	call que_setup;				/* go get next queue loc */
	if tolts_info.file_attach then		/* if print file attached.... */
	     if page > 0 & page ^= 9 & page ^= 19 then
		pline = "1"b;			/* set print flag */
	call cu_$arg_list_ptr (argp);			/* get ptr to our argument list */
	call ioa_$general_rs (argp, 2, 3, rs_data, c_len, "0"b, "0"b); /* format message */
	call parse_mess (addr (rs_data), c_len);	/* go parse message and store in queue */
	call wakeup;				/* wakeup display */
	return;


/* rcw - entry to output a message coded for gcos sysout */

rcw: entry (a_dcwp);

	page = 0;					/* set test page to exec */
	call que_setup;				/* go get next queue loc */
	dcwp = a_dcwp;				/* copy dcw ptr */
	c_len = fixed (dcw.tally);			/* get dcw length */
	i = 0;					/* reset word counter */
	genp = ptr (dcwp, dcw.address);		/* get ptr to first rcw */
	do while (i < c_len);			/* do until we are done */
	     i = i + rcw.dlen + 1;			/* add current rcw length + rcw */
	     call tolts_util_$bci_to_ascii (rcw.data, tolts_info.cv_buf, rcw.dlen * 6); /* convert to ascii */
	     call parse_mess (addrel (addr (tolts_info.cv_buf), 1), length (tolts_info.cv_buf)); /* go parse message */
	     genp = addr (rcw.nxt_rcw);		/* get next rcw address */
	end;
	call wakeup;				/* wakeup display event */
	return;					/* thats it folks */


/* pdcw_list - subroutine to process a dcw list containing messages */

pdcw_list: proc;

	found = "0"b;				/* initiaize terminate condition */
	do while (^found);				/* process all dcws */
	     genp = ptr (dcwp, fixed (dcw.address, 17));	/* get ptr to string */
	     c_len = fixed (dcw.tally) * 6;		/* number of bcd chars */
	     call tolts_util_$bci_to_ascii (bcd_str, tolts_info.cv_buf, c_len);
	     call parse_mess (addrel (addr (tolts_info.cv_buf), 1), length (tolts_info.cv_buf)); /* go parse message */
	     if dcw.type = "00"b then found = "1"b;	/* if last dcw */
	     else dcwp = addrel (dcwp, 1);		/* otherwise get next dcw */
	end;

     end pdcw_list;

/* parse_mess - subroutine to parse terminal messages and store in queue entry message array */

parse_mess: proc (mesp, slen);

dcl  mesp ptr;					/* ptr to message to be parsed */
dcl  slen fixed bin;				/* length of message to be parsed */
dcl  rmess char (slen) based (mesp);			/* template for message to be parsed */

	if slen = 0 then				/* special case null lines */
	     lp = 0;
	else lp = 1;				/* set initial scan position */
	do while (lp <= slen);			/* process entire line */
	     mes_buf.nlines = mes_buf.nlines + 1;	/* update number of lines */
	     mes_buf.lines (nlines) = "";		/* initialize buffer to blanks */
	     if slen ^= 0 then do;			/* if somebody sent over a null string, special case */
		lb = verify (substr (rmess, lp, (slen - lp) + 1), NLFF); /* strip off NLs and Form feeds */
		if lb = 0 then do;			/* if couldn't find... */
		     lp = lp + (slen - lp) + 1;	/* update lp to escape from loop */
		     mes_buf.nlines = mes_buf.nlines - 1; /* get rid of blank line */
		end;
		else do;
		     lp = lp + (lb - 1);		/* correct starting position */
		     lb = search (substr (rmess, lp), NLFF); /* search for next NL or form feed */
		     if lb = 0 then			/* if no more */
			lb = (slen - lp) + 1;	/* set to end of line */
		     else lb = lb - 1;
		     mes_buf.lines (nlines) = substr (rmess, lp, lb); /* save substr as line */
		     lp = lp + lb;			/* update position */
		end;
	     end;
	     else lp = 1;				/* set condition to get out of loop */
	end;

     end parse_mess;


/* que_setup - subroutine to initialize a new queue entry */

que_setup: proc;

	unspec (NLFF) = "012014"b3;			/* set new line and form feed constants */
	mep = tolts_info.mess_buf.nxt;		/* set message ptr to next avail loc */
	mes_buf.page = page;			/* set page number in entry */
	mes_buf.nlines, mes_buf.cline = 0;		/* initialize number of lines and current line */
	pline = "0"b;				/* reset print line flag */

     end que_setup;

/* wakeup - subroutine to set the nxt queue entry address and wakeup tolts_dtty_io_ */

wakeup: proc;

	if pline then				/* if message to be printed... */
	     mes_buf.page = mes_buf.page + 20;		/* set print indicator */
	tolts_info.mess_buf.nxt = addr (mes_buf.nxt_mes); /* set next queue address */
	if rel (tolts_info.mess_buf.nxt) > rel (addr (tolts_info.mess_buf.q_end)) then /* if wrap */
	     tolts_info.mess_buf.nxt = tolts_info.mess_buf.first; /* set to start of queue */
	tolts_info.term_io_req_cnt = tolts_info.term_io_req_cnt + 1; /* increment number of requests */

/* send tolts_dttyio_ a wakeup and send him the message ptr */

	call hcs_$wakeup (tolts_info.process, tolts_info.tty_issue_event, mep, fatal_desc.fatal_code);
	if fatal_desc.fatal_code ^= 0 then do;
	     call com_err_ (fatal_desc.fatal_code, "tolts_qttyio_", "fatal error, terminating process");
	     fatal_desc.version = 0;
	     call terminate_process_ ("fatal_error", addr (fatal_desc));
	end;

     end wakeup;


%include tolts_info;
%include iom_dcw;

     end tolts_qttyio_;




		    tolts_ttyio_display_.pl1        12/09/86  1539.4r w 12/09/86  1522.8       55791



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* format: style4 */
tolts_ttyio_display_: proc (event_ptr);

/*
   This procedure displays each line of a queued terminal io message and  is  driven  by  IPC
   call  channels.  The first call is initiated by the tolts_qttyio_ subroutine waking up the
   tty_issue_event channel. Further calls on this  event  channel  are  inhibited  until  the
   entire  message  has  been  displayed. After the first line of a message is displayed, all
   subsequent lines are output by waking up the tty_display_event  channel.  The  tty_display
   event  channel  will  call  the entry tolts_ttyio_display_$nxt_line until all lines of the
   message are output. After the last line of a  message  is  displayed,  the  event  channel
   tty_ccc_event is woken up. This calls the routine tolts_ttyio_end_ for message completion.
   Message  routing  is  determined  by  the  value  of  the  message   entry   page   number
   (mes_buf.page).  If the page number has a value from 0 to 9, then the message is routed to
   the user_output io switch. If the page number has a value greater than  or  equal  to  20,
   then  the  message  is  routed  to  the io switch defined by tolts_info.pf_iocbp. The page
   number is then corrected to its true value (0 to 9) before the tolts_ttyio_end_  entry  is
   signalled.
*/


/* External Entries */

dcl  hcs_$wakeup entry (bit (36) aligned,
	fixed bin (71), ptr, fixed bin (35));		/* arg 3 is suppose to be fixed bin (71) */
dcl  (com_err_, ioa_$ioa_switch_nnl) entry options (variable);
dcl  terminate_process_ entry (char (*), ptr);
dcl  ipc_$cutoff entry (fixed bin (71), fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));

/* Entry Parameters */

dcl  event_ptr ptr;

/* Automatic */

dcl  (mep, iocbp) ptr;
dcl  page fixed bin;
dcl  error fixed bin (35);
dcl  npnl bit (1);

/* structures and based variables */

dcl  1 event_info based (event_ptr),
       2 causing_event fixed bin (71),
       2 cmp ptr,
       2 sender bit (36),
       2 origin,
         3 signal bit (18) unaligned,
         3 ring bit (18) unaligned,
       2 in_data_pointer ptr;


dcl  1 fatal_desc aligned,
       2 version fixed bin,
       2 fatal_code fixed bin (35);

dcl  1 mes_buf based (mep) aligned,			/* template for a message queue entry */
       2 page fixed bin,				/* test page number issuing io */
       2 nlines fixed bin,				/* number of array elements in message */
       2 cline fixed bin,				/* line number currently being displayed */
       2 lines (nlines) char (136),			/* array of message lines */
       2 nxt_mes char (1);				/* method to get to next message */

/* Builtins */

dcl  (addr, null) builtin;

/* Static */

dcl  (iox_$user_output, iox_$user_io) ptr ext;


	call ipc_$cutoff (tolts_info.tty_issue_event, error); /* inhibit further calls from tolts_qttyio_ */
	if error ^= 0 then do;
disaster:
	     call com_err_ (error, "tolts_ttyio_display_", "fatal error, terminating process");
	     fatal_desc.fatal_code = error;
	     fatal_desc.version = 0;
	     call terminate_process_ ("fatal_error", addr (fatal_desc));
	end;

/* entry to display more than one line (after first line) */

nxt_line: entry (event_ptr);

	mep = event_info.cmp;			/* copy message ptr */
	tolts_info.term_io_in_prog = "1"b;		/* set io in progress flag */
	if tolts_info.optflag ^= 0 then do;		/* has a quit been signalled? */
	     call wakeup (tolts_info.tty_ccc_event, "1"b);/* yes signal tolts_ttyio_end_ */
	     return;
	end;
	mes_buf.cline = mes_buf.cline + 1;		/* increment current line number */

/* determine if going to printer or terminel */

	page = mes_buf.page;			/* copy page number */
	if page >= 20 then do;			/* if printer flag set */
	     if tolts_info.pf_iocbp ^= null then	/* if print file iocb ptr good */
		iocbp = tolts_info.pf_iocbp;		/* output to print file switch */
	     else iocbp = iox_$user_output;		/* go to terminal */
	     page = page - 20;			/* get right page number */
	end;
	else iocbp = iox_$user_output;		/* otherwise go to terminal */

/* determine if line should end with newline character */

	npnl = "0"b;				/* default is to output new line */
	if page = 9 | page = 19 then			/* if exec read, no newline */
	     if mes_buf.cline = mes_buf.nlines then	/* and this is the last line of message */
		npnl = "1"b;
	     else ;
	else if page > 0 & page ^= 10 then		/* if not exec write */
	     if tolts_info.tadio (page).optrd then	/* and test page requesting options */
		if mes_buf.cline = mes_buf.nlines then	/* and this is the last line of message */
		     npnl = "1"b;			/* don't put out newline */
	call ioa_$ioa_switch_nnl (iocbp, "^a^[ ^;^/^]",
	     mes_buf.lines (mes_buf.cline), npnl);	/* display line */
	if mes_buf.cline = mes_buf.nlines | tolts_info.optflag ^= 0 then /* last line or quit? */
	     call wakeup (tolts_info.tty_ccc_event, "1"b);/* wake up tolts_ttyio_end_ */
	else call wakeup (tolts_info.tty_display_event, "0"b); /* otherwise, wakeup ourself */
	call iox_$control (iox_$user_io, "start", null, error); /* allow cleanup of any blocks */
	return;


/* wakeup - subroutine to wakeup requested event channel */

wakeup: proc (e_chan, last_line);

dcl  e_chan fixed bin (71);
dcl  last_line bit (1);

	if last_line then				/* if last line of message.... */
	     if mes_buf.page >= 20 then		/* and if printer output */
		mes_buf.page = mes_buf.page - 20;	/* correct page number for tolts_ttyio_end_ */
	call hcs_$wakeup (tolts_info.process, e_chan, mep, error); /* wakeup desired channel */
	if error ^= 0 then				/* if some problem... */
	     go to disaster;			/* terminate process */

     end wakeup;


%include tolts_info;

     end tolts_ttyio_display_;




		    tolts_ttyio_end_.pl1            12/09/86  1539.4rew 12/09/86  1521.0      131580



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* Modified on 5/80 by R. Fakoury  to check for mtar request.
   Modified 12/80 by R. Fakoury to implement colts.
   Modified 81/05 by R. Fakoury to correctly handle a Multics command request.
   Modified 04/81 by R. Fakoury to allow clstal requests.
   Modified 03/83 by Rick Fakoury to implement 'test msg' for operator/user communication.
   Modified 08/16/83 by Rick Fakoury to allow partial config messages.
   Modified 11/83 by Rick Fakoury to allow hyperchannel test request.
   Modified 01/84 to allow input prior to first request.
*/




/****^  HISTORY COMMENTS:
  1) change(85-12-21,Fakoury), approve(86-08-21,MCR7514),
     audit(86-11-11,Martinson), install(86-12-04,MR12.0-1235):
     for a test nio request,
     to allow the Colts responder (rsp) request,
     set limit of Molts request line to 11 chars,
     allow single character reply to a tolts query.
                                                   END HISTORY COMMENTS */





/* This procedure is called (via the event call channel id tty_ccc_event) from tolts_ttyio_display_.
   It functions to do any cleanup upon the completion of a terminal io message. If the io request was
   for test page number 9, this is a read request folloiwing the message completion. If this is the
   case, or if a quit was signaled during transmission of the last message, a call is made to
   tolts_util_$query to get input from the user. The input requests are processed accordingly. */


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
tolts_ttyio_end_: proc (event_ptr);


/* External Entries */

dcl  hcs_$wakeup entry (bit (36) aligned,
      fixed bin (71), ptr, fixed bin (35));		/* arg 3 is suppose to be fixed bin (71) */
dcl  (com_err_, ioa_) entry options (variable);
dcl  terminate_process_ entry (char (*), ptr);
dcl  ipc_$reconnect entry (fixed bin (71), fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
dcl  tolts_util_$opr_msg entry;
dcl  tolts_util_$query entry (char (*), char (132) aligned, fixed bin, (32) char (28) varying, fixed bin);
dcl  tolts_alm_util_$ascii_to_bci_ entry (char (*), bit (*));
dcl  tolts_pcd_ entry (char (6), char (*));
dcl  tolts_qttyio_ entry (char (*), fixed bin);

/* Entry Parameters */

dcl  event_ptr ptr;

/* Automatic */

dcl  com_string char (132) aligned;
dcl  args (32) char (28) varying;
dcl  ascii_in char (18);
dcl  bcd_out bit (144);
dcl  bcd_opt bit (6 * 84);
dcl  (page, cmd_cnt, c_len, i, j, term_io_req_cnt_hld) fixed bin;
dcl  mep ptr;
dcl  error fixed bin (35);
dcl  q_str char (5);
dcl  NL char (1) int static options (constant) init ("
");

/* structures and based variables */

dcl  bcd_request (4) bit (36) based (addr (bcd_out));
dcl  opt_str char (c_len) based (addr (com_string));


dcl  fnp_num (0:7) char (1) static options (constant) init
      ("a", "b", "c", "d", "e", "f", "g", "h");
dcl  chn_num (0:14) char (2) static options (constant) init
      ("77", "77", "77", "77", "77", "77", "h0", "h1", "h2", "l0", "l1", "l2", "l3", "l4", "l5");
dcl  cdt_fnp char (1);
dcl  (cdt_chn, cdt_subchan) char (2);

dcl  1 event_info based (event_ptr),
       2 causing_event fixed bin (71),
       2 cmp ptr,
       2 sender bit (36),
       2 origin,
         3 signal bit (18) unaligned,
         3 ring bit (18) unaligned,
       2 in_data_pointer ptr;

dcl  1 fatal_desc aligned,
       2 version fixed bin,
       2 fatal_code fixed bin (35);

dcl  1 mes_buf based (mep) aligned,			/* template for a message queue entry */
       2 page fixed bin,				/* test page number issuing io */
       2 nlines fixed bin,				/* number of array elements in message */
       2 cline fixed bin,				/* line number currently being displayed */
       2 lines (nlines) char (136),			/* array of message lines */
       2 nxt_mes char (1);				/* method to get to next message */

/* Builtins */

dcl  (addr, bin, length, ltrim, null, search, substr) builtin;
dcl  iox_$user_io ptr ext;
%page;

      if ^tolts_info.term_io_in_prog then
         return;					/* not mine  forget it */
      mep = event_info.cmp;				/* get currnet message ptr */
      page = mes_buf.page;				/* extract test page number */
      if tolts_info.optflag ^= 0 then q_str = NL || "??? "; /* if quit signaled output "??? " */
      else q_str = "";
      if page = 9 | page = 19 | tolts_info.optflag ^= 0 then do; /* exec read or quit signaled */
         tolts_info.optflag = 0;			/* reset option request flag */
requery:
         call tolts_util_$query (q_str, com_string, c_len, args, cmd_cnt); /* get user input */
         if page = 19 then do;			/* is it local Multics question? */
	  tolts_info.mult_ans = substr (com_string, 1, 28); /* yes copy answer */
	  go to ck_first;
         end;
         if c_len <= 2 then do;			/* if user just typed nl */
ck_first:
	  if ^tolts_info.first_request_done & page ^= 19 then do; /* and initial read not complete */
	     q_str = NL || "??? ";			/* set up questions for requery */
	     go to requery;				/* go ask again */
	  end;
	  call reconnect;				/* enable term io  again */
	  call wakeup (tolts_info.wait_list.wait_event_id (1), null); /* wake up dispatcher */
	  return;
         end;
         else if args (1) = "reprint" then do;		/* user wants to see last message */
	  if page = 9 then				/* it has already been printed */
	     call ioa_ ("^as: Last message was complete and is not available for reprinting",
	      tolts_info.exec);
	  else do;
	     mes_buf.cline = 0;			/* make tolts_ttyio_display_ start at beginning of message */
	     call wakeup (tolts_info.tty_display_event, mep); /* signal restart of message */
	     if tolts_info.first_request_done then	/* if first request complete */
	        call tolts_qttyio_ ("??? ", 9);		/* queue up another read, but don't reconnect issue channel */
	     return;
	  end;
         end;
         else if args (1) = "msg" then			/* user wants to communicate with the operator */
	  call tolts_util_$opr_msg;
         else if args (1) = "E" | args (1) = "e" | substr (args (1), 1, 2) = ".." then do; /* user wants to execute Multics command */
	  com_string = ltrim (substr (com_string, 2));
	  if substr (args (1), 1, 2) = ".." then com_string = substr (com_string, 2);
	  term_io_req_cnt_hld = tolts_info.term_io_req_cnt;
	  tolts_info.term_io_req_cnt = 0;
	  call cu_$cp (addr (com_string), length (com_string), error); /* execute Multics command */
	  tolts_info.term_io_req_cnt = term_io_req_cnt_hld;
         end;

/* check for improper input */

         else if args (1) ^= "test" then		/* input must be "test piccdd" etc */
	  call ioa_ ("^as: (^a) invalid input;^/use ""test xx--""",
	   tolts_info.exec, com_string);
         else if args (2) = "msg" then			/* user wants to communicate with the operator */
	  call tolts_util_$opr_msg;
         else if args (2) = "pcd" then do;		/* user wants to get config */
	  if cmd_cnt = 3 then call tolts_pcd_ (((exec) || "  "), (args (3)));
	  else call tolts_pcd_ (((exec) || "  "), (""));
	  call reconnect;				/* reconnect ipc channel and give pcd a chance to come out */
	  call wakeup (tolts_info.wait_list.wait_event_id (1), null); /* wakeup the dispatcher */
	  return;
         end;
         else if tolts_info.exec = "polt" then		/* if running polts */
	  if search (args (2), "pwl") ^= 1 | length (args (2)) > 11
	   | substr (args (2), 1, 1) ^= "w" & length (args (2)) < 2 then /* improper input? */

	     call ioa_ ("^as: (^a) invalid input, use:^/^a, ^[^a,^;^s^] ^a, ^a, or ^a",

	      tolts_info.exec, com_string, """test piccddooooo""", (tolts_info.first_request_done),
	      """test pxiccddoooo""", """test w""", """test lstal""", """test pcd""");
	  else call test_request;			/* enter test_request */
         else if tolts_info.exec = "molt" then		/* if running molts */
	  if search (args (2), "lmnw") ^= 1		/* if one of these errors */
	   | length (args (2)) > 11
	   | substr (args (2), 1, 1) ^= "w" & length (args (2)) < 2
	   then call ioa_ ("^as: (^a) invalid input, use:^/^a, ^a, ^a,^/^a, ^a, ^a,^/^a, ^a, ^a,^/^a, ^a, ^a,^/^a, ^a, ^a,^/^a, ^a, or ^a",
	      tolts_info.exec, com_string,
	      """test mdciccooooo""", """test mdriccddooooo""", """test mhpiccooooo""",
	      """test mmticcddoooo""", """test mpciccooooo""", """test mpticcddooooo""",
	      """test mtgiccddoooo""", """test mxdciccoooo""", """test mxdriccddoooo""",
	      """test mxhpiccoooo""", """test mxmticcddoooo""", """test mxpciccoooo""",
	      """test mxpticcddoooo""", """test mxtgiccddoooo""", """test nioi""",
	      """test w""", """test lstal""", """test pcd""");
	  else if length (args (2)) > 2 then do;
	     if (substr (args (2), 1, 3) = "mpc" |
	      substr (args (2), 1, 3) = "mdr") &
	      tolts_info.first_request_done then	/* if user attempting to enter more than one page */
	        call ioa_ ("^as: (^a) only one mpc (itr) or mdr test request may be active at one time",
	         tolts_info.exec, com_string);
	     else call test_request;			/* enter test request */
	  end;

	  else call test_request;			/* enter test request */


         else if tolts_info.exec = "colt" then do;	/* if running colts */
	  if search (args (2), "cwl") ^= 1 |
	   length (args (2)) > 11
	   | substr (args (2), 1, 1) ^= "w" & length (args (2)) < 2 then do;
	     call ioa_ ("^as: (^a) invalid input, use: ^/^a, ^a, ^[^a, ^a,^;^2s^] ^a, ^a, or ^a",
	      tolts_info.exec, com_string, """test Cnccssooooo""", """test Cfrspd""",
	      (tolts_info.first_request_done), """test Cxccssoooo""", """test Cxfrspd""",
	      """test w""", """test lstal""", """test pcd""");
	     go to ck_first;
	  end;
	  if search (args (2), "wl") ^= 1
	   & search (args (2), "loew") ^= 2 then do;

	     if search (args (2), "rsp") ^= 0 then do;
	        do j = lbound (tolts_info.pages, 1) to hbound (tolts_info.pages, 1);
		 if ^pages (j).in_use then do;
		    io_info_ptr = addr (pages (j));
		    io_info.test_req.tt = "71"b3;
		    io_info.fnp_num = (bin (substr (args (2), 2, 1)));
		    j = 8;
		 end;
	        end;
	     end;
	     else do;
	        cdt_fnp = fnp_num (bin (substr (args (2), 2, 1)));
	        cdt_chn = chn_num (bin (substr (args (2), 3, 2)));
	        cdt_subchan = substr (args (2), 5, 2);
	        fnp (bin (substr (args (2), 2, 1))).exec_chan = cdt_fnp || "." || "c000";
	        do j = 1 to 8;
		 if substr (fnp (bin (substr (args (2), 2, 1))).cdt_name (j), 1, 5) = "empty" then do;
		    fnp (bin (substr (args (2), 2, 1))).cdt_name (j) = cdt_fnp || "." || cdt_chn || cdt_subchan;
		    j = 8;
		 end;
	        end;
	     end;
	  end;
	  call test_request;
	  if substr (args (2), 2, 3) = "rsp" then io_info.test_req.fnccss = substr (bcd_out, 7, 18);
         end;

         go to ck_first;				/* go reconnect */
      end;
      if page = 0 | page = 10 | tolts_info.exec_term_io_wait then /* if exec io or waiting to abort */
         go to ck_first;				/* go check if first request complete */
      if tolts_info.tadio (page).optrd then do;		/* test page looking for options */
         tolts_info.tadio (page).optrd = "0"b;		/* reset options flag */
         call tolts_util_$query ("", com_string, c_len, args, cmd_cnt); /* get user input */
         if c_len > 0 then do;			/* if something entered.. */
	  call tolts_alm_util_$ascii_to_bci_ (opt_str, bcd_opt); /* convert to bcd */
	  substr (tolts_info.tadio (page).option, 1, c_len * 6) = substr (bcd_opt, 1, c_len * 6); /* move to buffer */
         end;
      end;
      else tolts_info.tadio (page).inuse = "0"b;		/* release this tadio queue entry */
      i, tolts_info.exec_dta_cnt = tolts_info.exec_dta_cnt + 1; /* increment count */
      tolts_info.exec_dta (i).word (1) = tolts_info.tadio (page).return_word (1);
      tolts_info.exec_dta (i).word (2) = tolts_info.tadio (page).return_word (2);
      tolts_info.exec_dta (i).word (3) = tolts_info.tadio (page).return_word (3);
      call reconnect;				/* reconnect ipc channel */
      call wakeup (tolts_info.wait_list.wait_event_id (1), null); /* wake up dispatcher */
      return;					/* thats all folks */
%page;

/* reconnect - internal procedure to reconnect ipc channel */

reconnect: proc;

/* re enable io issuing */

      tolts_info.term_io_in_prog = "0"b;
      tolts_info.term_io_req_cnt = tolts_info.term_io_req_cnt - 1;
      call ipc_$reconnect (tolts_info.tty_issue_event, error);
      if error ^= 0 then do;				/* term process if error */
         call com_err_ (error, "tolts_ttyio_end_", "fatal error, terminating process");
         fatal_desc.version = 0;
         fatal_desc.fatal_code = error;
         call terminate_process_ ("fatal_error", addr (fatal_desc));
      end;
      call iox_$control (iox_$user_io, "start", null, error); /* allow cleanup of any blocks */
   end reconnect;

/* wakeup - internal procedure to issue wakeup to ipc wait channel */

wakeup: proc (e_chan, wakeup_ptr);

dcl  e_chan fixed bin (71);
dcl  wakeup_ptr ptr;

/*   issue wakeup to dispatcher   */

      call hcs_$wakeup (tolts_info.process, e_chan, wakeup_ptr, error);
      if error ^= 0 then do;				/* term process if error */
         call com_err_ (error, "tolts_ttyio_end_", "fatal error, terminating process");
         fatal_desc.version = 0;
         fatal_desc.fatal_code = error;
         call terminate_process_ ("fatal_error", addr (fatal_desc));
      end;
   end wakeup;

/* test_request - internal procedure to convert test request data and queue it up */

test_request: proc;

      ascii_in = args (2);				/* copy data to convert */
      substr (ascii_in, 12, 7) = "10000t/";		/* use coded logical terminal 1 and "t/" tty code */
      call tolts_alm_util_$ascii_to_bci_ (ascii_in, bcd_out); /* convert to bcd */
      i, tolts_info.exec_dta_cnt = tolts_info.exec_dta_cnt + 1; /* increment count */
      tolts_info.exec_dta (i).word (*) = bcd_request (*);	/* move the data to the queue */
      tolts_info.first_request_done = "1"b;		/* set flag for dispatcher */

   end test_request;
%page;
%include tolts_info;

   end tolts_ttyio_end_;




		    tolts_util_.pl1                 12/09/86  1539.4rew 12/09/86  1521.6      161703



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* Initially coded 6/78 by J. A. Bush
   Modified by Rich Coppola 9/29/81 to return value of iocbp if non-null so
   caller can clean up.
   Modified by R. Fakoury 3/16/83 to add the get_ttl_date entry.
   Modified by R. Fakoury 6/10/83 to add opr_msg facility.
   Modified by R. Fakoury 8/02/83 to fix a typo in opr_msg.
   Modified by R. Fakoury 10/84 to replace the internal proc, find_card with an external entry of find_card,
   and to remove the obsolete entry config.
*/




/****^  HISTORY COMMENTS:
  1) change(84-11-01,Fakoury), approve(86-08-21,MCR7514),
     audit(86-11-17,Martinson), install(86-12-04,MR12.0-1235):
     to add the dev0_valid entry.
     to change call hcs_$status_long to hcs_$status_minf.
                                                   END HISTORY COMMENTS */




/* tolts_util_ - a group of utility subroutines for TOLTS, MOLTS, POLTS, and ISOLTS */


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
tolts_util_: proc;


/* External entries */

dcl  decode_clock_value_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3));
dcl  (get_wdir_, get_default_wdir_) entry returns (char (168));
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl  hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
dcl  (ioa_, ioa_$nnl, ioa_$rsnnl, com_err_) entry options (variable);
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), 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_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$seek_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
dcl  object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  opr_query_ entry options (variable);


/* External static */

dcl  iox_$user_input ptr ext;

/* Entry parameters */

dcl  seg_name entry;
dcl  com_string char (132) aligned;
dcl  mess char (*);
dcl  c_args (32) char (28) varying;
dcl  rcode fixed bin (35);
dcl  cmd_cnt fixed bin;
dcl  c_len fixed bin;
dcl  (a_iocbp, c_ptr) ptr;
dcl  config_name char (4);
dcl  in bit (*);
dcl  out char (*) varying;
dcl  bci_len fixed bin;
dcl  c_name char (32);
dcl  exec char (6);
dcl  state char (3);
dcl  ttl_date char (6);

/* Automatic */

dcl  1 o_info like object_info;
dcl  (month, dom, year, dow) fixed bin;
dcl  tod fixed bin (71);
dcl  zone char (3);
dcl  ttl char (6);
dcl  bc fixed bin (24);
dcl  type fixed bin (2);
dcl  (i, j, lp, escape_cnt) fixed bin;
dcl  rec_len fixed bin (21);
dcl  seek_key char (256) varying;
dcl  ename char (32);
dcl  tim char (12);
dcl  cc char (1);
dcl  (temp_ptr, info_ptr, seg_ptr, iocbp) ptr;
dcl  cur_char bit (6);
dcl  bit_cnt fixed bin (24);
dcl  code fixed bin (35);				/* error code */
dcl  info (20) bit (36);
dcl  gki (20) bit (36);

/* Builtins */

dcl  (addr, addrel, before, date, divide, fixed, hbound, length, ltrim,
     null, rtrim, codeptr, ptr, reverse, search, substr, time, unspec, verify) builtin;

/* Based */

dcl  1 rsi like rs_info aligned;

dcl  1 cata_info based (c_ptr) aligned,			/* info structure for cata_sel entry */
       2 n_keys fixed bin,				/* number of multiple keys */
       2 cata_keys (1 refer (cata_info.n_keys)) char (24);	/* multiple key array */


/* Constants */

dcl  opn_ksi fixed bin int static options (constant) init (8);
dcl  bcd_to_ascii char (64) int static options (constant) init
      ("0123456789[#@:>? abcdefghi&.](<\^jklmnopqr-$*);'+/stuvwxyz_,%=""!");
dcl  lib_dir char (168) int static options (constant) init
      (">system_library_tandd");
dcl  WS char (2) int static options (constant) init (" 	");
dcl  NL char (1) int static options (constant) init ("
");
dcl  NP char (1) int static options (constant) init ("");

%page;

/* query - entry to query and get response from user */

query: entry (mess, com_string, c_len, c_args, cmd_cnt);

      cmd_cnt = 0;					/* initilize parameters */
      c_args = "";
m_retry:
      if length (rtrim (mess)) ^= 0 then		/* only print message if there */
         call ioa_$nnl (mess);			/* print out prompt for user */
      com_string = "";				/* clear out last command */
      call iox_$get_line (iox_$user_input, addr (com_string), length (com_string), rec_len, code);
      if code ^= 0 then do;				/* error reading from  terminal */
         call com_err_ (code, "tolts_util_$query", "reading input from user_input, re-enter");
         go to m_retry;
      end;
      substr (com_string, rec_len) = "";		/* strip out new_line */
      c_len = rec_len;				/* set command line length */
      if rec_len = 1 then return;			/* return if no message */

/* separate arguments into arg array */

      lp = 1;					/* start at beginning of line */
      do i = 1 to hbound (c_args, 1) while (lp < rec_len);
         j = length (ltrim (substr (com_string, lp, rec_len), WS)); /* strip off leading white space */
         lp = (rec_len - j) + lp;			/* lp = starting position of next string */
         j = search (substr (com_string, lp), WS);	/* find end of string */
         c_args (i) = substr (com_string, lp, j - 1);
         lp = lp + (j - 1);				/* update line position */
      end;
      cmd_cnt = i - 1;				/* set arg count for user */
      return;
%page;

/* on_off - entry to display greeting or signoff message from executives */

on_off: entry (exec, state, ttl_date);


      tim = time;

/* output message */

      call ioa_ ("^/***^a executive version ^a ^a ^a at ^a", exec, ttl_date, state, date,
       substr (tim, 1, 2) || "." || substr (tim, 3, 3));

      return;
%page;

/* bci_to_ascii - entry to convert bcd with imbedded escape and ignore characters to ascii */

bci_to_ascii: entry (in, out, bci_len);

      out = "";					/* pad output string with blanks */
      escape_cnt = 0;				/* initialize escape_cnt */

      do i = 1 to bci_len;				/* go through entire input string */
         cur_char = substr (in, 6 * (i - 1) + 1, 6);	/* pick up current bcd char */
         if escape_cnt = 2 then			/* if 2 times through here... */
	  go to use_char;				/* convert the character */
         else if cur_char = "77"b3 then			/* escape character */
	  escape_cnt = escape_cnt + 1;		/* increment escape count */
         else if escape_cnt = 1 then do;		/* if only 1 escape... */
	  lp = fixed (cur_char, 6);			/* get slew count */
	  if lp = 0 then lp = 1;
	  if lp >= 16 then				/* if slew to top of page */
	     out = out || NP;			/* set new page charater in out string */
	  else do j = 1 to lp;			/* put in correct number off new lines */
	     out = out || NL;
	  end;
	  escape_cnt = 0;				/* clear out escape cnt */
         end;
         else if cur_char = "17"b3 then			/* ignore character */
	  escape_cnt = 0;
         else do;					/* valid bcd character */
use_char:
	  cc = substr (bcd_to_ascii, fixed (cur_char, 6) + 1, 1); /* extract current char from table */
	  if cc = ")" | cc = "," then do;		/* check for white space before close paren or comma */
	     j = verify (reverse (out), WS);		/* find leading blank or tab */
	     if j ^= 1 then				/* if we found some */
	        out = substr (out, 1, length (out) - j + 1); /* wipe it out */
	  end;
	  out = out || cc;				/* add in current character */
	  escape_cnt = 0;
         end;
      end;

      return;
%page;

/* search - entry to find and return a pointer to a test page */

search: entry (a_iocbp, c_name, c_ptr, c_len, rcode);

      temp_ptr, c_ptr = null;				/* preset return parameters */
      rcode, c_len = 0;
      iocbp = a_iocbp;				/* copy dkfile iocb ptr */
      ename = c_name;				/* copy search name */

/* attempt to initiate the segment first in working dir, home dir and then in sys lib */

      call hcs_$initiate_count ((get_wdir_ ()), ename, "", bit_cnt, 0, temp_ptr, code);
      if temp_ptr = null then				/* no find, check home dir */
         call hcs_$initiate_count ((get_default_wdir_ ()), ename, "", bit_cnt, 0, temp_ptr, code);
      if temp_ptr = null then				/* no find, check sys dir */
         call hcs_$initiate_count (lib_dir, ename, "", bit_cnt, 0, temp_ptr, code);
      if temp_ptr ^= null then do;			/* found it, return to user */
         c_ptr = temp_ptr;				/* copy seg ptr */
         c_len = divide (bit_cnt, 36, 17, 0);
         return;
      end;

/* couldn't find entry as a ssf, now lets check to see if we have a deckfile */

      if iocbp = null then do;			/* deckfile not attached */
         call find_deckfile ((get_wdir_ ()));		/* try to find deckfile in working dir */
         if code ^= 0 then				/* no deck file there, try sys dir */
	  call find_deckfile (lib_dir);
         if code ^= 0 then do;			/* still couln't find it, return */
	  rcode = code;				/* give user the error */
	  return;
         end;
      end;
      call find_record;				/* go find desired record */
      if code = 0 then do;				/* found it ok */
         a_iocbp = iocbp;				/* return good iocb ptr to user */
         c_ptr = rsi.record_ptr;			/* return ptr to deckfile record */
         c_len = divide (rsi.record_length, 4, 17, 0);	/* and record word length */
      end;
      else rcode = code;				/* else return error */
      return;
%page;
/* cata_sel - entry to find all catalog search keys, given search key head */

cata_sel: entry (a_iocbp, c_name, c_ptr, rcode);

      rcode = 0;
      iocbp = a_iocbp;				/* copy dkfile iocb ptr */
      ename = c_name;				/* copy search name */
      info_ptr = addr (info);				/* set info ptrs */
      unspec (info) = "0"b;				/* clear structure first */
      if iocbp = null then do;			/* deckfile not attached */
         call find_deckfile ((get_wdir_ ()));		/* try to find deckfile in working dir */
         if code ^= 0 then				/* no deck file there, try sys dir */
	  call find_deckfile (lib_dir);
         if code ^= 0 then do;			/* still couln't find it, return */
	  rcode = code;				/* give user the error */
	  if iocbp ^= null then
	     a_iocbp = iocbp;			/* let caller clean up */
	  return;
         end;
      end;
      a_iocbp = iocbp;				/* copy iocb ptr back */
      common_sl_info.version = sl_info_version_0;
      common_sl_info.list_type = 1;			/* set to reuse subset */
      common_sl_info.output_descriptors = "1"b;		/* want descriptors */
      common_sl_info.array_limit = 1;			/* 1 element array */
      common_sl_info.desc_arrayp = null;		/* let vfile_ allocate area for storage */
      hi_sl_info.first_head (1).length, hi_sl_info.last_head (1).length = length (rtrim (ename));
      hi_sl_info.first_head (1).kptr, hi_sl_info.last_head (1).kptr = addr (ename);
      call iox_$control (iocbp, "select", addr (info), code); /* get select info */
      if code ^= 0 then do;				/* problem with select */
         rcode = code;
         return;
      end;
      call iox_$position (iocbp, -1, 0, code);		/* position to beginning of file */
      if code ^= 0 then do;				/* problem with select */
         rcode = code;
         return;
      end;
      cata_info.n_keys = common_sl_info.count;		/* copy number of descriptors */
      gk_info_ptr = addr (gki);			/* set info ptr */
      unspec (gki) = "0"b;				/* clear structure first */
      gk_info.input_desc = "1"b;			/* using input descriptors */
      gk_info.reset_pos = "1"b;			/* don't change position */
      do i = 1 to common_sl_info.count;			/* find each key */
         gk_info.descrip = desc_array (i);		/* insert each descriptor */
         call iox_$control (iocbp, "get_key", addr (gki), code);
         if code ^= 0 then do;			/* error */
	  rcode = code;
	  return;
         end;
         cata_info.cata_keys (i) = gk_info.key;		/* copy key */
      end;
      common_sl_info.list_type = 0;			/* set to reuse subset */
      common_sl_info.subset_no = 0;
      common_sl_info.array_limit = 0;			/* 0 element array */
      common_sl_info.desc_arrayp = null;		/* let vfile_ allocate area for storage */
      call iox_$control (iocbp, "select", addr (info), code); /* reset current subset */
      return;					/* thats it folks */
%page;

/* find_deckfile - int procedure to search for tandd_deck_file and return desired record info if found */

find_deckfile: proc (dir);

dcl  deckfile_dir char (168);
dcl  dir char (168);
dcl  type fixed bin (2) init (0);

      call hcs_$status_minf (dir, "tandd_deck_file", 1, type, 0, code);
      if type = 2 then do;				/* found deck file 0 = link, 1 = seg, 2 = dir */

/* attach and open deck file for keyed seq input */

         call iox_$attach_name ("dk_file_sw", iocbp, "vfile_ " || rtrim (dir) || ">tandd_deck_file", null, code);
         if code ^= 0 then return;

         call iox_$open (iocbp, opn_ksi, "0"b, code);	/* attach ok, open it */
         if code ^= 0 then return;

         unspec (rsi) = "0"b;				/* clear structure */
         rsi.version = rs_info_version_2;		/* set proper version for vfile_ */
         call iox_$control (iocbp, "record_status", addr (rsi), code); /* get record info */
         if code ^= 0 then return;

         call hcs_$fs_get_path_name (rsi.record_ptr, deckfile_dir, 0, "", code); /* code always = 0 */

         if before (deckfile_dir, ">tandd_deck_file") ^= lib_dir then
	  call ioa_ ("Using ^a", deckfile_dir);
      end;

   end find_deckfile;

/* find_record - int precdure to find desired record in deckfile */

find_record: proc;

      seek_key = ename;				/* copy search key */
      call iox_$seek_key (iocbp, seek_key, rec_len, code);	/* find record */
      if code = 0 then do;				/* record exists, get record info */
         unspec (rsi) = "0"b;				/* clear structure */
         rsi.version = rs_info_version_2;		/* set proper version for vfile_ */
         call iox_$control (iocbp, "record_status", addr (rsi), code); /* get record info */
      end;

   end find_record;
%page;

/* find_card - external procedure to search config deck for desired config card */

find_card: entry (config_name, cardp);

%include config_deck;

dcl  config_deck_end fixed bin based (addr (config_card.word));

      if cardp = null then				/* if pointer is null, set it  */
         cardp = addr (config_deck$);
      else cardp = addrel (cardp, 16);			/* else go to next card */

      do while (config_deck_end ^= -1);			/* go through entire deck if necessary */
         if config_card.word = config_name then		/* found the right card */
	  return;
         else cardp = addrel (cardp, 16);		/* get next card */
      end;
      cardp = null;					/* did'nt find it */
      return;
%page;

/* get_ttl_date - entry to find date a obj seg was compiled */

get_ttl_date: entry (seg_name, ttl_date);



      seg_ptr = ptr (codeptr (seg_name), 0);
      o_info.version_number = 2;
      call hcs_$status_mins (seg_ptr, type, bc, code);
      call object_info_$display (seg_ptr, bc, addr (o_info), code);
      call decode_clock_value_ (o_info.compile_time, month, dom, year, tod, dow, zone);
      year = year - 1900;
      call ioa_$rsnnl ("^d^[0^]^d^[0^]^d", ttl, i, year, (month < 10), month, (dom < 10), dom);
      ttl_date = ttl;
      return;
%page;

/* opr_msg - internal procedure to send messages to the operator */


opr_msg: entry;

dcl  tolts_util_$query entry (char (*), char (132) aligned, fixed bin, (32) char (28) var, fixed bin);
dcl  d fixed bin (71) init (1);
dcl  c_string char (132) aligned;
dcl  (clen, c_cnt) fixed bin;
dcl  cargs (32) char (28) varying;


      call ioa_ ("^/enter 1 line message of up to 80 characters");
      call tolts_util_$query ("??? ", c_string, clen, cargs, c_cnt);
      if substr (c_string, clen - 1, 1) = "?" then do;
         opr_query_info.q_sw = "1"b;
         opr_query_info.prim = "";
         opr_query_info.alt = "";
         opr_query_info.r_comment = "Please reply: x oqr followed by message of up to 80 characters";
         if clen > 80 then clen = 80;			/* truncate message length if necessary */
         call opr_query_ (addr (opr_query_info), substr (c_string, 1, clen));
         call ioa_ ("^a", opr_query_info.answer);
      end;
      else do;
         opr_query_info.q_sw = "0"b;			/* no operator response needed */
         call opr_query_ (addr (opr_query_info), substr (c_string, 1, clen));
      end;
      return;


%page;
/*
   The following function returns the value of the first
   disk driver in a string .
*/

dev0_valid: entry (cdp, Model) returns (bit (1));


dcl  (Model, nnames) fixed bin;
dcl  cdp ptr;
dcl  1 cd_model_info based (cdp) aligned,
       2 count fixed bin,
       2 names (nnames) aligned,
         3 model fixed bin,
         3 name char (8),
         3 dev_0_valid bit (1);


      nnames = cd_model_info.count;
      do i = 1 to cd_model_info.count while (cd_model_info.names (i).model ^= Model);
      end;
      if cd_model_info.names (i).dev_0_valid then return ("1"b);
      else return ("0"b);

%page;
%include ak_info;
%page;
%include object_info;
%page;
%include opr_query_info;
%page;
%include rs_info;
%page;
%include select_info;
%page;
%include status_structures;



   end tolts_util_;





		    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
