1 /****^  ************************************************************
   2         *                                                          *
   3         * Copyright, (C) Honeywell Information Systems Inc., 1983  *
   4         *                                                          *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1980. *
   6         *                                                          *
   7         * Copyright (c) 1972 by Massachusetts Institute of         *
   8         * Technology and Honeywell Information Systems, Inc.       *
   9         *                                                          *
  10         ************************************************************ */
  11 
  12 
  13 
  14 
  15 
  16 /* mtdsim_ - (Multics T & D Slave Interface Module) Procedure to drive the gcos T & D Modules
  17    known as slave mode polt and slave mode molt (and eventually slave mode colt)
  18    originally coded by J. K. Rhodes 4Q/1977
  19    extensive modification by J. A. Bush 9/78
  20    code added to drive slave mode molts by J. A. Bush 2/79
  21    initial release - MR7.0A
  22    Modified by J. A. Bush 12/79 for static mme handler and to handle new deckfile catalog format
  23    Modified by G. Haney & R. Fakoury  80/03/24 to handle mtar
  24    Modified by J. A. Bush 5/80 for several performance enhancements
  25    Modified by R. Fakoury 8/80 to handle the error return of "file not found" for a MME GCALL more cleanly.
  26    Modified by R. Fakoury 8/80 to handle dcw tally of 4096 correctly and to handle an incorrect density from rcp_.
  27    Modified by R. Fakoury 10/80 to set lostit_time = rcp_ max timeout.
  28    Modified by R. Fakoury 12/80 for colts implementation.
  29    Modified by R. Fakoury 10/81 to improve the quit handler.
  30    Modified by R. Fakoury 11/81 to attach the mpc for disk and tape mdrs.
  31    Modified by R. Fakoury 11/81 to dump the test exec when a machine fault is en countered.
  32    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.
  33    Modified by R. Fakoury 03/17/82 to redesign mme allocr handler making it more effecient.
  34    Modified by R. Fakoury 04/82 to change mme feptype interface, to add a timer for colts attachments,
  35    add cleanner wrapup sequences for colts attach errors, and to add eurc pr54 support.
  36    Modified by R. Fakoury 09/30/82 to change illegal zero dcws to a valid single xfer dcw and output a message.
  37    Modified by R. Fakoury 11/01/82 to correct problem in Colts wrap-up & add 128 chan support.
  38    Modified by R. Fakoury 01/07/83 to increase the value of iom table words read from the fnp.
  39    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.
  40    Modified by Rick Fakoury 03/16/83 to add a call to tolts_util_$get_ttl_date.
  41    Modified by R. Fakoury 09/83 to correct a 128chan bug.
  42    Modified by R. Fakoury 11/84 for hyperchan i/o.
  43    Modified by R.Fakoury 01/84 to accept multiple args & to implement a debugger for the slave execs.
  44    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.
  45    Modified by R Fakoury 09/84 to correct a problem in get_px_tcx which caused io_sel to be invalid.
  46    Modified by R Fakoury & Benson Margulies 10/84 to correct problems encountered with new AS,
  47    to add more debugging functions, and to use convert_status_code instead of com_err.
  48 */
  49 
  50 
  51 
  52 
  53 
  54 /****^  HISTORY COMMENTS:
  55   1) change(1985-02-01,Fakoury), approve(1986-08-20,MCR7514),
  56      audit(1986-12-09,Martinson), install(1986-12-09,MR12.0-1235):
  57       implement the test nio request (Dipper/MCA) with add debug aides,
  58       implement extented status store,
  59       further correct a problem in get_px_tcx,
  60       prevent returning to the subexec after a fault dump,
  61       support of a test rsp request (responder/DN8) with added debug aides,
  62       to dump machine conditions and history regs,
  63       to increase the bar value,
  64       to increase the timeout time for printer mdrs,
  65       to correct a problem encountered while attempting an attach for colts,
  66       to correct poorly written error messages.
  67   2) change(1986-12-18,Fakoury), approve(1986-12-18,MCR7514),
  68      audit(1986-12-18,Martinson), install(1986-12-19,MR12.0-1252):
  69      PBF to correct an error in MME POINTIT that returns the IO system type.
  70   3) change(1986-12-19,Fakoury), approve(1986-12-19,MCR7514),
  71      audit(1987-01-05,Martinson), install(1987-01-05,MR12.0-1254):
  72      Modified to correct a problems in MME DATA. One problem was caused by a
  73      change in the mca driver interface and the other problem was in the trace
  74      function.
  75   4) change(1987-01-06,Fakoury), approve(1987-01-06,MCR7514),
  76      audit(1987-01-07,Martinson), install(1987-01-08,MR12.0-1263):
  77      Corrected a Colt attachment problem by increasing the no responce count,
  78      corrected a problem in releasing the channel when a failure occurs.
  79   5) change(2021-10-24,Swenson), approve(2021-10-31,MCR10096),
  80      audit(2021-11-04,GDixon), install(2021-11-04,MR12.8-1005):
  81      Fix fault_tag_1 error when POLTS test page gets a lockup fault.
  82                                                    END HISTORY COMMENTS */
  83 
  84 
  85 
  86 
  87 
  88 
  89 /* mtdsim_ - (Multics T & D Slave Interface Module) Procedure to drive the gcos T & D Modules
  90    known as slave mode polt and slave mode molt (and eventually slave mode colt)
  91 */
  92 
  93 
  94 /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
  95 
  96 mtdsim_: proc;
  97 
  98 
  99 /* External entries */
 100 
 101 dcl  bcd_to_ascii_ entry (bit (*) aligned, char (*));
 102 dcl  com_err_ entry () options (variable);
 103 dcl  continue_to_signal_ entry (fixed bin (35));
 104 dcl  convert_dial_message_$return_io_module entry (fixed bin (71), char (*), char (*), fixed bin, 1 aligned,
 105       2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, 2 bit (33) unal, fixed bin (35));
 106 dcl  convert_status_code_ entry (fixed bin (35), char (*), char (*));
 107 dcl  cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin);
 108 dcl  cu_$arg_count entry (fixed bin);
 109 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 110 dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
 111 dcl  dial_manager_$privileged_attach entry (ptr, fixed bin (35));
 112 dcl  dial_manager_$release_channel entry (ptr, fixed bin (35));
 113 dcl  dial_manager_$release_channel_no_listen entry (ptr, fixed bin (35));
 114 dcl  dial_manager_$tandd_attach entry (ptr, fixed bin (35));
 115 dcl  db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35));
 116 dcl  db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35));
 117 dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
 118 dcl  gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35));
 119 dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), ptr, fixed bin (35)); /* arg 3 is suppose to be fixed bin (71) */
 120 dcl  hcs_$get_ips_mask entry (bit (36) aligned);
 121 dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
 122 dcl  (ioa_, ioa_$rsnnl) entry () options (variable);
 123 dcl  ioi_$connect entry (fixed bin (12), fixed bin (18), fixed bin (35));
 124 dcl  ioi_$release_devices entry (fixed bin (12), fixed bin (35));
 125 dcl  ioi_$set_channel_required entry (fixed bin (12), fixed bin (3), fixed bin (6), fixed bin (35));
 126 dcl  ioi_$set_status entry (fixed bin (12), fixed bin (18), fixed bin (8), fixed bin (35));
 127 dcl  ioi_$suspend_devices entry (fixed bin (12), fixed bin (35));
 128 dcl  ioi_$timeout entry (fixed bin (12), fixed bin (52), fixed bin (35));
 129 dcl  ioi_$workspace entry (fixed bin (12), ptr, fixed bin, fixed bin (35));
 130 dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
 131 dcl  iox_$close entry (ptr, fixed bin (35));
 132 dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
 133 dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
 134 dcl  iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
 135 dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
 136 dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
 137 dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
 138 dcl  ioi_$connect_pcw entry (fixed bin (12), fixed bin (18), bit (36), fixed bin (35));
 139 dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
 140 dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
 141 dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
 142 dcl  ipc_$read_ev_chn entry (fixed bin (71), fixed bin, ptr, fixed bin (35));
 143 dcl  mca_$attach_ipc entry (char (*), fixed bin, fixed bin, fixed bin (35));
 144 dcl  mca_$attach_mca entry (char (*), fixed bin (71), fixed bin, fixed bin (35));
 145 dcl  mca_$detach_ipc entry (char (*), fixed bin, bit (1), fixed bin (35));
 146 dcl  mca_$detach_mca entry (fixed bin, fixed bin (35));
 147 dcl  mca_$load_ipc entry (fixed bin, fixed bin, bit (36), fixed bin (35));
 148 dcl  mca_$tandd_read_data entry (fixed bin, ptr, fixed bin, bit (36), fixed bin (35));
 149 dcl  mca_$tandd_write_data entry (fixed bin, ptr, fixed bin, bit (36), fixed bin (35));
 150 dcl  mca_$tandd_write_text entry (fixed bin, ptr, fixed bin, bit (36), fixed bin (35));
 151 dcl  mca_$reset entry (fixed bin, bit (36), fixed bin (35));
 152 dcl  opr_query_ entry () options (variable);
 153 dcl  rcp_$attach entry (char (*) aligned, ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35));
 154 dcl  rcp_$check_attach entry (bit (36) aligned, ptr, char (*), fixed bin (12),
 155       fixed bin (19) aligned, fixed bin (71) aligned, fixed bin, fixed bin (35));
 156 dcl  rcp_$detach entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));
 157 dcl  rcp_priv_$attach entry (char (*) aligned, ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35));
 158 dcl  probe entry options (variable);
 159 dcl  terminate_process_ entry (char (*), ptr);
 160 dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));
 161 dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
 162 dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
 163 dcl  tolts_alm_util_$ascii_to_bcd_ entry (char (*), bit (*));
 164 dcl  tolts_alm_util_$enter_ccc_req_ entry (ptr, bit (36));
 165 dcl  tolts_alm_util_$enter_slave_ entry (ptr);
 166 dcl  tolts_alm_util_$gen_ck_sum entry (ptr);
 167 dcl  tolts_alrm_util_$quit entry;
 168 dcl  tolts_device_info_ entry (ptr, fixed bin, fixed bin);
 169 dcl  tolts_file_util_$close entry;
 170 dcl  tolts_file_util_$open entry (fixed bin (35));
 171 dcl  tolts_file_util_$snap entry (ptr);
 172 dcl  tolts_file_util_$wdump entry (ptr);
 173 dcl  tolts_load_firmware_ entry (fixed bin, fixed bin (35));
 174 dcl  tolts_init_ entry (char (4), fixed bin (35));
 175 dcl  tolts_init_$clean_up entry;
 176 dcl  tolts_init_$cr_event_chan entry (fixed bin (71), bit (1), entry, ptr, fixed bin, fixed bin (35));
 177 dcl  tolts_io_int_ entry;
 178 dcl  tolts_qttyio_ entry (char (*), fixed bin);
 179 dcl  tolts_qttyio_$dcw_list entry (ptr, fixed bin);
 180 dcl  tolts_qttyio_$dcw_ptr entry (ptr, fixed bin, fixed bin);
 181 dcl  tolts_qttyio_$rcw entry (ptr);
 182 dcl  tolts_qttyio_$rs entry () options (variable);
 183 dcl  tolts_util_$cata_sel entry (ptr, char (32), ptr, fixed bin (35));
 184 dcl  tolts_util_$find_card entry (char (4), ptr);
 185 dcl  tolts_init_$gc_tod entry (bit (36));
 186 dcl  tolts_util_$get_ttl_date entry (entry, char (6));
 187 dcl  tolts_util_$search entry (ptr, char (32), ptr, fixed bin, fixed bin (35));
 188 
 189 /* AUTOMATIC */
 190 
 191 dcl  bufp ptr;
 192 dcl  (nargs, return_value, c_len, n_dialed, len, tio, dealc_err, ev_occurred,
 193      i, j, mesg_len, ndcws, tally, t_err) fixed bin init (0);
 194 dcl  (chan_name, io_module) char (32);
 195 dcl  (error, c_error, mem_needed) fixed bin (35) init (0);
 196 dcl  filename_idx fixed bin;
 197 dcl  lvl_idx fixed bin;
 198 dcl  imu_found bit (1) init ("0"b);
 199 dcl  iom_found bit (1) init ("0"b);
 200 dcl  iom fixed bin (3), chan fixed bin (6), tio_off fixed bin (18), timeout_time fixed bin (52) init (0);
 201 dcl  cpu_time fixed bin (71);
 202 dcl  wake_time fixed bin (71) init (500000);
 203 dcl  mem_now fixed bin (19);
 204 dcl  (pcwa, bcd_callname, gcos_tod) bit (36);
 205 dcl  b18 bit (18);
 206 dcl  bit_buf bit (72);
 207 dcl  pad_char bit (6);
 208 dcl  sb_data_idx fixed bin;
 209 dcl  ws_data_idx fixed bin;
 210 dcl  (argptr, train_ptr, tp, cltp, t_ptr, ioe_ptr, l_ptr, gcatp, info_ptr) ptr;
 211 dcl  coment char (256), shortinfo char (8), lginfo char (100), message char (512), ac_name char (6);
 212 dcl  workspace_move char (c_len * 4) based (bufp);
 213 
 214 
 215 /* INTERNAL STATIC */
 216 
 217 dcl  (gicm_count, io_sel, isc_cntdn, last_mme, mme_number, nr_cnt) fixed bin int static init (0);
 218 dcl  (term, gndc_flag, found, gelbar, glb_brk, in_ccc, isc_ccc_rqt, mpc_io, trace_save, debug, debugging,
 219      rd_blk, flt_flag, alt_flag, q_flag, rd_flag, tcd, trace_io, trace, itr_run) bit (1) aligned int static init ("0"b);
 220 dcl  tolts_active bit (1) aligned int static init ("0"b);   /* flag for epilogue handler */
 221 dcl  db_addr fixed dec int static;
 222 dcl  exec char (4) int static;
 223 dcl  ttl_date char (6) int static;
 224 dcl  (old_mask, new_mask) bit (36) aligned int static;
 225 dcl  clt_sw char (32) varying int static;
 226 dcl  io_block_len fixed bin;
 227 dcl  (gicmp, icmp, mvp, ricmp, ticmp, wicmp) ptr int static init (null);
 228 dcl  (l, k) fixed bin (6) int static;
 229 dcl  code fixed bin (35) init (0) int static;
 230 dcl  db_sv_wd bit (36) int static;
 231 dcl  (gerout_num, icm_tally, fnp_addr, fnp_num, remote_inquiry_ic) fixed bin int static;
 232 dcl  att_desc char (40) int static;
 233 dcl  (mmep, genp) ptr int static;
 234 dcl  (arglen, n_read) fixed bin (21) int static;
 235 dcl  blk_lbl label int static;
 236 dcl  emsg char (40) int static;
 237 dcl  term_lbl label int static;
 238 dcl  no_blk label int static;
 239 
 240 /* EXTERNAL STATIC */
 241 
 242 dcl  error_table_$bad_command_name fixed bin (35) ext static;
 243 dcl  error_table_$force_unassign external fixed bin (35);
 244 dcl  error_table_$resource_unavailable external fixed bin (35);
 245 dcl  printer_images_$n_images fixed bin external;
 246 dcl  printer_images_$image_base external;
 247 dcl  printer_images_$image_offsets (10) fixed bin (18) external;
 248 dcl  printer_images_$image_numbers (10) fixed bin external;
 249 dcl  sys_info$alrm_mask bit (36) aligned ext;
 250 
 251 /* BASED */
 252 
 253 dcl  arg char (arglen) based (argptr);
 254 dcl  data_move char (c_len * 4) based (mvp);
 255 dcl  prt_image (64) char (288) based unaligned;
 256 dcl  exec_wd (0:210000) bit (36) based (execp);
 257 dcl  ioe (11) bit (36) based (ioe_ptr);
 258 dcl  reg_move bit (36 * 8) based aligned;
 259 dcl  fix_wd (2) fixed bin (18) unsigned unaligned based (genp);
 260 dcl  sctwrk (12) bit (36) based (genp);
 261 dcl  mme_call_w (0:11) bit (36) based (mmep) aligned;       /* mme call template for full words */
 262 dcl  1 mme_call_hw (0:11) based (mmep) aligned,             /* mme template for half words */
 263        (2 upper bit (18),
 264        2 lower bit (18)) unaligned;
 265 
 266 dcl  1 mme_call_hf (0:11) based (mmep) aligned,             /* mme template for fixed half words */
 267        (2 upper fixed bin,
 268        2 lower fixed bin) unaligned;
 269 
 270 /* STRUCTURES */
 271 
 272 /* The following structure declaration defines the gcos slave prefix area as used by the slave
 273    mode execs. Only areas used by the execs have been defined, the remaining area is set to
 274    padx. For a full description of the gcos slave prefix area, refer to gcos manual DD19. */
 275 
 276 dcl  1 spa based (execp) aligned,                           /* slave prefix area, 0 - 77 of slave pgm */
 277        (2 user_fault (0:10) bit (36),                       /* 0 - 12 = user settable fault vectors */
 278        2 abort,                                             /* 13 = used for aborting slave pgm */
 279          3 add bit (18),                                    /*  U = abort address */
 280          3 code bit (18),                                   /*  L = abort reason code */
 281        2 pad1 (5) bit (36),
 282        2 glbtmr bit (36),                                   /* 21 = gelbar mode timer setting */
 283        2 glbici,                                            /* 22 = gelbar ic and i value */
 284          3 ic bit (18),                                     /*  U = instruction counter value */
 285          3 ind bit (18),                                    /*  L = indicator register */
 286        2 glbflt bit (36),                                   /* 23 = gelbar fault vector */
 287        2 pad2 (3) bit (36),
 288        2 wrapup_add bit (18),                               /* 27 = exec wrap up address */
 289        2 pad3 bit (18),
 290        2 pad4 bit (36),
 291        2 acc_fault bit (36),                                /* 31 = accumulated fault status word */
 292        2 enter,                                             /* 32 = entry into exec always at this point */
 293          3 lreg bit (36),                                   /* 32 = "lreg  spa.regs" instruction */
 294          3 lbar,                                            /* 33 = "lbar  bar,du" instruction */
 295            4 bar bit (18),                                  /*  U = bar value to load */
 296            4 inst bit (18),                                 /*  L = "230203"b3 (lbar  bar,du) */
 297          3 ret bit (36),                                    /* 34 = "ret  spa.enter.icivlu" instruction */
 298          3 icivlu,                                          /* 35 = return ic and i value */
 299            4 ic bit (18),                                   /*  U = instruction counter */
 300            4 ind bit (18),                                  /*  L = indicator register */
 301        2 ccc_icivlu bit (36),                               /* 36 = ic and i storage while in courtesy call */
 302        2 pad5 bit (36),
 303        2 regs like mc.regs,                                 /* 40 = return register storage */
 304        2 ccc_regs like mc.regs,                             /* 50 = courtesy call register storage */
 305        2 pad6 (16) bit (36)) unaligned;
 306 
 307 dcl  1 fatal_desc aligned,
 308        2 version fixed bin,
 309        2 fatal_code fixed bin (35);
 310 
 311 dcl  1 ci aligned like condition_info;
 312 
 313 dcl  1 event_out static aligned like event_wait_info;
 314 
 315 dcl  1 flags aligned,
 316        2 dialed_up bit (1) unal,
 317        2 hung_up bit (1) unal,
 318        2 control bit (1) unal,
 319        2 pad bit (33) unaligned;
 320 
 321 dcl  1 cata based (io_info.catp) aligned,                   /* template for deckfile catalog */
 322        2 n fixed bin,                                       /* number of entries */
 323        2 key (1 refer (cata.n)) char (24);                  /* array of key names */
 324 
 325 dcl  1 mca_gcata (100) based (gcatp) aligned,
 326          (2 equip_type bit (36),
 327        2 cat_index fixed bin,
 328        2 nblk fixed bin (13),
 329        2 dipper_flag bit (4),
 330        2 filename,
 331          3 filename bit (48),
 332          3 diskette_prod_tab bit (12),
 333          3 prog_tab bit (12)) unaligned;
 334 
 335 
 336 dcl  1 gcata (1000) based (gcatp) aligned,                  /* template for a gcos catalog entry */
 337        (2 edit_rev bit (36),                                /* bcd edit name and rev */
 338        2 cat_index fixed bin,                               /* deckfile catalog index */
 339        2 pad1 bit (3),
 340        2 nblk fixed bin (14),                               /* (same as cat_index) */
 341        2 ident bit (36),                                    /* word 0 of ident blk */
 342        2 purpose bit (36)) unaligned;                       /* deck purpose (itr, mdr or fw) */
 343 
 344 /* The following structure declaration defines the gcos 11 word I/O  entry  as  used  by  the
 345    slave  mode  execs.  Only areas used by the execs have been defined, the remaining area is
 346    set to padx. For a full description of the gcos I/O entry, refer to gcos manual DD14. */
 347 
 348 dcl  1 io_entry based (ioe_ptr) aligned,                    /* :: */
 349        (2 pad1 bit (36),                                    /* word 0 unused */
 350        2 ext_sts fixed bin,                                 /* extented status address */
 351        2 pad2 bit (18),
 352        2 pad3 bit (5),
 353        2 sct_add bit (13),                                  /* system config table entry (test page index) */
 354        2 pad4 bit (18),
 355        2 pad5 bit (36),
 356        2 prim,                                              /* primary device info */
 357          3 dev_cmd bit (6),                                 /* device command */
 358          3 dev bit (6),                                     /* punch indicator if not "00"b3 */
 359          3 pad6 bit (6),
 360          3 io_cmd bit (6),                                  /* iom command */
 361          3 pad7 bit (6),
 362          3 record_count bit (6),                            /* idcw/pcw record count */
 363        2 first_dcw like dcw,                                /* first dcw relative to iom lal */
 364        2 pad8 bit (36),
 365        2 second,                                            /* secondary device info (the same as prim unless dual cmd) */
 366          3 dev_cmd bit (6),                                 /* device command */
 367          3 prex bit (12),                                   /* preselect index */
 368          3 io_cmd bit (6),                                  /* iom command */
 369          3 pad9 bit (5),
 370          3 ignore_term bit (1),                             /* ignore terminate int, report special int if on */
 371          3 record_count bit (6),                            /* idcw/pcw record count */
 372        2 dcw_ptr fixed bin,                                 /* pointer to dcw list (offset to lal) */
 373        2 pad10 bit (18),
 374        2 stat_p bit (18),                                   /* ptr to place to store status */
 375        2 ccc_p bit (18),                                    /* courtesy call ptr */
 376        2 pad11 bit (36)) unaligned;
 377 
 378 dcl  1 colts_op_flags aligned ext static,
 379        2 colt_flag bit (1) unaligned init ("0"b),
 380        2 dm_attach bit (1) unaligned init ("0"b),
 381        2 dm_detach bit (1) unaligned init ("0"b),
 382        2 sicm bit (1) unaligned init ("0"b),
 383        2 gicm bit (1) unaligned init ("0"b);
 384 
 385 dcl  1 gicm based (gicmp) aligned,
 386        2 cltp ptr init (null),
 387        2 ricmp ptr init (null),
 388        2 cc_addr bit (36),
 389        2 st_addr fixed bin,
 390        2 tally fixed bin (21);
 391 
 392 
 393 dcl  1 ricm like icm based (ricmp);
 394 dcl  1 wicm like icm based (wicmp);
 395 dcl  1 ticm like icm based (ticmp);
 396 dcl  1 icm based (icmp) aligned,
 397        (2 word_total bit (18),
 398        2 rbuf_addr bit (18),
 399        2 cksum bit (18),
 400        2 test_id bit (18),
 401        2 host_opcode bit (18),
 402        2 fnp_opcode bit (18),
 403        2 icm_buf (icm_tally) bit (36)) unaligned;
 404 
 405 dcl  1 info_struct based (info_ptr) aligned,
 406        2 ev_chan fixed bin (71),
 407        2 out_pend bit;
 408 
 409 
 410 /* constants */
 411 
 412 dcl  (quit, lockup, illop, illegal_modifier, illegal_opcode, illegal_procedure,
 413      store, program_interrupt, cleanup, tolts_error_) condition;
 414 dcl  (addr, addrel, bin, bit, divide, fixed, index, length, null, rel, rtrim, string, substr, time, unspec) builtin;
 415 %page;
 416 /* enviornment initialization */
 417 
 418       debug, debugging, q_flag, trace_io, trace = "0"b;
 419       exec = "";
 420       call cu_$arg_count (nargs);
 421       call cu_$arg_ptr (1, argptr, arglen, code);
 422       if arg ^= "polt" & arg ^= "molt" & arg ^= "colt" then do; /* invalid executive */
 423          call com_err_ (0, "mtdsim_", "Invalid executive code - ""^a""", exec); /* tell user */
 424          return;
 425       end;
 426       exec = arg;
 427       term = "0"b;
 428       if nargs > 1 then do;
 429          do i = 2 to nargs;
 430             call cu_$arg_ptr (i, argptr, arglen, code);
 431             if arg = "-debug" | arg = "-db" then debug = "1"b;
 432 
 433             else if arg = "-quit" | arg = "-q" then q_flag = "1"b; /* user wants to return to command level on quits  */
 434 
 435             else if arg = "-trace" | arg = "-tc" then trace = "1"b; /* user wants mme trace */
 436             else if arg = "-trace_cata_data" | arg = "-tcd" then tcd = "1"b;
 437             else if arg = "-tio" then trace_io = "1"b;
 438             else if arg = "-probe" | arg = "-pb" then call probe (mtdsim_);
 439          end;
 440          debugging = "1"b;
 441       end;
 442 
 443 
 444       last_mme, isc_cntdn, tio = 0;
 445       trace_save, in_ccc, isc_ccc_rqt, rd_blk, gelbar, glb_brk, itr_run = "0"b; /* reset flags */
 446       gicm_count = 0;
 447       gicmp, ricmp, ticmp, wicmp = null;                    /* initialize colts pointers */
 448       call tolts_init_ (exec, error);                       /* go init our enviornment and create slave seg */
 449       if error ^= 0 then return;                            /* if error durring init */
 450       on cleanup call clean_up;                             /* establish cleanup handler */
 451       gndc_flag = "0"b;                                     /* flag to prevent recursive courtsey calls */
 452       call tolts_util_$get_ttl_date (mtdsim_, ttl_date);
 453       tolts_active = "1"b;                                  /* set active flag for epilogue handler */
 454 
 455 /* search for <exec>cm in file system (exec can be polt, molt, or colt) */
 456 
 457       call tolts_util_$search (tolts_info.df_iocbp, substr (exec, 1, 1) || "lt." || exec || "cm", t_ptr, c_len, error);
 458       if error ^= 0 then do;                                /* if couldn't find cplt */
 459          call com_err_ (error, exec, "searching for ^alt.^acm", substr (exec, 1, 1), exec);
 460          call tolts_init_$clean_up;                         /* go delete our event channels and slave seg */
 461          return;
 462       end;
 463       call gload_ (t_ptr, execp, 0, addr (gload_data), error); /* load core image into our work segment */
 464       if error ^= 0 then do;                                /* problem durring load */
 465          call com_err_ (error, exec, "^a^/attempting to load ^alt.^acm",
 466           gload_data.diagnostic, substr (exec, 1, 1), exec);
 467          call tolts_init_$clean_up;                         /* go delete our event channels and slave seg */
 468          return;
 469       end;
 470 
 471       if debugging then call ioa_ (" execp = ^p", execp);
 472 
 473       if debug then do;
 474          debug = "0"b;
 475          tolts_info.mult_ans = "";                          /* clear out response */
 476 db_query:
 477          call tolts_qttyio_$rs (19, "tolts_debugger: enter break point address");
 478          call message_wait;                                 /* wait for user response */
 479          if mult_ans ^= "" then do;
 480             db_addr = cv_oct_check_ ((rtrim (mult_ans)), code);
 481             if code ^= 0 | db_addr > 65535 then do;
 482                call ioa_ ("Debugger: invalid address supplied");
 483                goto db_query;
 484             end;
 485             db_sv_wd = exec_wd (db_addr);
 486             exec_wd (db_addr) = "777650001000"b3;
 487          end;
 488       end;
 489 
 490 
 491       blk_lbl = block_disp;
 492       term_lbl = done;
 493       no_blk = no_blk_disp;
 494       spa.enter.lreg = rel (addr (spa.regs)) || "073200"b3; /* set lreg instruction  (lreg  spa.regs) */
 495       if exec = "molt" then string (spa.enter.lbar) = "000630230203"b3; /* set initial lbar instruction (lbar =o630,du) */
 496       else string (spa.enter.lbar) = "000201230203"b3;      /* set initial lbar instruction (lbar =o200,du) */
 497       spa.enter.ret = rel (addr (spa.enter.icivlu)) || "630200"b3; /* set return instruction (ret  spa.enter.icivlu) */
 498       spa.enter.icivlu.ic = gload_data.definition (1).offset; /* set initial entry point */
 499       spa.enter.icivlu.ind = "0"b;                          /* initial entry indicators are zero */
 500       scup = null;
 501       on lockup begin;
 502          call ioa_ ("^a encountered a lockup fault ^[a dump will be taken^]", exec, ^flt_flag);
 503          if ^flt_flag then call fault_dump;
 504          else call continue_to_signal_ (error);
 505       end;
 506       on illop begin;
 507          call ioa_ ("^a encountered a illop fault ^[a dump will be taken ^]", exec, ^flt_flag);
 508          if ^flt_flag then call fault_dump;
 509          else call continue_to_signal_ (error);
 510       end;
 511       on illegal_modifier begin;
 512          call ioa_ ("^a encountered an illegal_modifier fault ^[a dump will be taken ^]", exec, ^flt_flag);
 513          if ^flt_flag then call fault_dump;
 514          else call continue_to_signal_ (error);
 515       end;
 516       on illegal_opcode begin;
 517          call ioa_ ("^a encountered an illegal_opcode fault ^[a dump will be taken ^]", exec, ^flt_flag);
 518          if ^flt_flag then call fault_dump;
 519          else call continue_to_signal_ (error);
 520       end;
 521       on illegal_procedure begin;
 522          call ioa_ ("^a encountered an illegal_procedure fault ^[a dump will be taken ^]", exec, ^flt_flag);
 523          if ^flt_flag then call fault_dump;
 524          else call continue_to_signal_ (error);
 525       end;
 526       on store begin;
 527          call ioa_ ("^a encountered a store fault ^[a dump will be taken ^]", exec, ^flt_flag);
 528          if ^flt_flag then call fault_dump;
 529          else call continue_to_signal_ (error);
 530       end;
 531       on tolts_error_ begin;
 532          call probe (mtdsim_);
 533          call clean_up;
 534       end;
 535 
 536       on quit begin;                                        /* establish quit handler */
 537          if ^q_flag then                                    /* if normal operation */
 538             call tolts_alrm_util_$quit;
 539          else call continue_to_signal_ (error);
 540       end;
 541       on program_interrupt begin;                           /* establish pi handler for debugging */
 542          call hcs_$wakeup (tolts_info.process, tolts_info.quith_event, null, error);
 543       end;
 544       call tolts_qttyio_ ("??? ", 9);                       /* exec read for original data */
 545 %page;
 546 /* this is the main program dispatcher */
 547 
 548       term = "0"b;                                          /* reset terminate condition */
 549       do while (^term);                                     /* loop until we are done */
 550 block_disp:                                                 /* target of nonlocal gotos */
 551          call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error);
 552          if error ^= 0 then do;                             /* this is a fatal error, terminate our process */
 553             call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */
 554             fatal_desc.version = 0;
 555             fatal_desc.fatal_code = error;
 556             if ^debugging then
 557                call terminate_process_ ("fatal_error", addr (fatal_desc));
 558             else signal tolts_error_;
 559          end;                                               /* no need to return, as we won't be back */
 560          if tolts_info.wait_list.nchan > 1 then do;         /* if we are waiting for > 1 event */
 561             if event_out.channel_id ^= wait_list.wait_event_id (2)
 562              | event_out.channel_id ^= tolts_info.dm_event
 563             then do;                                        /* if the wake up is not for the second channel */
 564                ev_occurred = 0;                             /* initialize in case code ^= 0 */
 565                call ipc_$read_ev_chn (wait_list.wait_event_id (2),
 566                 ev_occurred, addr (event_out), code);       /* check and see if the second channel is ready */
 567                if code ^= 0 then do;
 568                   call com_err_ (code, exec, "Error calling ipc_$read_ev_chn");
 569                   if debugging then signal tolts_error_;
 570                end;
 571                if ev_occurred ^= 1 then do;
 572                   if nr_cnt < 20 then do;
 573                      if debugging then call ioa_ ("nr_cnt = ^d", nr_cnt);
 574                      wake_time = 500000;
 575                      call timer_manager_$sleep (wake_time, "10"b);
 576                      nr_cnt = nr_cnt + 1;
 577                      call wake_disp;                        /* if the second channel hasn't awaken then wait */
 578                   end;
 579                   else do;
 580                      if substr (clt_sw, 3, 4) = "c000" then do; /* if exec chan - wrapup */
 581                         call tolts_qttyio_$rs (0, "^as: timeout error attempting attach of ^a",
 582                          tolts_info.exec, clt_sw);          /* notify the user */
 583                         call tolts_abort ("$c1");           /* then abort colts */
 584                      end;
 585                      else do;
 586                         call rel_tst_chan (l);
 587                         colts_pages (l).in_use = "0"b;      /* reset test page active */
 588                         call tolts_qttyio_$rs (0, "^as:  timeout error attempting a tandd_attach of ^a",
 589                          tolts_info.exec, substr (colts_pages (l).cdt_name, 1, 6));
 590                         colts_op_flags.colt_flag = "0"b;    /* make use flag is reset so we don't go blocked */
 591                         colts_op_flags.sicm = "0"b;
 592                         colts_op_flags.dm_attach = "0"b;
 593                         if mme_call_hf (2).lower ^= 0 then do; /* cc requested */
 594                            exec_wd (mme_call_hf (2).upper) = "000000000004"b3; /* store error status */
 595                            call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
 596                             (mme_call_hw (2).lower || "000000"b3)); /* enter cc request */
 597                         end;
 598                         colts_pages (l).status_word = "000000000002"b3; /* test channel - store status */
 599                      end;
 600                   end;
 601                end;
 602             end;
 603             tolts_info.wait_list.nchan = tolts_info.wait_list.nchan - 1; /* else decrement the wait list */
 604             chan_name, io_module = "";
 605             n_dialed = 0;
 606             flags = ""b;
 607             call convert_dial_message_$return_io_module (event_out.message,
 608              chan_name, io_module, n_dialed, flags, code);  /* convert the message into flags */
 609             if code ^= 0 then do;
 610                call ioa_$rsnnl ("error attaching channel ^a", emsg, mesg_len, chan_name);
 611                call output_status_code (code, emsg);
 612             end;
 613             if trace_io then
 614                call ioa_ ("Channel ^a, IO Module ^a, N_dialed ^d, flags^[ dialed_up^]^[ hung_up^]^[ control^]",
 615                 chan_name, io_module, n_dialed, flags.dialed_up, flags.hung_up, flags.control);
 616 
 617             if flags.control                                /* if control flag then error */
 618              | (^flags.control                              /* or an informative message */
 619              & ^flags.dialed_up & ^flags.control) then do;  /* with no information */
 620 
 621                if substr (clt_sw, 3, 4) = "c000" then do;   /* if exec chan - wrapup */
 622                   call tolts_qttyio_$rs (0, "^as: control error attempting dial_manager_attach of ^a",
 623                    tolts_info.exec, substr (clt_sw, 1, 6)); /* notify user */
 624                   call tolts_abort ("$c0");                 /* then abort colts */
 625                end;
 626                else do;
 627                   call rel_tst_chan (l);
 628                   colts_pages (l).in_use = "0"b;            /* reset test page active */
 629                   call tolts_qttyio_$rs (0, "^as:  control error attempting a tandd_attach of ^a",
 630                    tolts_info.exec, substr (colts_pages (l).cdt_name, 1, 6));
 631                   colts_op_flags.colt_flag = "0"b;          /* make use flag is reset so we don't go blocked */
 632                   colts_op_flags.sicm = "0"b;
 633                   colts_op_flags.dm_attach = "0"b;
 634                   if mme_call_hf (2).lower ^= 0 then do;    /* cc requested */
 635                      exec_wd (mme_call_hf (2).upper) = "000000000002"b3; /* store error status */
 636                      call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
 637                       (mme_call_hw (2).lower || "000000"b3)); /* enter cc request */
 638                   end;
 639                   colts_pages (l).status_word = "000000000002"b3; /* else test channel - store status */
 640                end;
 641             end;
 642 
 643             if flags.dialed_up & colts_op_flags.dm_attach then do; /* if the channel is dialed attaching */
 644                call iox_$attach_name ((clt_sw), cltp, att_desc, null, code); /* create an io switch */
 645                if code ^= 0 then goto sw_err;               /* if error */
 646                call iox_$open (cltp, 3, "0"b, code);        /* open a switch */
 647                if code ^= 0 then goto sw_err;               /* if error */
 648                call iox_$modes (cltp, "rawi,rawo", "", code); /* now set the modes for the channel */
 649                if code ^= 0 then do;                        /* if error */
 650 sw_err:           if substr (clt_sw, 3, 4) = "c000" then do;/* if exec channel - wrapup */
 651                      call convert_status_code_ (code, shortinfo, lginfo); /* convert the status code */
 652                      call tolts_qttyio_$rs (0, "^as: ^a/ attempting a switch operation for ^a",
 653                       tolts_info.exec, lginfo, clt_sw);     /* and notify the user */
 654                      call tolts_abort ("$c1");              /* then abort colts */
 655                   end;
 656                   else do;
 657                      colts_pages (l).status_word = "000000000002"b3; /* else test channel - store status */
 658                      colts_pages (l).in_use = "0"b;
 659                   end;
 660                end;
 661                if code = 0 then do;
 662                   if substr (clt_sw, 3, 4) = "c000" then do;/* if exec channel */
 663                      tolts_info.fnp (k).exec_active = "1"b; /* set exec active */
 664                      fnp (k).fnp_execp = cltp;              /* save iocb ptr */
 665                      exec_wd (remote_inquiry_ic) = "0000000500"b3 || "1"b
 666                       || substr (bit (k), 2, 5);            /* answer remote inquiry request */
 667                   end;
 668                   else do;                                  /* else a test channel */
 669                      colts_pages (l).chanp = cltp;          /* save iocb ptr */
 670                      colts_pages (l).status_word = "000000000004"b3; /* store good status */
 671                      exec_wd (remote_inquiry_ic) = "0000000500"b3 || "0"b
 672                       || substr (bit (l), 2, 5);            /* answer remote inquiry request */
 673                   end;
 674                   colts_op_flags.colt_flag = "0"b;          /* reset colts flag */
 675                   colts_op_flags.dm_attach = "0"b;          /* reset dial_manager attach flag */
 676                   remote_inquiry_ic = 0;                    /* reset remote inquiry ic */
 677                end;
 678             end;
 679          end;
 680 
 681          if colts_op_flags.sicm then do;                    /* if an icm need to be sent to the fnp */
 682             call iox_$put_chars (fnp (k).fnp_execp, wicmp, (bin (wicm.word_total) + 1) * 4, code); /* send it */
 683             if code ^= 0 then do;                           /* if error */
 684                call convert_status_code_ (code, shortinfo, lginfo);
 685                call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer to fnp colt exec ^a",
 686                 tolts_info.exec, lginfo, fnp (k).fnp_execp);
 687                call tolts_abort ("$c1");                    /* then abort colts */
 688             end;
 689             gicmp = addr (gicm);                            /* else get ptr for return icm */
 690             gicm_count = gicm_count + 1;                    /* inc position in the queue */
 691 
 692             if gicm_count = 17 then do;                     /* if 17 - error */
 693                call tolts_qttyio_$rs (0, "^as: execessive outstanding io's", tolts_info.exec);
 694                call tolts_abort ("$c2");                    /* abort colts */
 695             end;
 696             gicm.cltp = fnp (k).fnp_execp;                  /* save iocb ptr */
 697             gicm.ricmp = ricmp;                             /* rtrn icm ptr */
 698             gicm.tally = bin (wicm.word_total) + 1;         /* tally */
 699             if mme_call_hf (2).lower ^= 0 then do;          /* cc requested */
 700                gicm.cc_addr = mme_call_hw (2).lower || "000000"b3; /* save cc address */
 701                gicm.st_addr = mme_call_hf (2).upper;        /* save status address */
 702             end;
 703             colts_op_flags.sicm = "0"b;                     /* reset send icm flag */
 704          end;
 705 
 706          if tolts_info.special_fault then do;               /* special int. fault from tolts_io_int_ */
 707             tolts_info.special_fault = "0"b;
 708             call tolts_abort ("$b6");
 709          end;
 710          else if tolts_info.exec_term_io_wait then term = "1"b; /* we are all done */
 711          else if tolts_info.first_request_done then do;     /* if we have something to do... */
 712 no_blk_disp:                                                /* target of non-local gotos */
 713             if gicm_count ^= 0 then do;                     /* if outstanding icm */
 714                alloc info_struct;                           /* alloc an info struct */
 715                info_ptr = addr (info_struct);               /* get its ptr */
 716 
 717                if gicm.cltp ^= null then do;                /* if slot is in use */
 718                   call iox_$control (gicm.cltp, "read_status", info_ptr, code); /* read the status */
 719                   if info_struct.out_pend then do;          /* output ready */
 720                      call iox_$get_chars (gicm.cltp, gicm.ricmp, gicm.tally * 4, n_read, code); /* get the icm */
 721                      if code ^= 0 then do;                  /* if error */
 722                         call convert_status_code_ (code, shortinfo, lginfo);
 723                         call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer from fnp", tolts_info.exec, lginfo);
 724                         call tolts_abort ("$c1");           /* then abort colts */
 725                      end;
 726                      if gicm.cc_addr ^= "0"b3 then do;      /*  if a courtesy call requested */
 727                         if fnp (k).fnp_execp = gicm.cltp then
 728                            exec_wd (gicm.st_addr) = fnp (k).status_word;
 729                         else exec_wd (gicm.st_addr) = colts_pages (l).status_word;
 730                         call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
 731                          (gicm.cc_addr));                   /* enter ccc request */
 732                      end;
 733                      gicm_count = gicm_count - 1;           /* dec the count */
 734                      gicm.cltp = null;                      /* open up the slot */
 735                      gicm.ricmp = null;
 736                      if gicm_count = 0
 737                      then do;                               /* delete unused gicms */
 738                         free gicm;
 739                         gicmp = null;
 740                      end;
 741                   end;
 742                end;
 743 
 744                free info_struct;                            /* free the info structure */
 745             end;
 746 
 747             if isc_ccc_rqt then do;                         /* if outstanding inter slave read ... */
 748                if tolts_info.exec_dta_cnt = 0 then isc_cntdn = isc_cntdn - 1; /* but no data to xfer yet ... */
 749                if isc_cntdn = 0 | tolts_info.exec_dta_cnt ^= 0 then do; /* if timeout or isc data avail */
 750                   isc_ccc_rqt = "0"b;                       /* reset isc courtesy call flag and enter courtesy call */
 751                   call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), (isc_queue.icivlu));
 752                   exec_wd (isc_queue.status_add + 1) = "0"b;/* dcw residue = zero */
 753                   if tolts_info.exec_dta_cnt = 0 then       /* if no data to xfer... */
 754                      exec_wd (isc_queue.status_add) = "400006000000"b3; /* set status to timeout */
 755                   else call pop_isc (isc_queue.status_add, isc_queue.data_add); /* data to xfer */
 756                end;
 757             end;
 758             if ^in_ccc & ^gndc_flag then                    /* if not in ccc */
 759                if tolts_info.ccc_requests ^= 0 & ^gelbar then do; /* pay courtesy call first */
 760                   unspec (spa.ccc_regs) = addr (spa.regs) -> reg_move; /* move current regs into safe store */
 761                   spa.ccc_icivlu = string (spa.enter.icivlu);
 762                   string (spa.enter.icivlu) = tolts_info.ccc_queue (1).icivlu;
 763                   tolts_info.ccc_requests = tolts_info.ccc_requests - 1; /* decrement count */
 764                   do i = 1 to tolts_info.ccc_requests;
 765                      tolts_info.ccc_queue.icivlu (i) = tolts_info.ccc_queue.icivlu (i + 1); /* move queue down */
 766                   end;
 767                   in_ccc = "1"b;
 768                end;
 769                else if rd_blk then do;                      /* road blocked? */
 770                   if isc_ccc_rqt then call wake_disp;       /* wakeup dispatcher */
 771                   rd_blk = "0"b;
 772                end;
 773             if trace | (trace_save & in_ccc) then           /* if tracing mmes and dispatches */
 774                call tolts_qttyio_$rs (10,
 775                 "^a ^a ^12.3b^[, ^a^;^s^]^[, ^a ^6.3b^;^2s^]^[, ^a ^a ^12.3b, ^a ^12.3b^]",
 776                 ctime (), "Dispatch to ici -", string (spa.enter.icivlu), in_ccc,
 777                 "in courtesy call", gelbar, "in gelbar, BAR -", spa.enter.lbar.bar, glb_brk,
 778                 "gelbar break,", "gb ici -", string (spa.glbici), "gbfv -", spa.glbflt);
 779             glb_brk = "0"b;                                 /* reset gelbar break indicator if set */
 780             gndc_flag = "0"b;
 781             if ^flt_flag then
 782                call tolts_alm_util_$enter_slave_ (addr (spa.enter)); /* enter slave program */
 783          end;
 784 done:                                                       /* target of nonlocal goto */
 785       end;
 786       if ^tolts_active then return;
 787       tolts_info.exec_term_io_wait = "1"b;                  /* make sure we quit */
 788       call clean_up;                                        /* go cleanup our enviornment */
 789       return;                                               /* and return  to tolts command level */
 790 %page;
 791 
 792 /* mme_fault - static condition handler for GCOS type mme faults */
 793 
 794 mme_fault: entry (mcptr, cname, tptr1, tptr2, tcont);
 795 
 796 dcl  (mcptr, tptr1, tptr2) ptr;
 797 dcl  cname char (*);
 798 dcl  tcont bit (1);
 799 dcl  tags (1:8) char (1) static options (constant) init
 800       ("a", "b", "c", "d", "e", "f", "g", "h");
 801 dcl  fnp_state (0:4) char (7) static options (constant) init
 802       ("free   ", "unknown", "down   ", "booting", "up     ");
 803 
 804 
 805       mcp = mcptr;                                          /* get ptr to machine conditions */
 806       scup = addr (mc.scu);                                 /* get ptr to scu data */
 807       unspec (spa.regs) = addr (mc.regs) -> reg_move;       /* save the processor regs */
 808       spa.enter.icivlu.ind = string (scu.ir);
 809 
 810       if gelbar then                                        /* if in gelbar mode, pass fault on to gcos module */
 811          call set_gelbar;                                   /* we want return from this call */
 812       mmep = addrel (execp, scu.ilc);                       /* set mme call ptr */
 813 
 814       if substr (mme_call_w (0), 19, 10) ^= "0000000010"b then /* if not mme1 instruction... */
 815          go to undefm;
 816 
 817       if in_ccc then
 818          if mme_call_hw (0).upper ^= "000016"b3 then do;
 819             call tolts_qttyio_$rs (0, "^as: Illegal mme in ccc  (^12.3b) @ ^p",
 820              exec, mme_call_w (0), mmep);
 821             call tolts_abort ("$a4");
 822          end;
 823       mme_number = mme_call_hf (0).upper;
 824       if (mme_number < -127 | mme_number > 31)              /* if out of legal range */
 825        | (mme_number < -66 & mme_number > -87)
 826        | (mme_number < -94 & mme_number > -127) then
 827          go to undefm;
 828       if trace | trace_save then do;                        /* if tracing mmes and dispatches */
 829          if trace then do;                                  /* if currently tracing */
 830             if (mme_number = -1 & last_mme = -39)
 831              | (mme_number = -39 & last_mme = -1)
 832              | mme_number = last_mme then do;               /* do not display idle loop */
 833                trace_save = "1"b;                           /* save state and turn trace off */
 834                trace = "0"b;                                /* idle loop */
 835             end;
 836          end;
 837          else if mme_number ^= last_mme then do;            /* if idle loop has ended */
 838             trace = "1"b;                                   /* turn back on trace */
 839             trace_save = "0"b;
 840          end;
 841       end;
 842       last_mme = mme_number;                                /* save mme number for nxt time */
 843       go to mme_typ (mme_number);                           /* process gcos mme */
 844 %page;
 845 /* ********* MME ABSTIM ********* (absolute time)
 846 
 847    input registers: none
 848 
 849    mme     abstim
 850    ------  return
 851 
 852    return registers: AR = time of day, 1/64 ms. since midnight */
 853 
 854 mme_typ (-1): if trace then call tolts_qttyio_$rs (10, "^a MME ABSTIM @ ^p", ctime (), mmep);
 855       call tolts_init_$gc_tod (spa.regs.a);                 /* get current time of day */
 856       call return_plus (1);
 857 
 858 /* ********* MME ACCWRT ********* (accounting file write, unused in Multics)
 859 
 860    input registers:   x1 -> message address
 861 
 862    mme     accwrt
 863    ------  return
 864 
 865    return registers: none */
 866 
 867 mme_typ (-2): if trace then call tolts_qttyio_$rs (10, "^a MME ACCWRT @ ^p", ctime (), mmep);
 868       call return_plus (1);
 869 
 870 /* ********* MME ASGPAT ********* (assign peripheral allocation table, unused in Multics)
 871 
 872    input registers:   X1 = sct (test page index mod 4),   X4 = pat address (lal offset)
 873 
 874    mme     asgpat
 875    ------  return
 876 
 877    return registers: X2 = sct word 1 (returned = 0) */
 878 
 879 mme_typ (-5): if trace then call tolts_qttyio_$rs (10, "^a MME ASGPAT @ ^p", ctime (), mmep);
 880       spa.regs.x (2) = "0"b;                                /* set # modules to zero */
 881       call return_plus (1);
 882 %page;
 883 /* *********************************************************************************
 884    *   alternate mtar device is defined as  "alt sct addr = (page index) *4 + 512   *
 885    ********************************************************************************* */
 886 
 887 /* ********* MME ALLOCR ********* (allocate peripheral)
 888 
 889    input registers:   x1 = sct (test page index mod 4)
 890    x3 = chan number if new format
 891 
 892    mme    allocr
 893    zero   ficcdd,delaysct                         ficcdd ptr, sct value if delayed allocation
 894    zero   sctwrk,mtardata                         ficcdd ptr to sct work area.
 895    mtardata is storage for (even) mtar r/w flag (molts only)
 896    zero   alcflg,0                                ptr to alcflg
 897    zero   alcccp,dldcwp                           ptr to courtesy call routine, ptr to dcw for delayed allocation message
 898    ----   return error                            (mme call + 5)
 899    ----   return ask stranger permission          (mme call + 6)
 900    ----   return not free                         (mme call + 7)
 901    ----   return allocated or usage count bumped  (mme call + 8)
 902    ----   return shared device                    (mme call + 9)
 903    ----   return allocation in progress, wait     (mme call + 10)
 904 
 905    return registers:          X2 = error code on error (see set_sctwrk subroutine for error codes)
 906    *                          output in sctwrk (12 words): see the set_sctwrk subroutine */
 907 
 908 mme_typ (-4): if trace then call tolts_qttyio_$rs (10, "^a MME ALLOCR @ ^p", ctime (), mmep);
 909       call get_px_sct ("ALLOCR", bin (spa.regs.x (1), 17), "0"b); /* get test page index */
 910       call set_sctwrk (io_sel);                             /* go set up the sct work area */
 911       if spa.regs.x (2) ^= "0"b then do;                    /* if some error from tolts_device_info_... */
 912          if fixed (spa.regs.x (2)) = m_iv_iom then          /* if invalid IOM number... */
 913             spa.regs.x (2) = "0"b;                          /* correct error code */
 914          call return_plus (5);                              /* take error return */
 915       end;
 916       io_info_ptr = addr (pages (io_sel));                  /* get ptr to this test page */
 917 
 918 /* create an event call channel for tdio status events */
 919 
 920       if ^io_info.ev_ch_ass then do;                        /* we we havn't done this already */
 921          call tolts_init_$cr_event_chan (io_info.status_event,
 922           "1"b, tolts_io_int_, io_info_ptr, 2, error);
 923          if error ^= 0 then                                 /* if error creating event call chan */
 924             call tolts_abort ("$a9");
 925          io_info.ev_ch_ass = "1"b;                          /* set event chan assigned flag */
 926       end;
 927 
 928       if mme_call_hf (1).lower = 0 then do;                 /* if we havn't already attached perp... */
 929          alt_flag, rd_flag = "0"b;                          /* make sure we start in a known state */
 930          if io_info.devsct.type_code = "22"b3               /* if ccu as a reader */
 931           & ^io_info.ccu_pun then rd_flag = "1"b;           /* set read flag */
 932          if ^io_info.alloc_wait & ^io_info.p_att then do;
 933 
 934             if io_info.io_type = mca_io_type
 935              & io_info.mca_attach_state = MCA_NOT_CONFIGURED then do;
 936                call mca_$attach_mca ((io_info.device_name), io_info.status_event,
 937                 io_info.mca_ioi_idx, error);
 938                io_info.mca_attach_state = MCA_FREE;
 939             end;
 940             else do;
 941 
 942 attach:        if ^alt_flag then do;                        /* if we want the primary or only channel */
 943                   call ioa_$rsnnl ("T&D is attaching for a ^[write^]^[read^] ^a",
 944                    att_desc, mesg_len, (^rd_flag), (rd_flag), io_info.device_name);
 945                   call rcp_priv_$attach (io_info.rcp_name, addr (io_info.rcp_area (1)), io_info.status_event,
 946                    att_desc, io_info.rcp_id, error);
 947                end;
 948                else do;
 949                   call ioa_$rsnnl ("T&D is attaching for a ^[write^]^[read^] ^a",
 950                    att_desc, mesg_len, (^rd_flag), (rd_flag), io_info.alt_device_name);
 951                   call rcp_priv_$attach (io_info.rcp_name, addr (io_info.alt_rcp_area (1)), io_info.status_event,
 952                    att_desc, io_info.alt_rcp_id, error);
 953                end;
 954 
 955                if error ^= 0 then do;
 956                   call output_status_code (error, "rcp attach error");
 957                   call dealcp_sub;                          /* go release status event */
 958                   spa.regs.x (2) = bit (os_deny);           /* set appropriate error code */
 959                   call return_plus (5);                     /* take error return */
 960                end;
 961                if ^alt_flag then
 962                   call rcp_$check_attach (io_info.rcp_id, addr (io_info.rcp_area (1)), coment, io_info.device_index,
 963                    tolts_info.max_wks_sz, tolts_info.max_to, io_info.rcp_state, io_info.attach_err);
 964                else call rcp_$check_attach (io_info.alt_rcp_id, addr (io_info.alt_rcp_area (1)), coment,
 965                      io_info.alt_device_index, tolts_info.max_wks_sz,
 966                      tolts_info.max_to, io_info.rcp_state, io_info.attach_err);
 967 
 968             end;
 969          end;
 970       end;
 971 
 972 /* only one call to rcp_$check_attach here. If delayed allocation (tape or disk),  RCP  will  signal
 973    (via  the  status call channel) tolts_io_int_, when an event has ocurred. tolts_io_int_ will check the
 974    rcp state flag and either return and let RCP work if attachment is incomplete or enter the  courtesy
 975    call request and signal the dispatcher if the attachment is complete or if an error has occurred */
 976 
 977 /* *********************************************
 978    *   check for mtar write permission denial     *
 979    ********************************************* */
 980 
 981       if io_info.io_type = mtar_io_type
 982        & (^io_info.p_att | io_info.alt_dev_flag) then do;
 983          if io_info.attach_err = error_table_$force_unassign then do;
 984             if ^alt_flag then disk_info_ptr = addr (io_info.rcp_area (1));
 985             else disk_info_ptr = addr (io_info.alt_rcp_area (1));
 986             if ^rd_flag then do;                            /* opr denied write request */
 987                disk_info.write_flag = "0"b;                 /* read only */
 988                rd_flag = "1"b;
 989                goto attach;
 990             end;
 991             else do;
 992                call output_status_code (io_info.attach_err, "ioi_assign error--check attach");
 993                call dealcp_sub;                             /* go release status event */
 994                spa.regs.x (2) = bit (os_deny);              /* set appropriate error code */
 995                call return_plus (5);                        /* take error return */
 996             end;
 997          end;
 998       end;
 999 
1000       if ^io_info.p_att | ^io_info.p2_att then do;
1001 
1002          if io_info.attach_err ^= 0
1003           | error ^= 0 then do;
1004             if io_info.attach_err = error_table_$resource_unavailable then do; /* must have been busy */
1005                spa.regs.x (2) = bit (dev_busy);             /* set appropriate error code */
1006                if ^io_info.dev_busy then do;                /* only output device busy message once */
1007                   call tolts_qttyio_$rs (0, "^a device busy, allocation queued", io_info.test_hdr);
1008                   io_info.dev_busy = "1"b;                  /* set flag so we only output message once */
1009                end;
1010                call return_plus (7);                        /* return ic + 7 */
1011             end;
1012             if io_info.io_type ^= mca_io_type then
1013                call output_status_code (io_info.attach_err, "ioi_assign error--check attach");
1014             else call output_status_code (error, " mca assign error");
1015             call dealcp_sub;                                /* go release status event */
1016             spa.regs.x (2) = bit (os_deny);                 /* set appropriate error code */
1017             call return_plus (5);                           /* take error return */
1018          end;
1019          if io_info.rcp_state ^= 0                          /* return - allocation wait */
1020           | (io_info.io_type = mca_io_type
1021           & io_info.mca_attach_state < MCA_ATTACHED) then do;
1022             io_info.alloc_wait = "1"b;                      /* set wait flag for tolts_io_int_ */
1023             io_info.icivlu.ic = mme_call_hw (4).upper;      /* save ccc ptr for tolts_io_int_ */
1024             io_info.icivlu.ind = "0"b;
1025             call tolts_qttyio_$dcw_list (addrel (execp, mme_call_hf (4).lower), 0);
1026             tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1; /* increment global IO count */
1027             call return_plus (10);                          /* return ic + 10, allocation wait */
1028          end;
1029 
1030          if io_info.io_type = mdr_io_type & ^io_info.p2_att then /* if running mdrs */
1031             if substr (io_info.device_name, 1, 3) = "tap"   /* if tape */
1032              | substr (io_info.device_name, 1, 3) = "dsk" then do; /* or disk */
1033                io_info.p2_att = "1"b;                       /* set perph attach flag */
1034                io_info.alt_rcp_id = io_info.rcp_id;         /* mv rcp id to alt rcp id */
1035                go to mme_typ (-4);                          /* we have the mpc now go get the dev */
1036             end;
1037          if ^alt_flag then io_info.p_att = "1"b;            /* set perp attach flag */
1038          else io_info.p2_att = "1"b;
1039          io_info.dev_busy = "0"b;                           /* reset device busy flag */
1040       end;
1041 
1042 
1043 /* ***************************************************
1044    *   attach alternate device for mtar if required   *
1045    *************************************************** */
1046 
1047 
1048       if io_info.io_type = mtar_io_type & io_info.alt_dev_flag
1049        & io_info.p_att & ^io_info.p2_att then do;
1050 
1051          if rd_flag then do;                                /* sct requested permission equal to that of primary */
1052             disk_info_ptr = addr (io_info.alt_rcp_area (1));
1053             disk_info.write_flag = "0"b;
1054             rd_flag, alt_flag = "1"b;
1055             goto attach;
1056          end;
1057          else do;
1058             disk_info_ptr = addr (io_info.alt_rcp_area (1));
1059             disk_info.write_flag = "1"b;
1060             rd_flag = "0"b;
1061             alt_flag = "1"b;
1062             goto attach;
1063          end;
1064       end;
1065 
1066 
1067 
1068 
1069 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1070 /*   set permission code for mtar                                                                             */
1071 /*   The address for permission storage is in the lower half of (mme call + 2).                               */
1072 /*   appropriate permission is stored in the lower half of the target word,                                   */
1073 /*    0 = write permission, 8 = read permission                                                               */
1074 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
1075 
1076 
1077 
1078       if ^rd_flag then
1079          exec_wd (mme_call_hf (2).lower) = exec_wd (mme_call_hf (2).lower) & "777777000000"b3;
1080       else exec_wd (mme_call_hf (2).lower) = (exec_wd (mme_call_hf (2).lower)) | ("000000000010"b3);
1081       if io_info.rcp_name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then /* if tape device... */
1082          call decode_den;                                   /* go decode density info */
1083 
1084       if io_info.io_type = mca_io_type then
1085          call get_temp_segment_ ("mca_workspace", io_info.workspace_ptr, error);
1086       else call ioi_$workspace (io_info.device_index, io_info.workspace_ptr, tolts_info.wks_sz, error);
1087       if error ^= 0 then do;
1088          call output_status_code (error, "workspace assign error");
1089          call dealcp_sub;                                   /* go release status event */
1090          spa.regs.x (2) = bit (os_deny);                    /* set appropriate error code */
1091          call return_plus (5);                              /* take error return */
1092       end;
1093       io_info.cur_wks_sz = tolts_info.wks_sz;               /* set current value of workspace size */
1094       if io_info.io_type ^= mca_io_type then do;
1095          ioi_wksp = io_info.workspace_ptr;
1096          call ioi_$set_status (io_info.device_index, fixed (rel (addr (tolts_workspace.status)), 18), 1, error);
1097          if error ^= 0 then do;
1098             call output_status_code (error, "set_status error");
1099             call dealcp_sub;                                /* go detach and release status event */
1100             spa.regs.x (2) = bit (os_deny);                 /* set appropriate error code */
1101             call return_plus (5);                           /* take error return */
1102          end;
1103          if io_info.nff then do;
1104             iom = fixed (substr (io_info.devsct.icc, 1, 3), 3) + 1;
1105             chan = fixed (substr (io_info.devsct.icc, 6, 6), 6);
1106          end;
1107          else do;
1108             iom = fixed (substr (io_info.devsct.icc, 1, 3), 3) + 1;
1109             chan = fixed (substr (io_info.devsct.icc, 4, 6), 6);
1110          end;
1111          call ioi_$set_channel_required (io_info.device_index, iom, chan, error);
1112          if error ^= 0 then do;
1113             call output_status_code (error, "set_channel error");
1114             call dealcp_sub;                                /* go detach and release status event */
1115             spa.regs.x (2) = bit (os_deny);                 /* set appropriate error code */
1116             call return_plus (5);                           /* take error return */
1117          end;
1118 
1119          timeout_time = 30000000;                           /* set timeout to a minimum value of 30 sec */
1120          if io_info.io_type = mdr_io_type
1121           & io_info.devsct.type_code = "001110"b then       /* if mdr and 601/610 */
1122             timeout_time = 390000000;                       /* set timeout to 6.5 mins */
1123          else if io_info.io_type = itr_io_type              /* if mdrs on an eurc */
1124           & io_info.devsct.cr501_pr54 then
1125             timeout_time = 60000000;                        /* time_out = 1min */
1126          else if io_info.io_type = mtar_io_type then
1127             timeout_time = 90000000;                        /* time_out = 1.5min */
1128          io_info.lostit_time =                              /* set lostit time = time_out time + 1sec * 64 / 1000 */
1129           divide ((timeout_time + 1000000) * 64, 1000, 35);
1130          call ioi_$timeout (io_info.device_index, timeout_time, error);
1131          if error ^= 0 then do;
1132             call output_status_code (error, "set timeout error");
1133             call dealcp_sub;                                /* go release status event */
1134             spa.regs.x (2) = bit (os_deny);                 /* set appropriate error code */
1135             call return_plus (5);                           /* take error return */
1136          end;
1137       end;
1138       io_info.allocated = "1"b;
1139       call return_plus (8);                                 /* return ic + 8 - good return */
1140 %page;
1141 /* ********* MME CATA. ********* (Get itr or mdr deckfile catalog)
1142 
1143    input registers:           qu = ICC
1144    *                          x1 = ptr to call seq (defined by cata_call structure (below)
1145    *                          x2 = max load address
1146    *                          x3 = test page base
1147    mme     cata.
1148    ------  return if error
1149    ------  return if more or extenstion file follows
1150    ------  return if all read
1151 
1152    return registers:          AL    = words read in this call
1153    *                          Q-reg = error code
1154    *                          status word 1 bit 18 set for extension call */
1155 
1156 dcl  1 cata_call based (genp) aligned,                      /* structure for mme cata and mme data */
1157        (2 fdcwp bit (18),                                   /* first dcw ptr */
1158        2 statp bit (18),                                    /* ptr to status */
1159        2 patp bit (18),                                     /* ptr to PAT entry */
1160        2 nblk fixed bin) unaligned;                         /* next catalog block */
1161 
1162 mme_typ (-50): if trace | tcd then call tolts_qttyio_$rs (10, "^a MME CATA. @ ^p", ctime (), mmep);
1163       if substr (spa.regs.q, 7, 1) then                     /* if new format */
1164          call get_px_tcx ("CATA. ", substr (spa.regs.q, 8, 11)); /* get test page index */
1165       else call get_px_tcx ("CATA. ", substr (spa.regs.q, 10, 9)); /* get test page index */
1166       if io_info.io_type = mca_io_type then do;
1167          if io_info.mcata_idx = 0 then do;
1168             call tolts_util_$cata_sel (tolts_info.df_iocbp, "cata.nio.mca", addr (io_info.n_keys), error);
1169             if error ^= 0 then do;                          /* if we couldn't find catalog */
1170                call output_status_code (error, "selecting catalog subset of cata." || io_info.cat_name);
1171                call return_plus (1);                        /* take error return */
1172             end;
1173             call tolts_util_$search (tolts_info.df_iocbp, (io_info.cata_keys (1)), io_info.catp, c_len, error);
1174             if error ^= 0 then do;                          /* if we couldn't find catalog */
1175                call output_status_code (error, "searching for " || io_info.cata_keys (io_info.mcata_idx));
1176                call return_plus (1);                        /* take error return */
1177             end;
1178             do io_info.mcata_nkeys = 1 to cata.n;
1179                io_info.mcata_keys (io_info.mcata_nkeys) = cata.key (io_info.mcata_nkeys);
1180             end;
1181             io_info.mcata_idx = 1;
1182          end;
1183          io_info.cat_name = substr (io_info.mcata_keys (io_info.mcata_idx), 6, 7);
1184       end;
1185       if io_info.catx = 0 then do;                          /* only select catalog keys once */
1186          call tolts_util_$cata_sel (tolts_info.df_iocbp, "cata." || io_info.cat_name, addr (io_info.n_keys), error);
1187          if error ^= 0 then do;                             /* if we couldn't find catalog */
1188             call output_status_code (error, "selecting catalog subset of cata." || io_info.cat_name);
1189             call return_plus (1);                           /* take error return */
1190          end;
1191          io_info.catx = io_info.n_keys;
1192          if io_info.io_type ^= mca_io_type
1193           & io_info.n_keys > 1 then do;                     /* multiple catalogs */
1194             call tolts_qttyio_$rs (0, "^a Multiple catalog files (^d) for ^a ^a catalog.",
1195              io_info.test_hdr, io_info.n_keys, substr (io_info.cat_name, 5), substr (io_info.cat_name, 1, 3));
1196             do io_info.catx = 1 to io_info.n_keys;
1197                i = search (substr (io_info.cata_keys (io_info.catx), 10), ".");
1198 
1199                call tolts_qttyio_$rs (0, "^a ^a catalog, ^[firmware rev ^a^] - ",
1200                 substr (io_info.cata_keys (io_info.catx), 10, i - 1),
1201                 substr (io_info.cata_keys (io_info.catx), 6, 3),
1202                 (substr (io_info.cata_keys (io_info.catx), 6, 3) = "itr"),
1203                 substr (io_info.cata_keys (io_info.catx), 10 + i));
1204             end;
1205             call tolts_qttyio_$rs (0, "^a^/^a",
1206              "Indicate which one is to be used by answering yes to",
1207              "one of the following catalog entrys:");
1208             tolts_info.mult_ans = "";                       /* clear out response */
1209             do io_info.catx = 1 to io_info.n_keys while (mult_ans = "" | mult_ans = "no" | mult_ans = "n");
1210                i = search (substr (io_info.cata_keys (io_info.catx), 10), ".");
1211 requery:
1212                call tolts_qttyio_$rs (19, "^a ^a catalog, ^[firmware rev ^a^] - ",
1213                 substr (io_info.cata_keys (io_info.catx), 10, i - 1),
1214                 substr (io_info.cata_keys (io_info.catx), 6, 3),
1215                 (substr (io_info.cata_keys (io_info.catx), 6, 3) = "itr"),
1216                 substr (io_info.cata_keys (io_info.catx), 10 + i));
1217                call message_wait;                           /* wait for user response */
1218                if tolts_info.mult_ans ^= ""
1219                 & (mult_ans ^= "yes" & mult_ans ^= "y")
1220                 & (mult_ans ^= "no" & mult_ans ^= "n") then do;
1221                   call tolts_qttyio_ ("Please answer yes, no, or eom", 0);
1222                   go to requery;                            /* go ask again */
1223                end;
1224             end;
1225             io_info.catx = io_info.catx - 1;                /* currect io_info.catx */
1226             if io_info.catx > io_info.n_keys
1227              | (mult_ans ^= "yes" & mult_ans ^= "y") then
1228                call return_plus (1);                        /* take error return */
1229          end;
1230       end;
1231       else if io_info.io_type = mca_io_type then do;
1232          if ^io_info.cata_cycle then io_info.cata_cycle = "1"b; /* first time thru */
1233          else do;                                           /* must be second pass */
1234             if io_info.catx > 1 then                        /* if diskette catalog index > 1 */
1235                io_info.catx = io_info.catx - 1;             /* subtract 1 */
1236             else do;                                        /* else move to the mca cata index */
1237                io_info.mcata_idx = io_info.mcata_idx + 1;
1238                io_info.catx = 0;                            /* reset the diskette catalog index */
1239             end;
1240             io_info.cata_cycle = "0"b;
1241          end;
1242          spa.regs.a = "0"b;                                 /* intialize words read to 0 */
1243       end;
1244       if io_info.catx ^= 0 then do;
1245          call tolts_util_$search (tolts_info.df_iocbp, (io_info.cata_keys (io_info.catx)), io_info.catp, c_len, error);
1246          if error ^= 0 then do;                             /* if we couldn't find catalog */
1247             call output_status_code (error, "searching for " || io_info.cata_keys (io_info.catx));
1248             call return_plus (1);                           /* take error return */
1249          end;
1250          genp = addrel (execp, spa.regs.x (1));             /* get ptr to slave call */
1251          dcwp = addrel (execp, cata_call.fdcwp);            /*  get ptr to dcw */
1252          gcatp = addrel (execp, dcw.address);               /* get ptr to buffer */
1253          if trace | tcd then call tolts_qttyio_$rs (10, "MME CATA.; loading catalog ""cata.^a"" @ ^p",
1254              io_info.cat_name, gcatp);
1255          do i = 1 to cata.n;                                /* give page all catalog entries */
1256             if io_info.io_type = mca_io_type then do;
1257                unspec (mca_gcata (i)) = "0"b;               /* reset this entry */
1258                mca_gcata (i).cat_index, mca_gcata (i).nblk = i; /* set cata index & block number */
1259                if index (cata.key (i), "HDR") ^= 0 then do;
1260                   mca_gcata (i).dipper_flag = "0100"b;      /* set header flag */
1261                   filename_idx = index (cata.key (i),
1262                    after (cata.key (i), "HDR."));           /* get index of filename */
1263                end;
1264 
1265                else if index (cata.key (i), "DIR") ^= 0 then do;
1266                   mca_gcata (i).dipper_flag = "0101"b;      /* set dir flag */
1267                   filename_idx = index (cata.key (i), "DIR"); /* get index of filename */
1268                end;
1269 
1270                else if index (cata.key (i), "cata") ^= 0 then do;
1271                   mca_gcata (i).dipper_flag = "0100"b;      /* set cata flag */
1272                   filename_idx = index (cata.key (i),
1273                    after (cata.key (i), "nio."));           /* get index of filename */
1274                end;
1275 
1276                else filename_idx = index (cata.key (i),
1277                      after (cata.key (i), "nio."));         /* get index of filename */
1278                call tolts_alm_util_$ascii_to_bcd_
1279                 (substr (cata.key (i), filename_idx, 12), bit_buf);
1280                unspec (mca_gcata (i).filename) = bit_buf;
1281             end;
1282 
1283             else do;
1284                unspec (gcata (i)) = "0"b;                   /* clear element first */
1285                j = length (rtrim (cata.key (i)));           /* get true length of key */
1286                ac_name = substr (cata.key (i), j - 6, 4) || substr (cata.key (i), j - 1, 2);
1287                call tolts_alm_util_$ascii_to_bcd_ (ac_name, gcata (i).edit_rev); /* set edit name an rev */
1288                gcata (i).cat_index, gcata (i).nblk = i;     /* set index */
1289                if j < 13 then
1290                   call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), j, 6), gcata (i).ident); /* set ident */
1291                else call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), j - 13, 6), gcata (i).ident); /* set ident */
1292                if index (cata.key (i), ".") > 4 then        /* if firmware */
1293                   call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), 1, 6), gcata (i).purpose);
1294                else do;
1295                   call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), 1, 3), b18);
1296                   substr (gcata (i).purpose, 19, 18) = b18;
1297                end;
1298             end;
1299          end;
1300          spa.regs.a = bit (bin (cata.n * 4, 36));           /* set words read */
1301       end;
1302       if io_info.mcata_idx <= io_info.mcata_nkeys
1303        & io_info.io_type = mca_io_type then call return_plus (2); /* still more catalogs to read */
1304       else call return_plus (3);                            /* take good return */
1305 
1306 
1307 
1308 /* ********* MME CHANTM ********* (channel time)
1309 
1310    input registers:   X1 = sct (test page index mod 4),   X4 = pat address (lal offset)
1311 
1312    mme     chantm
1313    ------  return
1314 
1315    return registers: AR = channel time */
1316 
1317 mme_typ (-6): if trace then call tolts_qttyio_$rs (10, "^a MME CHANTM @ ^p", ctime (), mmep);
1318       call get_px_sct ("CHANTM", bin (spa.regs.x (1), 17), "1"b); /* get test page index */
1319       spa.regs.a = bit (bin (pages (io_sel).chan_time, 36));
1320       call return_plus (1);
1321 
1322 /* ********* MME CLEARQ ********* (clear ISC queue)
1323 
1324    input/return registers: none
1325 
1326    mme     clearq
1327    ------  return */
1328 
1329 mme_typ (-7): if trace then call tolts_qttyio_$rs (10, "^a MME CLEARQ @ ^p", ctime (), mmep);
1330       isc_ccc_rqt = "0"b;
1331       if isc_cntdn ^= 1 then isc_cntdn = 0;
1332       call return_plus (1);
1333 %page;
1334 /* ********* MME COINIT ********* (colts slave executive initialize)
1335 
1336    input/output registers: none
1337 
1338    mme    coinit
1339    zero   6,0       number of designators
1340    zero   wwflag,1
1341    zero   lstloc,2  core size available as loaded
1342    zero   tdflt,5   wrapup address
1343    zero   mmexec,7  interface module ttl
1344    zero   systyp,10  os type
1345    zero   crd30,11   .crd30     bit 17 = 1 if fnp active and 18-29 = # of active fnps
1346    ----   return    return is mme call + the number of designators + 2
1347 
1348    .crfig:
1349 
1350    0 = series 60 0r 6000      6 = system sckd. save opt.              24-30 = reserved for gcos
1351    1 = class. module present  7 = reserved for gcos                   31 = not in mem avail. space tab
1352    2 = shared memory system   8,9,10,11 = ioms 0-3 configured         32 = RLP300 present
1353    3 = >256k                  12,13,14,15 = CPUs 0-3 configured       33 = DN30
1354    4 = IOM system             16-19 = reserved for gcos               34 = DN305
1355    5 = series 60 system       20,21,22,23 = CPU has EIS               35 = DN   355/6600
1356 */
1357 
1358 
1359 mme_typ (-62): if trace then call tolts_qttyio_$rs (10, "^a MME COINIT @ ^p", ctime (), mmep);
1360       exec_wd (mme_call_hf (2).upper) = "0"b;               /*        zeros says not ww system */
1361       spa.wrapup_add = mme_call_hw (4).upper;               /* set wrapup address */
1362       call tolts_alm_util_$ascii_to_bcd_ (ttl_date, bcd_callname); /* convert ttl date to bcd */
1363       exec_wd (mme_call_hf (5).upper) = bcd_callname;       /* and store in message */
1364       substr (exec_wd (mme_call_hf (5).upper - 1), 19, 18) = "622017"b3; /* change version? ?? to version?s ? */
1365       genp = addrel (execp, mme_call_hf (3).upper);         /* get ptr to lstloc */
1366       if fix_wd (1) ^= 0 then                               /* if lstloc specified... */
1367          mem_now, fix_wd (1) = fix_wd (1) + 49152;          /* add 48k to lstloc */
1368       else mem_now, fix_wd (1) = fixed (gload_data.text_len) + 49152; /* otherwise use loaded length */
1369       call cpu_time_and_paging_ (i, cpu_time, j);           /* get current cpu time */
1370       tolts_info.init_time = cpu_time;                      /* save  */
1371       exec_wd (mme_call_hf (6).upper) = "000000000002"b3;   /* set os to multics */
1372       exec_wd (mme_call_hf (7).upper) = "000001001000"b3;   /* set fnp present bit and number of active fnp's to max */
1373       fnp.status_word, colts_pages.status_word = "000000000004"b3;
1374       call return_plus (8);
1375 
1376 /* ********* MME CONTML ********* (controlling terminal)
1377 
1378    input registers:   x1 = old controlling terminal
1379 
1380    mme     contml
1381    ------  return tolts aborted
1382    ------  return tolts swapped
1383    ------  return denied
1384    ------  return slaves copying
1385    ------  return good
1386 
1387    return registers:   x1 = new logical controlling terminal in lower */
1388 
1389 mme_typ (-8): if trace then call tolts_qttyio_$rs (10, "^a MME CONTML @ ^p", ctime (), mmep);
1390       spa.regs.x (1) = "000004"b3;                          /* coded terminal 4 */
1391       call return_plus (5);                                 /* return ic + 5 */
1392 
1393 %page;
1394 
1395 /* ********* MME DATA. ********* (Get itr or mdr from deckfile)
1396 
1397    input registers:           qu = ICC
1398    *                          x1 = ptr to call seq (defined by cata_call structure (see MME CATA.)
1399    *                          x2 = max load address
1400    *                          x3 = test page base
1401    *                          x4 = diskette sector number relative to sector 0
1402 
1403    mme     data.
1404    ------  return if error
1405    ------  return if more or extenstion file follows
1406    ------  return if all read
1407 
1408    return registers:          AL    = words read in this call
1409    *                          Q-reg = error code
1410    *                          status word 1 bit 18 set for extension call */
1411 
1412 mme_typ (-51): if trace | tcd then do;
1413          call tolts_qttyio_$rs (10, "^a MME DATA. @ ^p to load ^a",
1414           ctime (), mmep, cata.key (cata_call.nblk));
1415          genp = addrel (execp, spa.regs.x (1));             /* get ptr to slave call */
1416       end;
1417 
1418       if substr (spa.regs.q, 7, 1) then                     /* if new format */
1419          call get_px_tcx ("DATA. ", substr (spa.regs.q, 8, 11)); /* get test page index */
1420       else call get_px_tcx ("DATA. ", substr (spa.regs.q, 10, 9)); /* get test page index */
1421       genp = addrel (execp, spa.regs.x (1));                /* get ptr to slave call */
1422       dcwp = addrel (execp, cata_call.fdcwp);               /*  get ptr to dcw */
1423       l_ptr = addrel (execp, dcw.address);                  /* get ptr to buffer */
1424       call tolts_util_$search (tolts_info.df_iocbp, (cata.key (cata_call.nblk)), t_ptr, c_len, error);
1425       if error ^= 0 then do;                                /* if we couldn't find module */
1426          call output_status_code (error, "searching for " || cata.key (cata_call.nblk));
1427          call return_plus (1);                              /* take error return */
1428       end;
1429 
1430       if io_info.io_type = mca_io_type then do;
1431          if spa.regs.x (4) ^= "777777"b3 then do;           /* if data is wanted */
1432             io_info.catx = 0;
1433             io_info.mcata_idx = 1;
1434             t_ptr = addrel (t_ptr, fixed (spa.regs.x (4)) * 64); /* adjust the ptr to the correct sector */
1435             if bin (dcw.tally) = 0 then tally = 4096;       /* ck for a zero tally */
1436             else tally = bin (dcw.tally);
1437             if c_len < (fixed (spa.regs.x (4)) * 64) + tally then /* if the data wanted is > then end */
1438                c_len = c_len - fixed (spa.regs.x (4)) * 64; /* adjust the amount to be sent */
1439             else c_len = tally;
1440             if c_len < 0 then call return_plus (1);         /* should not happen */
1441             mvp = addrel (execp, dcw.address);              /* set mvp to where data is to go */
1442             data_move = t_ptr -> data_move;                 /* move it */
1443             spa.regs.a = bit (bin (c_len, 36));             /* set words read */
1444          end;
1445          else spa.regs.a = "0"b;
1446       end;
1447       else do;
1448          call gload_ (t_ptr, l_ptr, fixed (spa.regs.x (3), 18), addr (gload_data), error); /* load it */
1449          if error ^= 0 then do;
1450             call output_status_code (error,
1451              gload_data.diagnostic || " loading module " || cata.key (cata_call.nblk));
1452             call return_plus (1);                           /* take error return */
1453          end;
1454          spa.regs.a = bit (bin (gload_data.text_len, 36));  /* set words read */
1455       end;
1456       if trace | tcd then call tolts_qttyio_$rs (10, "MME DATA.; loaded ""^a"" @ ^p to ^p for ^d",
1457           cata.key (cata_call.nblk), t_ptr, l_ptr, spa.regs.a);
1458 
1459       call return_plus (3);                                 /* take good return */
1460 
1461 %page;
1462 
1463 /* ********* MME DEALCP ********* (deallocate peripheral)
1464 
1465    input registers:   x1 = sct (test page index mod 4)
1466 
1467    mme     dealcp
1468    ------  return
1469 
1470    return registers: none */
1471 
1472 mme_typ (-9): if trace then call tolts_qttyio_$rs (10, "^a MME DEALCP @ ^p", ctime (), mmep);
1473       call get_px_sct ("DEALCP", bin (spa.regs.x (1), 17), "0"b); /* get test page index */
1474       call dealcp_sub;
1475       if dealc_err ^= 0 then
1476          call tolts_abort ("$b3");
1477       else call return_plus (1);
1478 
1479 
1480 
1481 
1482 /* ********* MME DOFPIO ********* (mme to do reponder io)
1483 
1484    input registers:
1485    x1 = pointer to FPINFO table
1486    x3 = test page base
1487    a  = PCW like direct_channel_pcw
1488    q  = time out time
1489 
1490    I/O COMMANDS
1491    71 - Interrupt fnp (uses level 3, 4, 5, 6 & 77)
1492    72 - Bootload fnp (not used)
1493    73 - Interrupt host (uses level 3 & 7)
1494    75 - Test data xfer (fnp - host)
1495    76 - Test data xfer (host - fnp)
1496 
1497 
1498    mme    DOFPIO
1499    zero   good return       (mme call + 1) */
1500 
1501 
1502 mme_typ (-89): if trace | trace_io then call tolts_qttyio_$rs
1503           (10, "^a MME DOFPIO ^p, type - ^12.3b", ctime (), mmep, substr (spa.regs.a, 25));
1504 
1505       tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1));
1506 
1507       do io_sel = 1 to hbound (tolts_info.pages, 1)         /* get the correct io_info for this page */
1508        while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num);
1509       end;
1510 
1511       if io_sel > hbound (tolts_info.pages, 1) then call tolts_abort ("$c3");
1512       io_info_ptr = addr (pages (io_sel));
1513       io_info.fpinfo_ptr = tolts_fpinfo_ptr;                /* save fpinfo_ptr for this page */
1514       tolts_rspd_wksp = io_info.tolts_rspd_wksp;            /* get work space ptr */
1515       tolts_fpinfo.fnpdcw.address =                         /* set dcw address */
1516        bin (bin (spa.regs.x (3), 18) + bin (substr (spa.regs.a, 1, 18), 18), 18);
1517       direct_channel_pcw_ptr =                              /* set pcw */
1518        addr (tolts_rspd_workspace.mailbox.pcw);
1519       substr (unspec (direct_channel_pcw), 19) = substr (spa.regs.a, 19);
1520       substr (unspec (tolts_fpinfo.pcw_info), 19) =
1521        substr (spa.regs.a, 19);                             /* save pcw for test page */
1522       io_info.dcw_list (1) = exec_wd (tolts_fpinfo.fnpdcw.address); /* set dcw */
1523       direct_channel_tcw_ptr = addr (tolts_rspd_workspace.tcw); /* get tcw */
1524       unspec (direct_channel_tcw) = unspec (io_info.dcw_list (1));
1525       if direct_channel_pcw.operation = "75"b3              /* if data xfer pcw */
1526        | direct_channel_pcw.operation = "76"b3 then do;     /* set up pcw */
1527          substr (spa.regs.a, 1, 18) = unspec (tolts_fpinfo.fnpdcw.address);
1528          direct_channel_pcw.tcw_address = wordno (addr (tolts_rspd_workspace.tcw));
1529       end;
1530 
1531       else direct_channel_pcw.tcw_address = 0;              /* else set to 0 */
1532       io_info.pcwa = spa.regs.a;
1533       if direct_channel_pcw.operation = "76"b3 then do;     /* if sending data - move it */
1534          c_len = direct_channel_tcw.host_word_count;
1535          mvp = addrel (execp, bin (substr (spa.regs.a, 1, 18)) + 1);
1536          bufp = addr (tolts_rspd_workspace.data_buf);
1537          workspace_move = mvp -> workspace_move;
1538       end;
1539 
1540       tolts_rspd_workspace.pcw = direct_channel_pcw;
1541       unspec (tolts_rspd_workspace.tcw) = unspec (direct_channel_tcw);
1542       tio_off = wordno (direct_channel_pcw_ptr);
1543       io_info.lostit_time = bin (tolts_fpinfo.timeout_time);
1544       call tolts_init_$gc_tod ((tolts_fpinfo.timeout_time));
1545       tolts_fpinfo.timeout_time = bit (bin (tolts_fpinfo.timeout_time, 36) + io_info.lostit_time, 35);
1546       tolts_fpinfo.io_rq_cnt = tolts_fpinfo.io_rq_cnt + 1;  /* bump io request count */
1547 
1548       io_info.io_in_progress = "1"b;
1549       io_info.num_connects = io_info.num_connects + 1;
1550       call ioi_$connect (io_info.device_index, tio_off, error);
1551       if error ^= 0 then do;
1552          call output_status_code (error, "io connect error");
1553          call tolts_abort ("$c7");
1554       end;
1555 
1556       wake_time = 500000;
1557       call timer_manager_$sleep (wake_time, "10"b);
1558       tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1;
1559       call return_plus (1);
1560 
1561 /* ********* MME EXPDEV ********* (return device sct)
1562 
1563    input registers:   x1 = sct (test page index mod 4)
1564 
1565    mme     expdev
1566    ------  return
1567 
1568    return registers: A and Q regs contain 1st and 2nd words of device sct entry */
1569 
1570 mme_typ (-12): if trace then call tolts_qttyio_$rs (10, "^a MME EXPDEV @ ^p", ctime (), mmep);
1571       call get_px_sct ("EXPDEV", bin (spa.regs.x (1), 17), "1"b); /* get test page index */
1572       spa.regs.a = unspec (io_info.devsct.w1);              /* set sct in a  */
1573       spa.regs.q = unspec (io_info.devsct.w2);              /* and q registers */
1574       call return_plus (1);
1575 
1576 /* ********* MME FEPTYP ********* (return fnp type)
1577 
1578    input registers:   x2 =  logical fep number * 4
1579 
1580    mme     feptyp
1581    oct     0         data returned here
1582    ------  return        */
1583 
1584 
1585 
1586 mme_typ (-59): if trace then call tolts_qttyio_$rs (10, "^a MME FEPTYP @ ^p", ctime (), mmep);
1587 
1588 
1589       cdtp = cdtptr;
1590       j = bin (spa.regs.x (2));                             /* get true fnp number */
1591       tolts_info.fnp (j).type = (fnp_entry (j + 1).type);   /* find type */
1592       if tolts_info.fnp (j).type = 1 then spa.regs.x (2) = "000002"b3; /* if type 1 (dn355) set code */
1593       else if tolts_info.fnp (j).type = 3
1594        then spa.regs.x (2) = "000001"b3;                    /* if type 3 (DN6670) set code */
1595       else if tolts_info.fnp (j).type = 0
1596        then spa.regs.x (2) = "777777"b3;                    /* if type = 0 then illegal type set error return */
1597       if fnp_entry (j + 1).mpxe.current_service_type ^= 1
1598        & fnp_entry (j + 1).state ^= 4 then do;              /* if fnp is not up */
1599          spa.regs.x (2) = "777777"b3;                       /* return a bad code */
1600          call tolts_qttyio_$rs (0, "^as: fnp ^a is ^a", exec, tags (j + 1),
1601           fnp_state (fnp_entry (j + 1).mpxe.state));        /* notify the user */
1602       end;
1603       call return_plus (1);
1604 
1605 
1606 /* ********* MME FPWRAP ********* (Responder wrapup)
1607 
1608    input registers:   X1 = fpinfo pointer
1609 
1610    mme     fpwrap
1611    ------  return    */
1612 
1613 
1614 mme_typ (-93): if trace then call tolts_qttyio_$rs (10, "^a MME FPWRAP @ ^p", ctime (), mmep);
1615 
1616       tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1));    /* get pointer to test page fpinfo table */
1617 
1618       do io_sel = 1 to hbound (pages, 1)                    /* get the correct io_info for this page */
1619 
1620        while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num);
1621       end;
1622 
1623       if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* page not found - */
1624       io_info_ptr = addr (pages (io_sel));
1625       tolts_rspd_wksp = io_info.tolts_rspd_wksp;            /* get the io workspace for this page */
1626       tolts_fpinfo.partrs = 0;                              /* reset tolts assigned flag */
1627       if ^io_info.io_in_progress then tolts_fpinfo.io_rq_cnt = 0; /* reset io rquest count */
1628       unspec (tolts_rspd_workspace.mailbox.num_int) = "0"b; /* reset int count */
1629       tolts_rspd_workspace.mailbox.status_word = "0"b;
1630       call dealcp_sub;                                      /* release the fep */
1631       call return_plus (1);
1632 
1633 
1634 
1635 /* ********* MME FREEZE ********* (wire main memory (gcos only))
1636 
1637    input registers:   none
1638 
1639    mme     freeze
1640    ------  return
1641 
1642    return registers: X5 = LAL (returned = 0) */
1643 
1644 
1645 mme_typ (-53): if trace then call tolts_qttyio_$rs (10, "^a MME FREEZE @ ^p", ctime (), mmep);
1646       spa.regs.x (5) = "0"b;                                /* set x 5 to 0 */
1647       call return_plus (1);
1648 %page;
1649 
1650 
1651 /* ********* MME GECALL ********* (load object deck)
1652 
1653    input registers: none
1654    output register: q       error code entry options(variable)
1655    mme     gecall
1656    bci     1,name
1657    zero    add,error return
1658    zero    transfer add,0 */
1659 
1660 
1661 
1662 mme_typ (18): call bcd_to_ascii_ (mme_call_w (1), ac_name); /* convert callname to ascii */
1663       if trace then call tolts_qttyio_$rs (10, "^a MME GECALL (^a) @ ^p", ctime (), ac_name, mmep);
1664       coment = "";
1665       l_ptr = addrel (execp, mme_call_hf (2).upper);
1666       call tolts_util_$search (tolts_info.df_iocbp,
1667        substr (tolts_info.exec, 1, 1) || "lt." || ac_name, t_ptr, c_len, error);
1668       if error ^= 0 then                                    /* if could'nt find polt or molt page, try util */
1669          call tolts_util_$search (tolts_info.df_iocbp, "utl." || ac_name, t_ptr, c_len, error);
1670       if error ^= 0 then                                    /* if found test page */
1671          call ioa_$rsnnl ("searching for test page ^a", coment, mesg_len, ac_name);
1672       if error = 0 then
1673          call gload_ (t_ptr, l_ptr, fixed (spa.regs.x (3), 18), addr (gload_data), error); /* load it */
1674       if error ^= 0 then do;
1675          if coment = "" then
1676             call ioa_$rsnnl ("^a loading test page ^a", coment, mesg_len, gload_data.diagnostic, ac_name);
1677          call output_status_code (error, coment);
1678          if mme_call_hw (2).lower = "0"b                    /* error return = 0 */
1679           then spa.enter.icivlu = spa.wrapup_add;           /* set return to molts wrapup */
1680          else do;
1681             spa.enter.icivlu.ic = mme_call_hw (2).lower;    /* error return */
1682             mme_call_hw (2).lower = "0"b;                   /* zero error return to prevent loop */
1683             spa.regs.q = "63"b3;                            /* set q = file not found eror code */
1684          end;
1685       end;
1686       else spa.enter.icivlu.ic = mme_call_hw (3).upper;     /* normal return */
1687       call wake_disp;                                       /* go wake up dispatcher */
1688 
1689 /* ********* MME GEENDC ********* (end courtesy call)
1690 
1691    input/return registers: none
1692 
1693    mme     geendc
1694    no return from mme,   enters code whereever ccc interrupted */
1695 
1696 mme_typ (14): if trace | trace_io then call tolts_qttyio_$rs (10, "^a MME GEENDC @ ^p", ctime (), mmep);
1697       if ^in_ccc then do;                                   /* if not in courtesy call complain */
1698          call tolts_qttyio_$rs (0, "^as: MME GEENDC while not in courtesy call", exec);
1699          call tolts_abort ("$a6");
1700       end;
1701       gndc_flag = "1"b;                                     /* set geendc complete flag */
1702       in_ccc = "0"b;                                        /* reset courtesy call flag */
1703       unspec (spa.regs) = addr (spa.ccc_regs) -> reg_move;
1704       string (spa.enter.icivlu) = spa.ccc_icivlu;
1705       call wake_disp;                                       /* go wake up dispatcher */
1706 %page;
1707 /* ********* MME GEINOS ********* (console write or interslave read)
1708 
1709    input/return registers: none
1710 
1711    isc read:        mme     geinos                console write:      mme     geinos
1712    *                oct     010000000000                              oct     130000000000
1713    *                zero    quefcd,quedcw                             zero    flcode,ondcw
1714    *                zero    quests,quecc                              zero    ofstat,offccc
1715    *                ------  return                                    ------  return   */
1716 mme_typ (1): if trace then call tolts_qttyio_$rs (10, "^a MME GEINOS @ ^p, type - ^12.3b", ctime (), mmep, mme_call_w (1));
1717       if mme_call_w (1) ^= "130000000000"b3 & mme_call_w (1) ^= "010000000000"b3 then do; /* illegal type */
1718          call tolts_qttyio_$rs (0, "^as: MME GEINOS type ^12.3b not supported", exec, mme_call_w (1));
1719          call tolts_abort ("$a7");
1720       end;
1721       dcwp = addrel (execp, mme_call_hf (2).lower);         /* get ptr to dcw */
1722       exec_wd (mme_call_hf (3).upper), exec_wd (mme_call_hf (3).upper + 1) = "0"b; /* set status & dcw res to 0 */
1723       if mme_call_hw (1).upper = "010000"b3 then do;        /* isc read */
1724          if dcw.type ^= "0"b then do;                       /* dcw not iotd */
1725             call tolts_qttyio_$rs (0, "^as: MME GEINOS; Read isc dcw type not iotd. DCW = 12.3b",
1726              exec, string (dcw));
1727             call tolts_abort ("$a7");
1728          end;
1729          if dcw.tally ^= "0003"b3 then do;                  /* isc read word cnt must be 3 */
1730             call tolts_qttyio_$rs (0, "^as: MME GEINOS; Read isc word count ^= 3. DCW = 12.3b",
1731              exec, string (dcw));
1732             call tolts_abort ("$a7");
1733          end;
1734          if tolts_info.exec_dta_cnt ^= 0 then do;           /* if data to xfer... */
1735             j = mme_call_hf (3).upper;                      /* copy status address */
1736             call pop_isc (j, bin (dcw.address, 17));        /* do it */
1737             if mme_call_hf (3).lower ^= 0 then              /* if courtesy call requested */
1738                call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
1739                 mme_call_hw (3).lower || "000000"b3);
1740          end;
1741          else do;                                           /* no data to xfer */
1742             isc_cntdn = 10000;
1743             if mme_call_hf (3).lower ^= 0 then do;          /* if courtesy call requested */
1744                isc_ccc_rqt = "1"b;
1745                isc_queue.icivlu = mme_call_hw (3).lower || "000000"b3;
1746                isc_queue.status_add = mme_call_hf (3).upper;
1747                isc_queue.data_add = fixed (dcw.address);
1748             end;
1749          end;
1750       end;
1751       else do;                                              /* console write */
1752          if mme_call_hf (3).lower ^= 0 then                 /* if courtesy call requested */
1753             call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
1754              mme_call_hw (3).lower || "000000"b3);
1755          call tolts_qttyio_$dcw_list (dcwp, 0);             /* output the dcwp */
1756       end;
1757       call return_plus (4);                                 /* return ic + 4 */
1758 %page;
1759 /* ********* MME GELBAR ********* (load base address register)
1760 
1761    input registers: AR = upper/ptr to LOC1 structure (defined by gelbar_temp below)
1762    *                QR = CPU time increment beffor interrupt
1763 
1764    mme   gelbar
1765    no return, return to ic value located in gelbar_temp.ic
1766 
1767    return registers: none */
1768 
1769 dcl  1 gelbar_temp based (genp) aligned,                    /* template for gelbar loc1 and loc1+1 */
1770        (2 bar bit (18),                                     /* desired bar value */
1771        2 reg_ptr bit (18),                                  /* ptr to register storage */
1772        2 ic bit (18),                                       /* instruction counter */
1773        2 ind bit (18)) unaligned;                           /* indicator register */
1774 
1775 mme_typ (31): if trace then call tolts_qttyio_$rs (10, "^a MME GELBAR @ ^p", ctime (), mmep);
1776       spa.glbtmr = spa.regs.q;                              /* store entry timer setting */
1777       genp = addrel (execp, substr (spa.regs.a, 1, 18));    /* get ptr to LOC1 */
1778       spa.enter.icivlu.ic = gelbar_temp.ic;                 /* set desired ic value */
1779       spa.enter.icivlu.ind = gelbar_temp.ind;               /* and indicators */
1780       spa.enter.lbar.bar = gelbar_temp.bar;                 /* store new bar value to return */
1781       spa.acc_fault = gelbar_temp.bar || "000000"b3;        /* also save bar in accum fault status word */
1782       call tolts_init_$gc_tod (gcos_tod);                   /* get current time of day */
1783       string (spa.glbici) = gcos_tod;                       /* save current time of day in word 22 */
1784       genp = addrel (execp, gelbar_temp.reg_ptr);
1785       unspec (spa.regs) = genp -> reg_move;                 /* move regs to be returned */
1786       gelbar = "1"b;                                        /* and set gelbar mode indicator */
1787       call wake_disp;                                       /* go wake up dispatcher */
1788 
1789 /* ********* MME GEMORE ********* (get more memory)
1790 
1791    input/return registers: none
1792 
1793    mme     gemore
1794    zero    0,no. 1024 word blocks
1795    ------  return denial
1796    ------  return succesful */
1797 
1798 mme_typ (9): if trace then call tolts_qttyio_$rs (10, "^a MME GEMORE @ ^p", ctime (), mmep);
1799       call return_plus (3);                                 /* return ic + 3 */
1800 
1801 /* ********* MME GEMREL ********* (release memory)
1802 
1803    input registers: AR = return address in upper, lower not used
1804    *                QR = words lower mem to release in upper, words upper mem to release in lower
1805 
1806    mme     gemrel
1807    ------  return
1808 
1809    return registers: none */
1810 
1811 mme_typ (21): if trace then call tolts_qttyio_$rs (10, "^a MME GEMREL @ ^p", ctime (), mmep);
1812       spa.enter.icivlu.ic = substr (spa.regs.a, 1, 18);     /* return to address in a upper */
1813       call wake_disp;                                       /* go wake up dispatcher */
1814 %page;
1815 /* ********* MME GEPROC ********* (dedicate CPU, unused in Multics. Return error)
1816 
1817    input/return registers: none
1818 
1819    mme     geproc
1820    zero    gprprc,0
1821    zero    work,0
1822    ------  return error
1823    ------  return good */
1824 
1825 mme_typ (-13): if trace then call tolts_qttyio_$rs (10, "^a MME GEPROC @ ^p", ctime (), mmep);
1826       call return_plus (3);                                 /* return ic + 3, error return for Multics */
1827 
1828 /* ********* MME GERELC ********* (wait for I/O interrupt to occur)
1829 
1830    input/return registers: none
1831 
1832    mme     gerelc
1833    ------  return */
1834 
1835 mme_typ (15): if trace then call tolts_qttyio_$rs (10, "^a MME GERELC @ ^p", ctime (), mmep);
1836       call return_plus (1);
1837 
1838 /* ********* MME GEROAD ********* (road block, wait)
1839 
1840    input/return registers: none
1841 
1842    mme     geroad
1843    ------  return */
1844 mme_typ (2): if trace then call tolts_qttyio_$rs (10, "^a MME GEROAD @ ^p", ctime (), mmep);
1845       rd_blk = "1"b;
1846       call return_plus (1);
1847 
1848 
1849 /* ********* MME GEROUT ********* (colts communications)
1850 
1851    l   mme    gerout
1852    l+1     vfd     18/record pointer,06/op,12/terminal id
1853    l+2             status word pointer,courtesy call pointer
1854    l+3             return
1855 
1856 
1857    There are six gerout types handled by tolts.
1858    04  write/read
1859    05  remote inquiry
1860    06  terminal type request
1861    07  fnp colts wake-up
1862    17  disconnect
1863    20  line status request       */
1864 
1865 
1866 mme_typ (24): if trace then call tolts_qttyio_$rs (10, "^a MME GEROUT ^p, type - ^12.3b", ctime (), mmep, mme_call_w (1));
1867 
1868       gerout_num = bin (substr (mme_call_hw (1).lower, 1, 6)); /* get the gerout number index       */
1869       if gicm_count > 0 then call return_plus (0);
1870       else go to gerout (gerout_num);                       /* goto the gerout handler for this gerout        */
1871 %page;
1872 
1873 
1874 gerout (4): wicmp = addrel (execp, mme_call_hf (1).upper);  /* get write icm pointer */
1875       ricmp = addrel (execp, bin (wicm.rbuf_addr) - 1);     /* get read icm pointer */
1876       if gicmp = null then alloc gicm;                      /* alloc an icm area */
1877       gicmp = addr (gicm);                                  /* get a ptr to it */
1878       icm_tally = bin (wicm.word_total) * 2;                /* get icm tally */
1879       k = bin (substr (mme_call_hw (1).lower, 15, 4));      /* get index */
1880       if substr (mme_call_hw (1).lower, 13, 1) = "1"b then do; /* an exec request */
1881          if substr (wicm.host_opcode, 10, 9) = "042"b3 then do; /* if load memory request */
1882             alloc ticm;                                     /* allocate a temp icm */
1883             ticmp = addr (ticm);                            /* get a ptr */
1884             ticm = wicm;                                    /* move the icm */
1885             fnp_num = bin (substr (mme_call_hw (1).lower, 16, 3)) + 1; /* get the fnp number */
1886             do i = 1 to 2;
1887                if substr (ticm.icm_buf (1), 1, 18) = "777777"b3 then do; /* if first get mem icm */
1888                   call db_fnp_eval_ (null (), fnp_num, ".criom", null (), exec, fnp_addr, code);
1889                                                             /* get address of fnp iom table */
1890                   if code ^= 0 then go to db_err;           /* if error go to error routine */
1891                   icm_tally = 1;                            /* else set icm tally to correct value */
1892                end;
1893                else do;
1894                   i = 2;                                    /* second get mem icm */
1895                   icm_tally = bin (wicm.word_total) * 2;    /* compute the icm tally */
1896                   fnp_addr = bin (substr (ticm.icm_buf (1), 1, 18)); /* fill in fnp address */
1897                end;
1898                call db_fnp_memory_$fetch (null (), fnp_num, fnp_addr, icm_tally, addr (ticm.icm_buf), code);
1899                                                             /* get the iom table */
1900 db_err:        if code ^= 0 then do;                        /* if error */
1901                   call convert_status_code_ (code, shortinfo, lginfo);
1902                   call tolts_qttyio_$rs (0, "^as: ^a error reading fnp memory", tolts_info.exec, lginfo);
1903                                                             /* can't read fnp memory */
1904                   ticm.fnp_opcode = "000051"b3;             /* set bad status */
1905                end;
1906                else ticm.fnp_opcode = "000041"b3;           /* supply op complete code */
1907             end;
1908             ticm.rbuf_addr = "0"b;                          /* zero read buffer pointer */
1909             call tolts_alm_util_$gen_ck_sum (ticmp);        /* generate an icm check sum */
1910             ricm = ticm;                                    /* move icm */
1911             free ticm;
1912             ticmp = null;
1913             if mme_call_hf (2).lower ^= 0 then do;          /* a cc is requested */
1914                exec_wd (mme_call_hf (2).upper) = "000000000004"b3;
1915                call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
1916                 mme_call_hw (2).lower || "000000"b3);       /* enter a ccc request */
1917             end;
1918          end;
1919          else if substr (wicm.host_opcode, 10, 9) = "001"b3 then do; /* if a start test request */
1920             do i = 1 to 8 while (colts_pages (i).in_use);   /* find vacant test page slot */
1921             end;
1922             if i = 8 & colts_pages (8).in_use then do;      /* if 8 pages running - error */
1923                call tolts_qttyio_$rs (0, "^a: mme gerout 04; no vacant test page slot found", exec);
1924                call tolts_abort ("$c1");
1925             end;
1926 
1927             colts_pages (i).in_use = "1"b;                  /* else set page in use */
1928 
1929             do j = 1 to 8;
1930                if substr (fnp (k).cdt_name (j), 1, 5) ^= "empty" then do;
1931                   colts_pages (i).cdt_name = tolts_info.fnp (k).cdt_name (j);
1932                                                             /* save the cdt name in the test page */
1933                   tolts_info.fnp (k).cdt_name (j) = "empty";
1934                   j = 8;
1935                end;
1936             end;
1937             tolts_info.exec_page_count = tolts_info.exec_page_count + 1; /* inc test page count */
1938             dmap = addr (tolts_info.colts_pages (i).dm_arg);/* get dial_manager_arg ptr */
1939             colts_pages (i).dm_arg.version = dial_manager_arg_version_2; /* fill in the required fields */
1940             colts_pages (i).dm_arg.dial_qualifier = substr (colts_pages (i).cdt_name, 1, 22);
1941             colts_pages (i).dm_arg.dial_channel = tolts_info.dm_event;
1942             colts_pages (i).dm_arg.channel_name = colts_pages (i).cdt_name;
1943             colts_pages (i).type_code = substr (wicm.icm_buf (1), 22, 6);
1944             nr_cnt = 0;                                     /* reset the no responce count */
1945             call dial_manager_$tandd_attach (dmap, code);   /* get the channel for testing */
1946             if code ^= 0 then do;                           /* if error */
1947                if debugging then call com_err_ (code, "mtdsim_", "Error on tandd_attachment of ^a.",
1948                    colts_pages (i).cdt_name);
1949                colts_pages (i).in_use = "0"b;               /* reset test page active */
1950                call convert_status_code_ (code, shortinfo, lginfo);
1951                call tolts_qttyio_$rs (0, "^as: ^a/ error attempting a tandd_attach of ^a",
1952                 tolts_info.exec, lginfo, substr (colts_pages (i).cdt_name, 1, 6));
1953                colts_op_flags.colt_flag = "0"b;             /* make use flag is reset so we don't go blocked */
1954                alloc ticm;                                  /* allocate a temp icm */
1955                ticmp = addr (ticm);                         /* get a ptr */
1956                ticm = wicm;                                 /* move the icm */
1957                ticm.fnp_opcode = "000051"b3;                /* set error status code */
1958                ticm.rbuf_addr = "0"b;                       /* zero read buffer pointer */
1959                call tolts_alm_util_$gen_ck_sum (ticmp);     /* generate an icm check sum */
1960                ricm = ticm;                                 /* move icm */
1961                free ticm;
1962                ticmp = null;
1963                if mme_call_hf (2).lower ^= 0 then do;       /* a cc is requested */
1964                   exec_wd (mme_call_hf (2).upper) = "000000000004"b3;
1965 
1966                   call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
1967                    mme_call_hw (2).lower || "000000"b3);    /* enter a ccc request */
1968                end;
1969                call return_plus (3);
1970             end;
1971             tolts_info.wait_list.nchan = tolts_info.wait_list.nchan + 1; /* inc the event wait list */
1972             tolts_info.wait_event_id (tolts_info.wait_list.nchan) = tolts_info.dm_event; /* store the event id */
1973             clt_sw = substr (colts_pages (i).cdt_name, 1, 6) || ".sw"; /* create a switch name */
1974             att_desc = "tty_ " || substr (colts_pages (i).cdt_name, 1, 6); /* and an attach description */
1975             colts_op_flags.dm_attach = "1"b;                /* set colts control flags */
1976             colts_op_flags.colt_flag = "1"b;
1977             colts_op_flags.sicm = "1"b;
1978             l = i;                                          /* save i for later use */
1979          end;
1980          else do;                                           /* else a normal exec icm */
1981             call iox_$put_chars (fnp (k).fnp_execp, wicmp, (bin (wicm.word_total) + 1) * 4, code); /* transmit the icm */
1982             if code ^= 0 then do;                           /* if error */
1983                call convert_status_code_ (code, shortinfo, lginfo);
1984                call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer to fnp", tolts_info.exec, lginfo);
1985                call tolts_abort ("$c1");                    /* then abort colts */
1986             end;
1987             gicm_count = gicm_count + 1;                    /* inc outstanding icms count */
1988 
1989             if gicm_count = 17 then do;                     /* if = 17 - error */
1990                call tolts_qttyio_$rs (0, "^as: excessive outstanding io's", tolts_info.exec);
1991                call tolts_abort ("$c1");                    /* abort colts */
1992             end;
1993 
1994             gicm.cltp = fnp (k).fnp_execp;                  /* save iocb ptr */
1995             gicm.ricmp = ricmp;                             /* rd icm ptr */
1996             gicm.tally = bin (wicm.word_total) + 1;         /* icm tally */
1997             if mme_call_hf (2).lower ^= 0 then do;          /* if cc requested */
1998                gicm.cc_addr = mme_call_hw (2).lower || "000000"b3; /* save ccc address */
1999                gicm.st_addr = mme_call_hf (2).upper;        /* save status address */
2000             end;
2001          end;
2002       end;
2003       else do;                                              /* else icm for test chan */
2004 
2005          call iox_$put_chars (colts_pages (k).chanp, wicmp, (bin (wicm.word_total) + 1) * 4, code); /* send the icm */
2006          if code ^= 0 then do;                              /* if error */
2007             call convert_status_code_ (code, shortinfo, lginfo);
2008             call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer to chan ^a",
2009              tolts_info.exec, lginfo, substr (colts_pages (k).cdt_name, 1, 6));
2010             colts_pages (k).status_word = "000000000002"b3; /* store bad status */
2011          end;
2012 
2013          gicm_count = gicm_count + 1;                       /* inc outstanding icm count */
2014 
2015          if gicm_count = 17 then do;                        /* if 17 - error */
2016             call tolts_qttyio_$rs (0, "as: excessive outstanding io count", tolts_info.exec);
2017             call tolts_abort ("$c1");                       /* abort tolts */
2018          end;
2019          gicm.cltp = colts_pages (k).chanp;                 /* save iocb ptr */
2020          gicm.ricmp = ricmp;                                /* read icm ptr */
2021          gicm.tally = bin (wicm.word_total) + 1;            /* tally */
2022          if mme_call_hf (2).lower ^= 0 then do;             /* if cc requested */
2023             gicm.cc_addr = mme_call_hw (2).lower || "000000"b3; /* save ccc address */
2024             gicm.st_addr = mme_call_hf (2).upper;           /* status address */
2025          end;
2026       end;
2027       call return_plus (3);
2028 
2029 
2030 
2031 gerout (5): remote_inquiry_ic = bin (rel (addr (mme_call_w (1)))); /* remember remote inquiry location */
2032       call return_plus (3);                                 /* return to colts */
2033 
2034 gerout (06):
2035       k = bin (substr (mme_call_hw (1).lower, 15, 4));
2036       if substr (mme_call_hw (1).lower, 13, 1) = "1"b then
2037          mme_call_hw (1).upper = tolts_info.fnp (k).exec_type_code || "0000"b3; /* set type code    */
2038 
2039       else substr (mme_call_hw (1).upper, 1, 6) = colts_pages (k).type_code;
2040       call return_plus (3);
2041 
2042 
2043 gerout (7): if remote_inquiry_ic ^= 0 then do;              /* if no outstanding remote inquiry - error */
2044 
2045          k = bin (substr (mme_call_hw (1).upper, 1, 3));    /* k = fnp number */
2046 
2047          if ^tolts_info.fnp (k).exec_active then do;        /* if the fnp exec is not active */
2048             dmap = addr (tolts_info.fnp (k).dm_arg);        /* get addr of dial_manager arg */
2049             fnp (k).dm_arg.version = dial_manager_arg_version_2;
2050             fnp (k).dm_arg.dial_qualifier = substr (fnp (k).exec_chan, 1, 22);
2051             tolts_info.fnp (k).dm_arg.dial_channel = tolts_info.dm_event; /* set dial_channel to event channel */
2052             tolts_info.fnp (k).dm_arg.channel_name = fnp (k).exec_chan; /* get channel name         */
2053 
2054             nr_cnt = 0;                                     /* reset the no responce count */
2055             call dial_manager_$privileged_attach (dmap, code);
2056             if code ^= 0 then do;
2057                call convert_status_code_ (code, shortinfo, lginfo);
2058                call tolts_qttyio_$rs (0, "^as: ^a/ error attempting a priviledged_attatch of ^a",
2059                 tolts_info.exec, lginfo, fnp (k).channel_name);
2060                call tolts_abort ("$c1");                    /* then abort colts */
2061             end;
2062 
2063             tolts_info.wait_list.nchan = wait_list.nchan + 1;
2064             tolts_info.wait_event_id (tolts_info.wait_list.nchan) = tolts_info.dm_event;
2065             clt_sw = substr (fnp (k).exec_chan, 1, 6) || ".sw";
2066 
2067             att_desc = "tty_ " || substr (fnp (k).exec_chan, 1, 6);
2068             colts_op_flags.colt_flag = "1"b;
2069             colts_op_flags.dm_attach = "1"b; ;
2070             fnp (k).exec_type_code = substr (mme_call_hw (1).lower, 13, 6); /* save exec type code  */
2071          end;
2072          call return_plus (2);
2073       end;
2074       else do;
2075          call tolts_qttyio_$rs (0, "^as:  MME GEROUT 07 - no outstanding GEROUT 05", exec);
2076          call tolts_abort ("$c9");
2077       end;
2078 
2079 
2080 gerout (15): if mme_call_hw (1).lower = "170000"b3 then call return_plus (3);
2081       k = bin (substr (mme_call_hw (1).lower, 15, 4));
2082       if substr (mme_call_hw (1).lower, 13, 3) = "4"b3 then call rel_exec_chan (k);
2083 
2084       else call rel_tst_chan (k);
2085 
2086       if mme_call_hf (2).lower ^= 0 then do;
2087          exec_wd (mme_call_hf (2).upper) = "000000000002"b3;
2088          call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), mme_call_hw (2).lower || "000000"b3);
2089       end;
2090 
2091       call return_plus (3);
2092 
2093 
2094 
2095 gerout (16): k = bin (substr (mme_call_hw (1).lower, 15, 4));
2096       if substr (mme_call_hw (1).lower, 13, 1) = "1"b then
2097          exec_wd (mme_call_hf (2).upper) = "000000000004"b3;
2098       else exec_wd (mme_call_hf (2).upper) = colts_pages (k).status_word;
2099       call return_plus (3);
2100 
2101 
2102 %page;
2103 
2104 /* ********* MME GESNAP ********* (snap shot dump)
2105 
2106    input/return registers: none
2107 
2108    mme     gesnap
2109    iotd    add,wc
2110    ------  return */
2111 
2112 mme_typ (5): if trace then call tolts_qttyio_$rs (10, "^a MME GESNAP @ ^p", ctime (), mmep);
2113       if tolts_info.file_attach then                        /* if print file attached */
2114          call tolts_file_util_$snap (addrel (mmep, 1));     /* go output snap dump */
2115       call return_plus (2);                                 /* return ic + 2 */
2116                                                             /* ********* MME GETIME ********* (return date/time)
2117 
2118                                                                input registers: none
2119 
2120                                                                mme     getime
2121                                                                ------  return
2122 
2123                                                                return registers:   AR - date,  QR - time (right justified--1/64 ms. past midnight */
2124 
2125 mme_typ (17): if trace then call tolts_qttyio_$rs (10, "^a MME GETIME @ ^p", ctime (), mmep);
2126       call tolts_init_$gc_tod (spa.regs.q);                 /* get time of day */
2127       spa.regs.a = tolts_info.gc_date;                      /* and bcd date */
2128       call return_plus (1);
2129 
2130 /* ********* MME HUNGTM ********* (check for outstanding I/O)
2131 
2132    input registers:   AU = test page index (mod 4)
2133 
2134    mme     hungtm
2135    ------  return not in transmission
2136    ------  return in transmission
2137 
2138    return registers: QR = lostit time, X1 = 5 if timeout; = 3 if still time to go */
2139 
2140 mme_typ (-16): if trace then call tolts_qttyio_$rs (10, "^a MME HUNGTM @ ^p", ctime (), mmep);
2141       call get_px_sct ("HUNGTM", bin (substr (spa.regs.a, 1, 18), 17), "1"b); /* get test page index */
2142       if substr (spa.regs.a, 1, 18) = "0"b then do;
2143          call tolts_qttyio_$rs (0, "^a MME HUNGTM  illegal test page index @ ^p", ctime (), mmep);
2144          call tolts_abort ("$b6");
2145       end;
2146       call tolts_init_$gc_tod (gcos_tod);                   /* get current time of day */
2147       if bin (gcos_tod, 36) >= io_info.con_time + io_info.lostit_time then do; /* if time exceeded */
2148          spa.regs.x (1) = "000005"b3;                       /* set courtesy call wating */
2149          exec_wd (io_info.status_add) = "510006000000"b3;   /* set time out status */
2150          call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
2151           string (io_info.icivlu));                         /* enter ccc request */
2152          spa.regs.q = "0"b;                                 /* set 0 lostit time */
2153       end;
2154       else do;                                              /* not time out yet */
2155          spa.regs.x (1) = "000003"b3;                       /* set in xmission */
2156          spa.regs.q = bit ((io_info.con_time + io_info.lostit_time) - bin (gcos_tod, 35, 0), 35);
2157       end;
2158       call return_plus (2);                                 /* return ic + 2 */
2159 %page;
2160 /* ********* MME IOCONS ********* (return number of I/O connects)
2161 
2162    input registers:   x1 = sct (test page index mod 4)
2163 
2164    mme     iocons
2165    ------  return
2166 
2167    return registers:   AR = number of connects for this test page */
2168 
2169 mme_typ (-17): if trace then call tolts_qttyio_$rs (10, "^a MME IOCONS @ ^p", ctime (), mmep);
2170       call get_px_sct ("IOCONS", bin (spa.regs.x (1), 17), "1"b); /* get test page index */
2171       spa.regs.a = bit (bin (pages (io_sel).num_connects, 36));
2172       call return_plus (1);
2173 
2174 /* ********* MME IPCW. ********* ( send initialize PCW to mpc )
2175 
2176    input registers:   x1 = ICC
2177 
2178 
2179    mme     ipcw.
2180    ------  return
2181 
2182    return registers: none */
2183 
2184 mme_typ (-55): if trace then call tolts_qttyio_$rs (10, "^a MME IPCW. @ ^p", ctime (), mmep);
2185       if substr (spa.regs.x (1), 7, 1) then                 /* if new format */
2186          call get_px_tcx ("IPCW. ", substr (spa.regs.x (1), 8, 11)); /* get test page index */
2187       else call get_px_tcx ("IPCW. ", substr (spa.regs.x (1), 10, 9)); /* get test page index */
2188       pcwa = "0"b;                                          /* initialize pcw first */
2189       pcwp = addr (pcwa);
2190       pcw.code = "111"b;                                    /* Set PCW code */
2191       pcw.mask = "1"b;                                      /* Make it a reset PCW */
2192       pcw.control = "11"b;
2193       ioi_wksp = io_info.workspace_ptr;                     /* get ptr to our workspace */
2194       tio_off = fixed (rel (addr (tolts_workspace.p_idcw)));/* set default dcw list offset for ioi */
2195       idcwp = addr (tolts_workspace.p_idcw);                /* set up idcw ptr */
2196       string (idcw) = "0"b;                                 /* intiialize idcw */
2197       idcw.code = "7"b3;                                    /* set in idcw type code */
2198       io_info.to_no_cc = "1"b;                              /* set flag for int processor */
2199       call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error);
2200       if error ^= 0 then do;
2201          call output_status_code (error, "io connect error");
2202          call tolts_abort ("$m5");
2203       end;
2204       call return_plus (1);
2205 %page;
2206 /* ********* MME LODIMG ********* (load print train image (GCOS only))
2207 
2208    input registers:   x1 = sct (test page index mod 4)
2209 
2210    mme     lodimg
2211    ------  return good
2212    ------  return bad
2213 
2214    return registers: none */
2215 
2216 mme_typ (-18): if trace then call tolts_qttyio_$rs (10, "^a MME LODIMG @ ^p", ctime (), mmep);
2217       call return_plus (1);                                 /* return ic + 1 */
2218 
2219 /* ********* MME LODVFC ********* (load printer vertical format control (VFC) (GCOS only))
2220 
2221    input registers:   x1 = sct (test page index mod 4)
2222 
2223    mme     lodvfc
2224    ------  return good
2225    ------  return error
2226 
2227    return registers:   a-reg = error code on error */
2228 
2229 mme_typ (-19): if trace then call tolts_qttyio_$rs (10, "^a MME LODVFC @ ^p", ctime (), mmep);
2230       call return_plus (1);                                 /* return ic + 1 */
2231 
2232 /* ********* MME LPW. ********* ( return LPW tally residue )
2233 
2234    input registers:   x1 = ICC
2235 
2236    mme     lpw.
2237    ------  return
2238 
2239    return registers:   A-REG = LPW, .crmb1,1 */
2240 
2241 mme_typ (-52): if trace then call tolts_qttyio_$rs (10, "^a MME LPW. @ ^p", ctime (), mmep);
2242       if substr (spa.regs.x (1), 7, 1) then                 /* if new format */
2243          call get_px_tcx ("LPW.  ", substr (spa.regs.x (1), 8, 11)); /* get test page index */
2244       else call get_px_tcx ("LPW.  ", substr (spa.regs.x (1), 10, 9)); /* get test page index */
2245       ioi_wksp = pages (io_sel).workspace_ptr;              /* get ptr to proper workspace */
2246       spa.regs.a = tolts_workspace.lpw (1);                 /* copy lpw tally residue */
2247       call return_plus (1);
2248 
2249 
2250 /* ********* MME MASTER MODE ENTRY ********* */
2251 
2252 mme_typ (30):                                               /* not valid on Multics */
2253       call return_plus (1);
2254 
2255 
2256 
2257 %page;
2258 
2259 /* ********* MME MBXCMP ********* (Responder compare mailbox data)
2260 
2261    inputr registers:
2262 
2263    X1 = pointer to was data
2264    X2 = pointer to s/b data
2265    X5 = fpinfo pointer
2266    mme     mbxcmp
2267    error return
2268    good return
2269 
2270    return registers:
2271    A = bad data if not compare  */
2272 
2273 mme_typ (-90): if trace then call tolts_qttyio_$rs (10, "^a MME MBXCMP @ ^p", ctime (), mmep);
2274 
2275       tolts_fpinfo_ptr = addrel (execp, spa.regs.x (5));    /* get a ptr to the test page fpinfo table */
2276       do io_sel = 1 to hbound (pages, 1)                    /* get the io_info for this page */
2277        while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num);
2278       end;
2279       if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* io_info for this page not found */
2280       io_info_ptr = addr (pages (io_sel));
2281       tolts_rspd_wksp = io_info.tolts_rspd_wksp;
2282       lvl_idx = (bin (substr (spa.regs.x (1), 13, 3)));     /* get the level */
2283       ws_data_idx = (bin (substr (spa.regs.x (1), 16, 3))); /* was data index */
2284       sb_data_idx = (bin (substr (spa.regs.x (2), 16, 3))); /* s/b data index */
2285       if tolts_rspd_workspace.ima_level (lvl_idx).word (sb_data_idx) /* compare the data */
2286        ^= tolts_rspd_workspace.ima_level (lvl_idx).word (ws_data_idx) then do;
2287          spa.regs.a = tolts_rspd_workspace.ima_level (lvl_idx).word (ws_data_idx);
2288          call return_plus (1);                              /* take error return */
2289       end;
2290       else call return_plus (2);                            /* take good return */
2291 
2292 
2293 /* ********* MME MBXDAT ********* (mme to manipulate mailbox data)
2294 
2295    input registers:
2296    x1 = pointer to FPINFO table
2297    x2 = subcommand code
2298    1 = MBLC (get mbx location)       2 = INITMB (intialize mailbox data)
2299    3 = RDMBX (read mailbox)          6 = RDINT (read interrupt word)
2300    7 = RDINT0 (rd intrpt wrd & 0)   11 = STMBX (store mailbox word)
2301 
2302    mme    MBXDAT
2303    zero   error return       (mme call + 1)
2304    zero   timeout return       (mme call + 2)
2305    zero   retry return       (mme call + 3)
2306    zero   good return        (mme call + 4)
2307 
2308    return registers:
2309    A & Q = data requested.
2310 
2311    Data is also entered into FPINFO table.
2312 
2313    dcl 1 tolts_fpinfo aligned based (tolts_fpinfo_ptr),
2314    *      2 pcw_info,
2315    *         3 fnp_num fixed bin unaligned,
2316    *         3 chan fixed bin (6) unaligned,
2317    *         3 cmnd fixed bin (6) unaligned,
2318    *     2 fnpdcw,
2319    *         3 address fixed bin unaligned,
2320    *         3 word_count fixed bin unaligned,
2321    *     2 io_rq_cnt fixed bin (35),
2322    *     2 mbxloc fixed bin (35),
2323    *     2 spec_cnt fixed bin,
2324    *     2 term_cnt fixed bin,
2325    *     2 partrs fixed bin (35),
2326    *     2 timeout_time fixed bin (35),
2327    *     2 temp01,
2328    *       3 word1,
2329    *         4 upper bit (18),
2330    *         4 lower bit (18),
2331    *       3 word2,
2332    *         4 upper bit (18),
2333    *         4 lower bit (18),
2334    *     2 temp02,
2335    *       3 word1,
2336    *         4 upper bit (18),
2337    *         4 lower bit (18),
2338    *       3 word2,
2339    *         4 upper bit (18),
2340    *         4 lower bit (18),
2341    *     2 temp03,
2342    *       3 word1,
2343    *         4 upper bit (18),
2344    *         4 lower bit (18),
2345    *       3 word2,
2346    *         4 upper bit (18),
2347    *         4 lower bit (18),
2348    *     2 lvl3_flag bit (36),
2349    *     2 lvl7_flag bit (36),
2350    *     2 lvl3_cnt fixed bin (35),
2351    *     2 lvl7_cnt fixed bin (35),
2352    *     2 pprt_avail bit (35); */
2353 
2354 
2355 
2356 mme_typ (-65): if trace then call tolts_qttyio_$rs (10, "^a MME MBXDAT ^p, type - ^6.3b", ctime (), mmep, spa.regs.x (2));
2357 
2358       tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1));    /* get a ptr to the test page fpinfo table */
2359       do io_sel = 1 to hbound (pages, 1)                    /* get the io_info for this page */
2360        while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num);
2361       end;
2362       if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* io_info for this page not found */
2363       io_info_ptr = addr (pages (io_sel));
2364       io_info.fpinfo_ptr = tolts_fpinfo_ptr;
2365       goto sub_cmnd (bin (spa.regs.x (2)));
2366 
2367 
2368 sub_cmnd (1):
2369 
2370 
2371       call tolts_device_info_ (addr (io_info.test_req), io_sel, t_err);
2372       if t_err ^= 0 then call tolts_abort ("$c4");
2373 
2374 /* create an event call channel for tdio status events */
2375 
2376       if ^io_info.ev_ch_ass then do;                        /* we we havn't done this already */
2377          call tolts_init_$cr_event_chan (io_info.status_event,
2378           "1"b, tolts_io_int_, io_info_ptr, 2, error);
2379          if error ^= 0 then                                 /* if error creating event call chan */
2380             call tolts_abort ("$a9");
2381          io_info.ev_ch_ass = "1"b;                          /* set event chan assigned flag */
2382       end;
2383       call ioa_$rsnnl ("T&D is attaching for a ^[write^]^[read^] ^a",
2384        att_desc, mesg_len, (^rd_flag), (rd_flag), io_info.device_name);
2385       call rcp_$attach (io_info.rcp_name, addr (io_info.rcp_area (1)), io_info.status_event,
2386        att_desc, io_info.rcp_id, error);
2387 
2388       if error ^= 0 then do;
2389          call output_status_code (error, "rcp attach error");
2390          call dealcp_sub;                                   /* go release status event */
2391          call tolts_abort ("$c5");
2392       end;
2393 
2394       call rcp_$check_attach (io_info.rcp_id, addr (io_info.rcp_area (1)), coment, io_info.device_index,
2395        tolts_info.max_wks_sz, tolts_info.max_to, io_info.rcp_state, io_info.attach_err);
2396       if io_info.attach_err ^= 0
2397        | io_info.rcp_state ^= 0 then do;
2398          if io_info.attach_err ^= 0 then
2399             call output_status_code (io_info.attach_err, "workspace assign error");
2400          call dealcp_sub;
2401          call tolts_abort ("$c6");
2402       end;
2403       io_info.p_att = "1"b;
2404       io_info.tolts_rspd_wksp = addr (tolts_rspd_workspace);
2405       call ioi_$workspace (io_info.device_index, io_info.tolts_rspd_wksp, tolts_info.wks_sz, error);
2406       if error ^= 0 then do;
2407          call output_status_code (error, "workspace assign error");
2408          call dealcp_sub;                                   /* go release status event */
2409          call tolts_abort ("$c6");
2410       end;
2411       io_info.cur_wks_sz = tolts_info.wks_sz;               /* set current value of workspace size */
2412       call ioi_$set_status (io_info.device_index, fixed (rel (addr (tolts_rspd_workspace.mailbox.status_word)), 18), 1, error);
2413 
2414       tolts_fpinfo.mbxloc = 0;
2415       spa.regs.q = "0"b;
2416       tolts_fpinfo.partrs = -1;
2417 
2418       call return_plus (4);
2419 
2420 
2421 sub_cmnd (2):
2422 
2423       tolts_rspd_wksp = io_info.tolts_rspd_wksp;
2424       unspec (tolts_rspd_workspace.num_int) = "0"b;
2425 
2426       call return_plus (4);
2427 
2428 
2429 sub_cmnd (3):
2430 
2431       tolts_rspd_wksp = io_info.tolts_rspd_wksp;
2432       spa.regs.a = unspec (tolts_rspd_workspace.mailbox.pcw);
2433 
2434       call return_plus (4);
2435 
2436 sub_cmnd (6):
2437 
2438       tolts_rspd_wksp = io_info.tolts_rspd_wksp;
2439       unspec (tolts_fpinfo.temp03.word1) = unspec (tolts_rspd_workspace.mailbox.num_int);
2440 
2441       call return_plus (4);
2442 
2443 sub_cmnd (7):
2444 
2445       tolts_rspd_wksp = io_info.tolts_rspd_wksp;
2446       unspec (tolts_fpinfo.temp03.word2) = unspec (tolts_rspd_workspace.mailbox.num_int);
2447       unspec (tolts_rspd_workspace.mailbox.num_int) = "0"b;
2448 
2449       call return_plus (4);
2450 
2451 sub_cmnd (11):
2452 
2453       tolts_rspd_wksp = io_info.tolts_rspd_wksp;
2454       k = bin (substr (tolts_fpinfo.temp03.word1.upper, 13, 3));
2455       unspec (tolts_rspd_workspace.ima_level (k)) = "0"b;
2456       do i = 1 to bin (tolts_fpinfo.temp02.word1.upper);
2457          ima_level (k).word (i) = spa.regs.a;
2458       end;
2459 
2460       call return_plus (4);
2461 
2462 %page;
2463 
2464 
2465 /* ********* MME PACMAN ********* (allocate IPC's for mcad test )
2466 
2467    input registers:                         Channel List format:
2468    x1 = sct (test page index mod 4)         vfd 9/base chnl,9/# of chnls,16/flags
2469    x2 = address of channel list             .
2470    x5 = address of mca config               .
2471    A  =  0 then attach channels             oct -1 end of list flag
2472    A ^= 0 then return channels
2473    Q  = ICC
2474    mme    pacman
2475    zero   error return        x2 = reason code                (mme call + 1)
2476    zero   error return        no chnls requested configured   (mme call + 2)
2477    zero   retry return        I/O in progress, retry          (mme call + 3)
2478    zero   good return         requested chnls assigned        (mme call + 4)
2479 
2480    return registers:
2481    X2 = error code on error (see set_sctwrk subroutine for error codes)
2482    *                          output in sctwrk (12 words): see the set_sctwrk subroutine */
2483 
2484 dcl  1 chan_list aligned based (clp),
2485          (2 base_chan fixed bin (9) uns,
2486        2 num_chans fixed bin (9) uns,
2487        2 flags,
2488          3 reboot bit (1),
2489          3 pad bit (17)) unaligned;
2490 dcl  clp ptr;
2491 dcl  p99 pic "99" based;
2492 
2493 
2494 mme_typ (-87): if trace then call tolts_qttyio_$rs (10, "^a MME PACMAN @ ^p", ctime (), mmep);
2495 
2496       if substr (spa.regs.q, 7, 1) then                     /* if new format */
2497          call get_px_tcx ("PACMAN", substr (spa.regs.q, 8, 11)); /* get test page index */
2498       else call get_px_tcx ("PACMAN", substr (spa.regs.q, 10, 9)); /* get test page index */
2499       clp = addrel (execp, fixed (spa.regs.x (2)));
2500       if spa.regs.a = "0"b then do;
2501          if io_info.ipc_attached then do;
2502             call mca_$detach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx, "0"b, code);
2503             call tolts_qttyio_$rs (0, "^a ipc was still attached will detach leaving the device suspended", io_info.ipc_id);
2504          end;
2505          io_info.ipc_id = substr (io_info.device_name, 4, 1) || convert (p99, (chan_list.base_chan));
2506          call mca_$attach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx, io_info.ipc_number, code);
2507          if code ^= 0 then do;
2508             if code = error_table_$resource_unavailable then do; /* must have been busy */
2509                spa.regs.x (2) = bit (dev_busy);             /* set appropriate error code */
2510                call tolts_qttyio_$rs (0, "^a ipc ^a busy", io_info.test_hdr, io_info.ipc_id);
2511                call return_plus (1);                        /* return ic + 7 */
2512             end;
2513             else do;
2514                call output_status_code (code, "ipc attach error");
2515                spa.regs.x (2) = bit (os_deny);              /* set appropriate error code */
2516                call return_plus (1);                        /* take error return */
2517             end;
2518          end;
2519          io_info.ipc_attached = "1"b;
2520       end;
2521       else if io_info.ipc_attached then do;
2522          call mca_$detach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx,
2523           chan_list.flags.reboot, code);
2524          if code ^= 0 then call tolts_abort ("$p2");
2525          else io_info.ipc_attached = "0"b;
2526       end;
2527       call return_plus (4);
2528 
2529 
2530 %page;
2531 /* *************************************************************************************************************
2532    *   MTAR has to know what operating system it is running on. This code passes the Multics code to cmlt
2533    *   which passes it to mtar at initialize time.   *
2534    ************************************************************************************************************** */
2535 
2536 /*    ********* MME POINIT ********* (slave executive initialize)
2537 
2538    input/output registers: none
2539 
2540    mme    poinit
2541    zero   wwflag,o.s. code    from .crfig (upper) Multics o.s. code (lower)
2542    zero   lstloc,0  core size available as loaded
2543    zero   tewrk,0   from .crctb
2544    zero   .tdioc,0  from .crioc
2545    zero   wradd,0   wrapup address
2546    zero   cvttbl,0  conversion table ptr
2547    zero   mmexec,0  position of ttl date in message
2548    zero   mintr,0   min/max memory test ranges (2 words)
2549    zero   crafc0,0  .cracf bit 3 & mpc entry if single disk & disk acf for pri and alt files (3 words )
2550    ----   return    return is mme call + 10
2551 
2552    .crfig:
2553 
2554    0 = series 60 0r 6000      6 = system sckd. save opt.              24-30 = reserved for gcos
2555    1 = class. module present  7 = reserved for gcos                   31 = not in mem avail. space tab
2556    2 = shared memory system   8,9,10,11 = ioms 0-3 configured         32 = RLP300 present
2557    3 = >256k                  12,13,14,15 = CPUs 0-3 configured       33 = DN30
2558    4 = IOM system             16-19 = reserved for gcos               34 = DN305
2559    5 = series 60 system       20,21,22,23 = CPU has EIS               35 = DN   355/6600
2560 
2561    .crctb ->    chars specify the first six tabs beyond position 0
2562    .crioc ->    -1 = IOMs */
2563 
2564 mme_typ (-20): if trace then call tolts_qttyio_$rs (10, "^a MME POINIT @ ^p", ctime (), mmep);
2565       exec_wd (mme_call_hf (1).upper) = "0"b;               /*        zeros says not ww system */
2566       if mme_call_hf (1).lower ^= 0 then
2567          exec_wd (mme_call_hf (1).lower) = "000000000002"b3;/* store Multics code if pointer */
2568       exec_wd (mme_call_hf (3).upper) = "122436506274"b3;   /*        tabs at 10,20,30,40,50,60  */
2569       iom_cardp = null;
2570       term = "0"b;                                          /* reset terminate condition */
2571       do while (^term);                                     /* find all iom cards */
2572          call tolts_util_$find_card ("iom ", iom_cardp);    /* find iom card */
2573          if iom_cardp = null then term = "1"b;              /* completed search of the deck */
2574          else do;
2575             if iom_card.model = "imu " then imu_found = "1"b;
2576             else if iom_card.model = "iom" then iom_found = "1"b;
2577          end;
2578       end;
2579 
2580       if imu_found then                                     /* imu system  */
2581          exec_wd (mme_call_hf (4).upper) = "777777000000"b3;
2582       else if iom_found then                                /* iom system */
2583          exec_wd (mme_call_hf (4).upper) = "777777777777"b3;
2584       else exec_wd (mme_call_hf (4).upper) = "0"b3;         /* let the usbexec complain */
2585 
2586       spa.wrapup_add = mme_call_hw (5).upper;               /* set wrapup address */
2587       call tolts_alm_util_$ascii_to_bcd_ (ttl_date, bcd_callname); /* convert ttl date to bcd */
2588       exec_wd (mme_call_hf (7).upper) = bcd_callname;       /* and store in message */
2589       substr (exec_wd (mme_call_hf (7).upper - 1), 19, 18) = "622017"b3; /* change version? ?? to version?s ? */
2590       genp = addrel (execp, mme_call_hf (2).upper);         /* get ptr to lstloc */
2591       if exec = "molt" then do;
2592          if fix_wd (1) ^= 0 then                            /* if lstloc specified... */
2593             mem_now, fix_wd (1) = fix_wd (1) + 196608;      /* add 196k to lstloc */
2594          else mem_now, fix_wd (1) = fixed (gload_data.text_len) + 196608; /* otherwise use loaded length */
2595       end;
2596       else do;
2597          if fix_wd (1) ^= 0 then                            /* if lstloc specified... */
2598             mem_now, fix_wd (1) = fix_wd (1) + 32768;       /* add 32k to lstloc */
2599          else mem_now, fix_wd (1) = fixed (gload_data.text_len) + 32768; /* otherwise use loaded length */
2600       end;
2601       call cpu_time_and_paging_ (i, cpu_time, j);           /* get current cpu time */
2602       tolts_info.init_time = cpu_time;                      /* save  */
2603       call return_plus (10);                                /* return ic + 10 */
2604 %page;
2605 /* ********* MME PROCTM ********* (return CPU time used since exec init)
2606 
2607    input registers: none
2608 
2609    mme     proctm
2610    ------  return
2611 
2612    return registers:   a-reg = processor time in 1/64 ms */
2613 
2614 mme_typ (-21): if trace then call tolts_qttyio_$rs (10, "^a MME PROCTM @ ^p", ctime (), mmep);
2615       call cpu_time_and_paging_ (i, cpu_time, j);           /* get current cpu time */
2616       cpu_time = cpu_time - tolts_info.init_time;           /* compute delta */
2617       spa.regs.a = bit (bin (divide (cpu_time * 64, 1000, 71, 0), 36)); /* return time */
2618       call return_plus (1);
2619 
2620 /* ********* MME PRTRAN ********* (load print train image for test)
2621 
2622    input registers:   x1 = sct (test page index mod 4)
2623 
2624    mme     prtran
2625    zero    loc,0 pointer to buffer for train image
2626    ------  return error
2627    ------  return good
2628 
2629    return registers: AR contains error code if error */
2630 
2631 mme_typ (-22): if trace then call tolts_qttyio_$rs (10, "^a MME PRTRAN @ ^p", ctime (), mmep);
2632       call get_px_sct ("PRTRAN", bin (spa.regs.x (1), 17), "1"b); /* get test page index */
2633       do i = 1 to printer_images_$n_images while (io_info.devsct.ptrain ^= printer_images_$image_numbers (i));
2634       end;
2635       if i > printer_images_$n_images then do;
2636          call tolts_qttyio_$rs (0, "^as: MME PRTRAN; No such train number - ^d",
2637           exec, io_info.devsct.ptrain);
2638          call tolts_abort ("$b1");
2639       end;
2640       tp = addrel (addr (printer_images_$image_base), printer_images_$image_offsets (i));
2641       train_ptr = addrel (execp, mme_call_hf (1).upper);
2642       train_ptr -> prt_image = tp -> prt_image;
2643       call return_plus (3);                                 /* return ic + 3 */
2644 %page;
2645 /* ********* MME READIO ********* (read options)
2646 
2647    input registers:    x1 = 3/exec #,9/0,6/cid
2648    *                   x4 -> (see opt_temp structure declaration below)
2649 
2650    mme     readio
2651    ------  return if tolts aborted
2652    ------  return if tolts swapped
2653    ------  return good
2654 
2655    return registers: none */
2656 
2657 dcl  1 opt_temp based (genp) aligned,                       /* template for MME READIO */
2658        (2 bcd_o_dash bit (18),                              /* = bcd " o-" */
2659        2 tdpcn_add fixed bin,                               /* address of .tdpcn */
2660        2 bufnum fixed bin,                                  /* tadio buffer (array element) number */
2661        2 nu1 bit (6),
2662        2 exec_num bit (6),
2663        2 nu2 bit (6),
2664        2 opt_ptr fixed bin,                                 /* ptr to options storage area */
2665        2 nu3 bit (6),
2666        2 phy_term bit (12)) unaligned;                      /* physical terminal id */
2667 
2668 dcl  bcd_options bit (6 * 84) based (genp);                 /* to move options to test page */
2669 
2670 mme_typ (-24): if trace then call tolts_qttyio_$rs (10, "^a MME READIO @ ^p", ctime (), mmep);
2671       genp = addrel (execp, spa.regs.x (4));                /* get ptr to options template */
2672       i = opt_temp.bufnum;                                  /* get tadio buffer number */
2673       tolts_info.tadio (i).inuse = "0"b;                    /* reset  buffer in use flag */
2674       genp = addrel (execp, opt_temp.opt_ptr);              /* get ptr to store options */
2675       bcd_options = tolts_info.tadio (i).option;            /* move options to test page */
2676       call return_plus (3);                                 /* return ic + 3 */
2677 %page;
2678 /* ********* MME RELEAS ********* ( release device (reboot mpc firmware if running ITRs))
2679 
2680    input registers:
2681 
2682    *      POLT                          MOLT
2683    X0     ----                          Master console file code
2684    X1     SCT (test page index * 4)     SCT (test page index * 4)
2685    X2     Patptr                        ----
2686    X4     ----                          Patptr
2687    X6     ----                          possible hang flag
2688    X7     0                             Molt test type (In upper 6 bits: C = itrs, R = MDRs, T = MTAR, M = memory)
2689    AR     ----                          type code (tdcxxa)
2690    QR     ----                          ICC (XICCXXXX)
2691 
2692    mme     releas
2693    ------  return if error
2694    ------  return
2695 
2696    return registers: none */
2697 
2698 mme_typ (-56): if trace then call tolts_qttyio_$rs (10, "^a MME RELEAS @ ^p", ctime (), mmep);
2699       if spa.regs.x (7) ^= "0"b then                        /* if not polts */
2700          if substr (spa.regs.x (7), 1, 6) = "23"b3 then do; /* molts, running itrs */
2701             call get_px_sct ("RELEAS", bin (spa.regs.x (1), 17), "1"b); /* get test page index */
2702             if io_info.chan_suspended then do;              /* only load firmware if channel suspended */
2703                call tolts_load_firmware_ (io_sel, error);   /* go load mpc firmware */
2704                if error ^= 0 then                           /* if error loading firmware */
2705                   call ck_release;                          /* try again, and then ask user */
2706             end;
2707          end;
2708       call return_plus (2);
2709 
2710 /* ********* MME RLSMPC ********* (release mpc)
2711 
2712    input registers:   x1 = mpc controller sct pointer
2713 
2714    mme     rlsmpc
2715    ------  return
2716 
2717    return registers: none */
2718 
2719 mme_typ (-26): if trace then call tolts_qttyio_$rs (10, "^a MME RLSMPC @ ^p", ctime (), mmep);
2720       call return_plus (1);
2721 
2722 /* ********* MME RLSPAT ********* (release peripheral allocation table entry)
2723 
2724    input registers:   x4 = pat address (offset relative to LAL)
2725 
2726    mme     rlspat
2727    ------  return
2728 
2729    return registers: none */
2730 
2731 mme_typ (-28): if trace then call tolts_qttyio_$rs (10, "^a MME RLSPAT @ ^p", ctime (), mmep);
2732       call return_plus (1);
2733 %page;
2734 
2735 /* ********* MME RSPCHK ********* (check for fnp response)
2736 
2737    input registers:   x1 = fpinfo table pointer
2738 
2739    mme     rspchk
2740    ----    error return
2741    ----    timeout return
2742    ----    retry return
2743    ----    good return
2744 
2745    return registers:  q = status word if fault occurs */
2746 
2747 mme_typ (-91): if trace then call tolts_qttyio_$rs (10, "^a MME RSPCHK @ ^p", ctime (), mmep);
2748 
2749       tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1));    /* get a ptr to the test page fpinfo table */
2750       do io_sel = 1 to hbound (pages, 1)                    /* get the io_info for this page */
2751        while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num);
2752       end;
2753       if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* io_info for this page not found */
2754       io_info_ptr = addr (pages (io_sel));
2755       tolts_rspd_wksp = io_info.tolts_rspd_wksp;
2756       call tolts_init_$gc_tod (gcos_tod);
2757       if tolts_rspd_workspace.mailbox.status_word ^= "0"b then do; /* error status stored */
2758          if tolts_fpinfo.io_rq_cnt > 0 then                 /* if io request cnt > 0 */
2759             tolts_fpinfo.io_rq_cnt = tolts_fpinfo.io_rq_cnt - 1;
2760          if substr (tolts_rspd_workspace.status_word, 4, 1) = "1"b /* if timeout */
2761           | bin (tolts_fpinfo.timeout_time) - bin (gcos_tod) < 1 then
2762             call return_plus (2);                           /* take timeout return */
2763          else do;                                           /* else take normal error return */
2764             spa.regs.q = tolts_rspd_workspace.status_word;  /* return the status */
2765             call return_plus (1);                           /* take error return */
2766          end;
2767       end;
2768       else do;                                              /* no error */
2769          tolts_fpinfo.spec_cnt =
2770           tolts_rspd_workspace.mailbox.num_int.lvl7;        /* move spec count */
2771          tolts_fpinfo.term_cnt =
2772           tolts_rspd_workspace.mailbox.num_int.lvl3;        /* move term count */
2773          tolts_fpinfo.lvl3_cnt =                            /* decr levl 3 count with saved value */
2774           tolts_fpinfo.term_cnt - bin (unspec (tolts_fpinfo.temp01.word2));
2775          tolts_fpinfo.lvl7_cnt =                            /* decr levl 7 count with saved value */
2776           tolts_fpinfo.spec_cnt - bin (unspec (tolts_fpinfo.temp01.word1));
2777          if (tolts_fpinfo.lvl3_cnt = 0 & tolts_fpinfo.lvl3_flag) /* if no term int & one expected */
2778           | (tolts_fpinfo.lvl7_cnt = 0 & tolts_fpinfo.lvl7_flag) /* or no spec int & one ecpected */
2779           & (bin (tolts_fpinfo.timeout_time) < 0) then      /* & no timeout */
2780             call return_plus (3);                           /* take retry return */
2781          else do;
2782             if tolts_fpinfo.io_rq_cnt > 0 then
2783                tolts_fpinfo.io_rq_cnt = tolts_fpinfo.io_rq_cnt - 1;
2784             if (tolts_fpinfo.lvl3_cnt = 1 | ^tolts_fpinfo.lvl3_flag)
2785              & (tolts_fpinfo.lvl7_cnt = 1 | ^tolts_fpinfo.lvl7_flag) then
2786                call return_plus (4);                        /* take good return */
2787          end;
2788       end;
2789 
2790 %page;
2791 /* ********* MME SCTCMP********* (generate SCT entry)
2792 
2793    input registers: X2 = 128 chan number for new format
2794 
2795    mme     sctcmp
2796    zero    ficcdd,0
2797    zero    sctwrk,0
2798    ------  return good--shared file
2799    ------  return good--non-shared file
2800    ------  return error
2801 
2802    return registers:          X2 = error code if error (see set_sctwrk subroutine for error codes)
2803    *                          output in sctwrk area: see set_sctwrk subroutine */
2804 
2805 mme_typ (-29): if trace then call tolts_qttyio_$rs (10, "^a MME SCTCMP @ ^p", ctime (), mmep);
2806       do i = 1 to 8 while (pages (i).in_use);               /* find vacant page */
2807       end;
2808       if i = 8 & pages (8).in_use then do;                  /* no vacant page */
2809          call tolts_qttyio_$rs (0, "^a: MME SCTCMP; No vacant test page slot found", exec);
2810          call tolts_abort ("$a1");
2811       end;
2812       unspec (pages (i)) = "0"b;                            /* clear test page data */
2813       call set_sctwrk (i);                                  /* go set up the sct work area */
2814       if spa.regs.x (2) ^= "0"b then do;                    /* if error */
2815          if fixed (spa.regs.x (2)) = m_iv_iom then          /* if invalid IOM number... */
2816             spa.regs.x (2) = "0"b;                          /* correct it */
2817          call return_plus (5);                              /* take error return */
2818       end;
2819       pages (i).in_use = "1"b;                              /* set page in use flag */
2820       tolts_info.exec_page_count = tolts_info.exec_page_count + 1; /* increment total test page count */
2821       if pages (i).io_type = polt_io_type then              /* if user wants to run itrs... */
2822          itr_run = "1"b;                                    /* set flag for wake_disp subroutine */
2823       call return_plus (4);                                 /* take good return */
2824 %page;
2825 /* ********* MME SETPRT & MME SETPR2 ********* (reserve printer (attach print file in Multics's case ))
2826 
2827    input/return registers: none
2828 
2829    mme     setprt
2830    ------  return tolts aborted
2831    ------  return tolts swapped
2832    ------  no prt available
2833    ------  return pr2 in use
2834    ------  return good */
2835 
2836 mme_typ (-30):
2837 mme_typ (-31): if trace then call tolts_qttyio_$rs (10, "^a MME SET^[PRT^;PR2^] @ ^p", ctime (), (mme_number = -33), mmep);
2838       if ^tolts_info.file_attach then do;                   /* if print file not already attached... */
2839          call tolts_file_util_$open (error);                /* attach and open it */
2840          if error = 0 then                                  /* if no attach error */
2841             call return_plus (5);                           /* return good */
2842       end;
2843       call return_plus (3);                                 /* return ic + 3 */
2844 
2845 /* ********* MME SETPUN ********* (set reader/punch to punch mode)
2846 
2847    input registers:   x1 = sct (test page index mod 4)
2848 
2849    mme     setpun
2850    ------  return, no operator message
2851    ------  return, Output Operator message to put reader/punch in punch mode
2852 
2853    return registers: X1 = sct address
2854 
2855    Issued for 214 reader/punch to set in punch mode before mme allocr to set punch indicator in sct */
2856 
2857 mme_typ (-32): if trace then call tolts_qttyio_$rs (10, "^a MME SETPUN @ ^p", ctime (), mmep);
2858       call get_px_sct ("SETPUN", bin (spa.regs.x (1), 17), "0"b); /* get test page index */
2859       io_info.ccu_pun = "1"b;                               /* remember we want a punch */
2860       call return_plus (1);
2861 
2862 /* ********* MME SETTYP & MME DISPRT ********* (reset prt or pr2 request)
2863 
2864    input/return registers: none
2865 
2866    mme     settyp
2867    ------  return tolts aborted
2868    ------  return tolts swapped
2869    ------  return good */
2870 
2871 mme_typ (-11):
2872 mme_typ (-33): if trace then call tolts_qttyio_$rs (10, "^a MME ^[SETTYP^;DISPRT^] @ ^p", ctime (), (mme_number = -33), mmep);
2873       if tolts_info.file_attach then                        /* if print file attached... */
2874          call tolts_file_util_$close;                       /*  close it out */
2875       call return_plus (3);                                 /* return ic + 3 */
2876 %page;
2877 /* ********* MME TADIOD ********* (T&D terminal I/O)
2878 
2879    input registers: a-reg = 18/.tdpcn,6/pad,1/nu,1/dont record denial,1/mbz,3/exec,6/lid
2880 
2881    mme     tadio
2882    zero    nodcws,0
2883    zero    iotpd,wc   from 1 to 5 of these exist
2884    ------  return if tolts aborted
2885    ------  return if tolts swapped
2886    ------  return if request denied
2887    ------  return accepted
2888 
2889    return registers: none
2890 
2891    tadio type:                bit 23 "p" 1     print line   bit 22 "c" 2    controlling terminal
2892    *                          bit 21 "s" 4     slave term.  bit 20 "m" 8    master console output
2893    *                          bit 19 "r" 16    output/input bit 18 "e" 32   select console/printer by option
2894    all valid combinations:    ps  - 5   sp  - 5   cs  - 6   sc  - 6   mp  - 9   pm  - 9   cm  - 10
2895    *                          mc  - 10  ms  - 12  sm  - 12  mps - 13  msp - 13  pms - 13  psm - 13
2896    *                          smp - 13  spm - 13  cms - 14  csm - 14  mcs - 14  msc - 14
2897    *                          scm - 14  smc - 14  ep  - 33  pe  - 33  em  - 40  me  - 40     */
2898 
2899 mme_typ (-34): if trace then call tolts_qttyio_$rs (10, "^a MME TADIOD @ ^p", ctime (), mmep);
2900       ndcws = mme_call_hf (1).upper;                        /* extract number of dcws */
2901       if ndcws < 1 | ndcws > 5 then do;
2902          call tolts_qttyio_$rs (0, "^as: MME TADIOD; Number of dcws = ^d", exec, ndcws);
2903          call tolts_abort ("$b2");
2904       end;
2905       do i = 1 to 8 while (tolts_info.tadio (i).inuse);     /* find vacant tadio queue entry */
2906       end;
2907       if i = 8 & tolts_info.tadio (8).inuse then do;        /* no queue entry */
2908          call tolts_qttyio_$rs (0, "^as: MME TADIOD; No vacant queue entry", exec);
2909          call tolts_abort ("$b2");
2910       end;
2911       tolts_info.tadio (i).inuse = "1"b;                    /* fill in the queue entry */
2912       tolts_info.tadio (i).return_word (3) = "000000006361"b3; /* phy term sb 24-35 */
2913       tolts_info.tadio (i).return_word (2) = bit (bin (i, 18)) || "000000"b3;
2914       if substr (mme_call_w (2), 20, 1) = "1"b then do;     /* if read involved */
2915          tolts_info.tadio (i).optrd = "1"b;
2916          tolts_info.tadio (i).return_word (1) = "204652"b3 || substr (spa.regs.a, 1, 18); /* " o-||.tdpcn */
2917          pad_char = substr (spa.regs.a, 19, 6);             /* pick up pad character */
2918          do j = 0 to 83;                                    /*  pad options buffer */
2919             substr (tolts_info.tadio (i).option, (j * 6) + 1, 6) = pad_char;
2920          end;
2921       end;
2922       else do;
2923          tolts_info.tadio (i).optrd = "0"b;
2924          tolts_info.tadio (i).return_word (1) = "206252"b3 || substr (spa.regs.a, 1, 18); /* " s-||.tdpcn */
2925       end;
2926       call tolts_qttyio_$dcw_ptr (addrel (mmep, 2), ndcws, i); /* go queue up message */
2927       spa.enter.icivlu.ic = rel (addr (mme_call_w (5 + ndcws))); /* return ic +5 + number of dcws */
2928       call wake_disp;                                       /* go wake up dispatcher */
2929 %page;
2930 /* ********* MME TDIO ********* (issue I/O to device under test)
2931 
2932    input registers: none
2933 
2934    mme     tdio                         eep commands:       3100007x4000 = diagnostic mode control
2935    zero    myioq,0                                          2200007x4000 = read controller main memory
2936    zero    tpbase,0                                         0600007x4000 = initiate read data transfer
2937    zero    datara,redfol-wrtpre+1  ( = 0 if molts)          where x = 0 if last and 2 if continue idcw
2938    zero    iotrac,0
2939    ------  return
2940 
2941    return registers: AR = Time of day of connect, QR = lostit time, X4 = test page index */
2942 
2943 mme_typ (-36): ioe_ptr = addrel (execp, mme_call_hf (1).upper); /* get ptr to our io_entry */
2944       if trace then do;
2945          call tolts_qttyio_$rs (10, "^a MME TDIO @ ^p", ctime (), mmep);
2946          call ioa_$rsnnl ("^/io_entry:^-^4(^12.3b ^)^/^-^4(^12.3b ^)^/^-^3(^12.3b ^)",
2947           message, mesg_len, ioe, ioe (5), ioe (9));
2948          call tolts_qttyio_ (message, 10);
2949       end;
2950       if trace_io then do;                                  /* count number of mme tdio's if -tio option true */
2951          call tolts_qttyio_$rs (10, "^a MME TDIO @ ^p", ctime (), mmep);
2952          call ioa_$rsnnl ("^/io_entry:^-^4(^12.3b ^)^/^-^4(^12.3b ^)^/^-^3(^12.3b ^)",
2953           message, mesg_len, ioe, ioe (5), ioe (9));
2954          call tolts_qttyio_ (message, 10);
2955          tio = tio + 1;
2956          call tolts_qttyio_$rs (10, " MME TDIO =  ^b @ ^a", tio, ctime ()); /* notify user of tally of tdio's */
2957       end;
2958       call get_px_sct ("TDIO  ", bin (io_entry.sct_add, 17), "1"b); /* get test page index */
2959       if io_info.io_type = mca_io_type then call mca_io_setup; /* mca is special */
2960       else call io_setup;                                   /* go set up our workspace */
2961       if io_info.suspend_chan then do;                      /* if channel to be suspended */
2962          call ioi_$suspend_devices (io_info.device_index, error); /* let ioi_$ stop other io */
2963          if error ^= 0 then do;                             /* error, abort */
2964             call output_status_code (error, "suspend devices error");
2965             call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
2966              string (io_info.icivlu));                      /* enter ccc request */
2967             io_info.suspend_chan = "0"b;
2968             io_info.io_in_progress = "0"b;                  /* reset io in progress flag */
2969             if tolts_info.gewake_active then do;            /* if gewake alarm set */
2970                call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* reset it */
2971                call ipc_$drain_chn (tolts_info.gewake_event, error); /* make sure no alarms queue up */
2972                tolts_info.gewake_active = "0"b;             /* reset flag */
2973             end;
2974 
2975             call tolts_abort ("$b5");
2976          end;
2977          io_info.chan_suspended = "1"b;                     /* remember that channel suspended */
2978       end;
2979       if io_info.io_type = mca_io_type then do;
2980          if io_entry.prim.dev_cmd = "40"b3 then             /* if reset dcw */
2981             call mca_$reset (io_info.mca_ioi_idx, "0"b, error);
2982          else if io_entry.prim.dev_cmd = "15"b3 then        /* send mca data */
2983             call mca_$tandd_write_data (io_info.mca_ioi_idx,
2984              io_info.workspace_ptr, io_block_len, "0"b, error);
2985          else if io_entry.prim.dev_cmd = "13"b3 then        /* send mca command */
2986             call mca_$tandd_write_text (io_info.mca_ioi_idx,
2987              io_info.workspace_ptr, io_block_len, "0"b, error);
2988          else if io_entry.prim.dev_cmd = "03"b3 then        /* every write must be followed by a read */
2989             call mca_$tandd_read_data (io_info.mca_ioi_idx,
2990              io_info.workspace_ptr, io_block_len, "0"b, error);
2991          else error = error_table_$bad_command_name;
2992       end;
2993       else call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error);
2994       if error ^= 0 then do;
2995          call output_status_code (error, "doing io for a tdio");
2996          call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue),
2997           string (io_info.icivlu));                         /* enter ccc request */
2998          io_info.io_in_progress = "0"b;                     /* reset io in progress flag */
2999          if tolts_info.gewake_active then do;               /* if gewake alarm set */
3000             call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* reset it */
3001             call ipc_$drain_chn (tolts_info.gewake_event, error); /* make sure no alarms queue up */
3002             tolts_info.gewake_active = "0"b;                /* reset flag */
3003          end;
3004 
3005          call tolts_abort ("$b5");
3006       end;
3007       call tolts_init_$gc_tod (spa.regs.a);                 /* get current time of day */
3008       io_info.con_time = bin (spa.regs.a, 35);              /* save connect time */
3009       spa.regs.q = bit (bin (io_info.lostit_time, 36));     /* set lostit time */
3010       spa.regs.x (4) = bit (bin (io_sel * 4, 18));          /* return test page index, mod 4 */
3011       tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1;/* increment global IO count */
3012       call return_plus (5);                                 /* return ic + 5 */
3013 %page;
3014 /* ********* MME TERMIN ********* (terminate slave executive)
3015 
3016    input registers: none
3017 
3018    mme     termin
3019    does not return */
3020 
3021 mme_typ (-35): if trace then call tolts_qttyio_$rs (10, "^a MME TERMIN @ ^p", ctime (), mmep);
3022       term = "1"b;                                          /* set terminate condition */
3023       go to term_lbl;                                       /* and perform nonlocal goto */
3024 
3025 /* ********* MME TNDBUG ********* (tolts debugger break point))
3026 
3027    input/return registers: none
3028 
3029    mme     tndbug
3030 
3031    restores mme word with original value and returns to mme location */
3032 
3033 mme_typ (-88):
3034       if ^debugging then call return_plus (1);
3035       call probe (mtdsim_);
3036       exec_wd (db_addr) = db_sv_wd;
3037       tolts_info.mult_ans = "";                             /* clear out response */
3038       call tolts_qttyio_$rs (19, "tolts_debugger: enter break point address");
3039       call message_wait;                                    /* wait for user response */
3040       if mult_ans ^= "" then do;
3041          db_addr = cv_oct_check_ ((rtrim (mult_ans)), code);
3042          db_sv_wd = exec_wd (db_addr);
3043          exec_wd (db_addr) = "777650001000"b3;
3044       end;
3045       call return_plus (0);                                 /* return ic + 0 */
3046 
3047 /* ********* MME TOLDIS ********* (disconnect logical terminal ID (LID))
3048 
3049    input/return registers: none
3050 
3051    mme     toldis
3052    ------  return tolts aborted
3053    ------  return tolts swapped
3054    ------  return */
3055 
3056 mme_typ (-37): if trace then call tolts_qttyio_$rs (10, "^a MME TOLDIS @ ^p", ctime (), mmep);
3057       call return_plus (3);                                 /* return ic + 3 */
3058 
3059 
3060 /* ********* MME TOLGON ********* (used in gecos to inform tolts is terminating)
3061    mme       tolgon
3062    -----   return   */
3063 
3064 mme_typ (-38): if trace then call tolts_qttyio_$rs (10, "^a MME TOLGON @ ^p", ctime (), mmep);
3065       call return_plus (1);
3066 
3067 
3068 /* ********* MME TOLTIN ********* (slave executive idle dispatcher)
3069 
3070    input registers:   q-reg = time in 1/64 ms for wakeup
3071 
3072    mme     toltin
3073    ------  return not in core
3074    ------  return in core   (does mme gewake if in core)
3075 
3076    return registers: none */
3077 
3078 mme_typ (-39): if trace then call tolts_qttyio_$rs (10, "^a MME TOLTIN @ ^p", ctime (), mmep);
3079 
3080       wake_time = divide (fixed (spa.regs.q) * 1000, 64, 71, 0); /* convert gcos time to useconds */
3081       call timer_manager_$alarm_wakeup (wake_time, "10"b, tolts_info.gewake_event); /* set the alarm  */
3082       tolts_info.gewake_active = "1"b;                      /* set flag for int processor */
3083       spa.enter.icivlu.ic = rel (addr (mme_call_w (2)));    /* increment ic by 2 */
3084       go to blk_lbl;                                        /* return to blocked state */
3085 %page;
3086 /* ********* MME TRACIO ********* (trace I/O events (GCOS only, Unused in Multics))
3087 
3088    input/output registers: none
3089 
3090    mme     tracio
3091    iotd    msg,wordcount
3092    ------  return */
3093 
3094 mme_typ (-40): if trace then call tolts_qttyio_$rs (10, "^a MME TRACIO @ ^p", ctime (), mmep);
3095       call return_plus (2);                                 /* return ic + 2 */
3096 
3097 /* ********* MME UNFREZ ********* (unwire  main memory (gcos only))
3098 
3099    input/return registers:   none
3100 
3101    mme     unfrez
3102    ------  return */
3103 
3104 mme_typ (-54): if trace then call tolts_qttyio_$rs (10, "^a MME UNFREZ @ ^p", ctime (), mmep);
3105       call return_plus (1);
3106 
3107 /* ********* MME WRDUMP ********* (wrapup dump)
3108 
3109    input registers: areg = iotd for dump prefix
3110    *                qreg = start,size (relative to LAL)
3111    *                x1 = address bias (-1024 or page base)
3112    *                x2 = master/slave (=3hm  ,=3hs  )
3113 
3114    mme     wrdump
3115    ------  return
3116 
3117    return registers: none */
3118 
3119 mme_typ (-42): if trace then call tolts_qttyio_$rs (10, "^a MME WRDUMP @ ^p", ctime (), mmep);
3120       if tolts_info.file_attach then do;                    /* if print file attached... */
3121          call tolts_file_util_$wdump (addr (spa.regs));     /* go output entire dump */
3122          call tolts_file_util_$close;
3123       end;
3124       else call tolts_qttyio_$rcw (addr (spa.regs.a));      /* otherwise just output dump prefix */
3125       call return_plus (1);                                 /* return ic + 1 */
3126 %page;
3127 mme_typ (-60): mme_typ (-58): mme_typ (-57):
3128 mme_typ (-49): mme_typ (-48): mme_typ (-47): mme_typ (-46): mme_typ (-45):
3129 mme_typ (-44): mme_typ (-43): mme_typ (-41): mme_typ (-27): mme_typ (-23): mme_typ (-10):
3130 mme_typ (-25): mme_typ (-15): mme_typ (-14):
3131 mme_typ (-3): mme_typ (0): mme_typ (3): mme_typ (4): mme_typ (6): mme_typ (7):
3132 mme_typ (8): mme_typ (10): mme_typ (11): mme_typ (12): mme_typ (13): mme_typ (16):
3133 mme_typ (19): mme_typ (20): mme_typ (22): mme_typ (23): mme_typ (25):
3134 mme_typ (26): mme_typ (27): mme_typ (28): mme_typ (29):
3135 undefm:
3136 
3137       in_ccc = "0"b;
3138       call tolts_qttyio_$rs (0, "^as: Improper MME @ ^p; MME type - ^d; Instruction - ^12.3b",
3139        exec, mmep, mme_call_hf (0).upper, mme_call_w (0));
3140       call tolts_abort ("$b6");
3141 
3142 /* epilogue - entry called by execute_epilogue_ when process is terminated */
3143 
3144 epilogue: entry;
3145 
3146       if tolts_active then do;                              /* continue only if we were active */
3147          tolts_info.finish_cond = "1"b;                     /* set finish flag */
3148          call hcs_$get_ips_mask (old_mask);                 /* get current ips mask */
3149          new_mask = old_mask | sys_info$alrm_mask;          /* make sure "alrm"s are enabled */
3150          call hcs_$set_ips_mask (new_mask, new_mask);       /* set the mask */
3151          call clean_up;                                     /* go cleanup our enviornment */
3152          call hcs_$set_ips_mask (old_mask, old_mask);       /* set original ips mask */
3153       end;
3154       return;
3155 %page;
3156 
3157 /* return_plus - int procedure to add specified value to ic, wakeup dispatcher and take non-local goto to block */
3158 
3159 return_plus: proc (ic_inc);
3160 
3161 dcl  ic_inc fixed bin;                                      /* value to increment ic by */
3162 
3163       spa.enter.icivlu.ic = rel (addr (mme_call_w (ic_inc))); /* increment ic */
3164 
3165 /* wake_disp - entry to do non-local goto to dispatcher. If there is any oustanding IO,
3166    the wait event channel is woken up and we do non-local goto to the dispatcher block label.
3167    If there is no outstanding IO (terminal or test IO), we do non-local goto  directly
3168    back to the no_blk label, thus saving needless wakeyps and blocks */
3169 
3170 wake_disp: entry;
3171 
3172       if (tolts_info.term_io_req_cnt = 0 & tolts_info.glob_int_cnt = 0 /* if there is nothing to wait for... */
3173        & ^tolts_info.exec_term_io_wait & ^colts_op_flags.colt_flag) then /* go back to slave exec, don't go blocked */
3174          go to no_blk;                                      /* do non-local goto */
3175 
3176       call hcs_$wakeup (tolts_info.process, tolts_info.wait_list.wait_event_id (1), null, error);
3177       if error ^= 0 then do;                                /* this is a fatal error, terminate our process */
3178          call com_err_ (error, exec, "***fatal error, terminating process"); /* but tell user first */
3179          fatal_desc.version = 0;
3180          fatal_desc.fatal_code = error;
3181          if ^debugging then
3182             call terminate_process_ ("fatal_error", addr (fatal_desc));
3183          else signal tolts_error_;
3184       end;                                                  /* no need to return, as we won't be back */
3185       go to blk_lbl;                                        /* take non-local goto to dispatcher block */
3186 
3187    end return_plus;
3188 
3189 
3190 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
3191 /*                                                                                                            */
3192 /* fault_dump - internal procedure to force open a file for tolts abort                                       */
3193 /*                                                                                                            */
3194 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
3195 
3196 fault_dump: proc;
3197       flt_flag = "1"b;
3198       if ^tolts_info.file_attach then
3199          call tolts_file_util_$open (error);
3200       if error ^= 0 then do;
3201          call com_err_ (error, exec, "encountered an error while attempting to open a point file for ^a", error);
3202          call tolts_abort ("$t1");
3203       end;
3204       if debugging then call probe (mtdsim_);
3205       if tolts_info.file_attach then do;
3206          call display_mc;
3207          call tolts_file_util_$wdump (execp);               /* go output entire dump */
3208          call tolts_file_util_$close;
3209 
3210          in_ccc = "0"b;
3211          call tolts_abort ("$t2");
3212       end;
3213    end fault_dump;
3214 
3215 
3216 
3217 /* tolts_abort - internal procedure to set up abort vectors for the slave exec */
3218 
3219 tolts_abort: proc (a_code);
3220 
3221 dcl  a_code char (3);
3222 dcl  tfc bit (18);
3223 
3224       call tolts_alm_util_$ascii_to_bcd_ (a_code, tfc);     /* convert fault code to bcd */
3225       spa.abort.code = tfc;                                 /* and store in spa */
3226       if scup = null then
3227          spa.abort.add = "0"b;                              /* don't have an address, got a non MME fault */
3228       else
3229          spa.abort.add = scu.ilc;                           /* equals address of last mme */
3230       if spa.wrapup_add = "0"b                              /* if we have not been thru mme pointit yet.. */
3231        | flt_flag then do;                                  /* or we have detected a fault */
3232          call clean_up;
3233          term = "1"b;                                       /* set terminate condition */
3234          go to term_lbl;                                    /* take non-local goto to get out of dispatcher */
3235       end;
3236       spa.enter.icivlu.ic = spa.wrapup_add;                 /* set wrapup address */
3237       call wake_disp;                                       /* and wake up dispatcher */
3238 
3239    end tolts_abort;
3240 
3241 /* display_mc - int proc to display machine conditions after a fault */
3242 
3243 display_mc: proc;
3244 
3245 dcl  cu_$stack_frame_ptr entry (ptr);
3246 dcl  dump_machine_cond_ entry (ptr, ptr, char (32) aligned, fixed bin);
3247 dcl  find_condition_frame_ entry (ptr) returns (ptr);
3248 dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
3249 dcl  hran_$hranl entry (ptr, ptr, bit (1));
3250 dcl  ioa_ entry () options (variable);
3251 dcl  ioa_$ioa_switch entry () options (variable);
3252 dcl  (faultsp, hreg_ptr, stackp) ptr;
3253 dcl  code fixed bin (35);
3254 
3255 
3256       call cu_$stack_frame_ptr (stackp);                    /* get current sstack ptr */
3257       faultsp = find_condition_frame_ (stackp);             /* is this the cond frame ? */
3258       if faultsp = null () then do;
3259          call ioa_ ("^a: Cannot find condition frame.", "exec_name");
3260          return;
3261       end;
3262 
3263       call find_condition_info_ (faultsp, addr (ci), code);
3264       if ci.mc_ptr = null () then do;
3265          call ioa_ ("^a: Cannot find condition frame.", "exec_name");
3266          return;
3267       end;
3268 
3269 
3270       call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/MACHINE CONDITIONS AT ^p:^/", ci.mc_ptr);
3271       call dump_machine_cond_ (addr (ci), faultsp, "err_file", 2); /* print the MC */
3272 
3273 HREGS:
3274       if mcptr ^= null then hreg_ptr = addrel (mcptr, 96);
3275       if hreg_ptr = null then do;                           /* no history regs to dump */
3276          call ioa_$ioa_switch (tolts_info.pf_iocbp, "History Registers are not available");
3277          return;
3278       end;
3279       else do;
3280          call ioa_$ioa_switch (tolts_info.pf_iocbp, "CPU HISTORY REGISTERS AT TIME OF FAULT");
3281          call hran_$hranl (hreg_ptr, tolts_info.pf_iocbp, "0"b);
3282       end;
3283 
3284       return;
3285    end display_mc;
3286 
3287 
3288 %page;
3289 
3290 /* set_sctwrk - internal procedure to set up the sct work area sctwrk */
3291 
3292 set_sctwrk: proc (px);
3293 
3294 dcl  px fixed bin;                                          /*  test page index */
3295 
3296 /*
3297    output in sctwrk (12 words):
3298 
3299    18/devsct,6/0,12/xbicc
3300    18/altsct,6/g3typ,12/0
3301    18/cntsct,4/iotyp,4/cnttyp,1/pad,4/xiotyp,4/xcnttyp,1/pad
3302    18/cont. sct,18/mpc index (36/0 for non mpc)
3303    36/word +0 of .crcst entry for mpc
3304    36/word +1 of .crcst entry for mpc
3305    36/word +2 of .crcst entry for mpc
3306    36/word +3 of .crcst entry for mpc
3307    36/word +0 of sct entry
3308    36/word +1 of sct entry
3309    36/word +0 of alt sct
3310    36/word +1 of alt sct
3311 */
3312       genp = addrel (execp, mme_call_hf (2).upper);         /* get pointer to sctwrk */
3313       spa.regs.x (2), sctwrk = "0"b;                        /* initialize sctwrk first */
3314       t_err = 0;
3315       call tolts_device_info_ (addrel (execp, mme_call_hf (1).upper), px, t_err); /* get type code */
3316       spa.regs.x (2) = bit (bin (t_err, 18));               /* set x2 to type_error if any */
3317       substr (sctwrk (2), 19, 6) = pages (px).devsct.type_code; /* set type code */
3318       if ^pages (px).devsct.com_prph then do;               /* if mpc subsystem */
3319          pages (px).sct_info.cntsct = bit (bin (px * 4 + 1024, 18)); /* set cont. sct (device sct + 1024) */
3320          sctwrk (3) = unspec (pages (px).sct_info);         /* fill word 3 of sct area */
3321          substr (sctwrk (4), 1, 18) = bit (bin (px * 4 + 1024, 18)); /* set cont. sct */
3322       end;
3323       sctwrk (5) = unspec (pages (px).crcst);               /* set crcst entry wrd 0 */
3324       sctwrk (6) = unspec (pages (px).crcst);               /* set crcst entry wrd 1 */
3325       sctwrk (9) = unspec (pages (px).devsct.w1);           /* set dev sct word 1 */
3326       sctwrk (10) = unspec (pages (px).devsct.w2);          /* and word 2 */
3327       substr (sctwrk (1), 1, 18) = bit (bin (px * 4, 18));  /* set test page index (mod 4) */
3328 
3329 /*   The sct pointer and sct data for the alternate device must be passed back to cmlt, provided mtar is running   */
3330 
3331       if (pages (px).alt_dev_flag) then do;                 /* alt. device exists return device info */
3332          sctwrk (11) = unspec (pages (px).altsct.w1);
3333          sctwrk (12) = unspec (pages (px).altsct.w2);
3334          substr (sctwrk (2), 1, 18) = bit (bin (px * 4 + 512, 18));
3335       end;
3336 
3337    end set_sctwrk;
3338 %page;
3339 
3340 /* mca_io_setup - internal procedure to set up the mca workspace for mca I/O */
3341 
3342 mca_io_setup: proc;
3343 
3344 
3345       dcwp = addrel (execp, dcw_ptr);
3346       mca_work_space_ptr = io_info.workspace_ptr;           /* get a ptr to our workspace */
3347       unspec (mca_work_space) = "0"b;                       /* clear it */
3348       c_len = 4;                                            /* want to xfer 4 words */
3349       mvp = addrel (execp, dcw_ptr - 1);                    /* set move ptr to idcw */
3350       bufp = addr (mca_work_space.list_of_dcw);             /* set buf ptr to work space dcw list */
3351       workspace_move = mvp -> workspace_move;               /* move it */
3352       bufp = addr (io_info.dcw_list);                       /* move the buf ptrto save the dcw list in io_info */
3353       workspace_move = mvp -> workspace_move;               /* move it */
3354       if dcw.tally = "0"b3 then c_len = 4096;               /* check for 4096 tally */
3355       else c_len = bin (dcw.tally);                         /* else use as is */
3356       io_block_len = c_len + 4096 + 2;                      /* set io block length to reflect the tally */
3357       mvp = addrel (execp, dcw.address);                    /* set move ptr to data to be sent */
3358       bufp = addr (mca_work_space.data_header_1);           /* set buf ptr to data header area */
3359       workspace_move = mvp -> workspace_move;               /* move it */
3360       data_size_1 = fixed (data_header_1.dest_len_msb || data_header_1.dest_len_lsb, 16);
3361       io_info.icivlu.ic = io_entry.ccc_p;                   /* set entry to call on io completion */
3362       io_info.icivlu.ind = "0"b;                            /* initialize indicators */
3363       io_info.status_add = fixed (io_entry.stat_p);         /* save status storage ptr */
3364       exec_wd (io_info.status_add) = "0"b;                  /* initialize test page status */
3365       exec_wd (io_info.status_add + 1) = "0"b;
3366       io_info.pcwa = pcwa;                                  /* save pcw */
3367       io_info.tio_off = 0;                                  /* save dcw list offset */
3368       io_info.rew_wait = "0"b;                              /* not expecting special interrupt */
3369       io_info.io_in_progress = "1"b;                        /* set flag for interrupt processing */
3370       io_info.num_connects = io_info.num_connects + 1;
3371       io_info.int_time = 0;                                 /* clear out interrupt time */
3372 
3373    end mca_io_setup;
3374 
3375 
3376 
3377 
3378 
3379 /* io_setup - internal procedure to set up the ioi workspace for test I/O */
3380 
3381 io_setup: proc;
3382 
3383 dcl  (continue, first, idcw_io) bit (1);
3384 dcl  (cbuf_add, lstloc, nxtloc) fixed bin;
3385 dcl  dcwb fixed bin (18) uns;
3386 
3387       ioi_wksp = io_info.workspace_ptr;                     /* get a ptr to our workspace */
3388       continue = "0"b;                                      /* reset continue flag */
3389       unspec (wks_init) = "0"b;                             /* initialize workspace to zero */
3390       tolts_workspace.l_pad.e = "525252525252"b3;           /* set up our lower buffer pad */
3391       tolts_workspace.l_pad.o = "525252525252"b3;
3392       tio_off = fixed (rel (addr (tolts_workspace.p_idcw)));/* set default dcw list offset for ioi */
3393       idcwp = addr (tolts_workspace.p_idcw);                /* set up idcw ptr */
3394       idcw.code = "7"b3;                                    /* set in idcw type code */
3395       if io_entry.prim.io_cmd = "40"b3                      /* if idcw I/O */
3396        | io_entry.prim.io_cmd = "24"b3
3397        & io_info.io_type = mhp_io_type then do;             /* | idcw I/O & hyper */
3398          idcw_io = "1"b;                                    /* set flag for idcw io */
3399          idcw.command = io_entry.prim.dev_cmd;              /* set up first idcw from io entry word 4 */
3400          if (idcw.command = "31"b3 & io_info.chan_suspended)/* if diagnostic mode control... */
3401           | io_entry.prim.dev ^= "00"b3 then                /* or punch indicator */
3402             idcw.chan_cmd = "00"b3;                         /* set data xfer chan command */
3403          else if io_entry.prim.io_cmd = "24"b3              /* if cmd = 24 */
3404           & io_info.io_type = mhp_io_type then              /* & hyper io */
3405             idcw.chan_cmd = "00"b3;                         /* set data xfer chan command */
3406          else if io_info.io_type = mtar_io_type then        /* if mtar  */
3407             idcw.chan_cmd = "00"b3;                         /* set data xfer chan command */
3408          else idcw.chan_cmd = "40"b3;                       /* otherwise set special cont. cmd */
3409          idcw.count = io_entry.prim.record_count;           /* set record count */
3410          if idcw.count ^= "00"b3 & idcw.count ^= "01"b3 then do; /* if not single idcw */
3411             idcw.control = "10"b;                           /* set idcw continue bit */
3412             continue = "1"b;                                /* set continue flag */
3413          end;
3414          if idcw.command = "00"b3 then                      /* if suspend command */
3415             io_info.suspend_chan = "1"b;                    /* set flag for mme tdio */
3416          if idcw.command = "20"b3 then                      /* if release command */
3417             io_info.release_chan = "1"b;                    /* set flag for tolts_io_int_ */
3418       end;                                                  /* note that device code is = 0 */
3419       else do;                                              /* not idcw I/O, single or dual I/O */
3420          idcw_io = "0"b;
3421          idcw.command = io_entry.second.dev_cmd;            /* get idcw from word 7 (same for single or dual I/O */
3422          idcw.chan_cmd = io_entry.second.io_cmd;
3423          idcw.count = io_entry.second.record_count;
3424          if io_info.io_type = itr_io_type                   /* insure that release_chan is reset */
3425           then io_info.suspend_chan = "0"b;                 /* in the event no special was returned */
3426          if io_entry.prim.dev_cmd ^= io_entry.second.dev_cmd then do; /* disk/dual I/O */
3427             idcwp = addr (tolts_workspace.seek_idcw);       /* set up seek idcw */
3428             idcw.command = io_entry.prim.dev_cmd;           /* set device command */
3429             if bin (io_entry.sct_add, 13) >= 512
3430              then idcw.device = io_info.altsct.device_no;
3431             else idcw.device = io_info.devsct.device_no;
3432             idcw.code = "7"b3;
3433             idcw.control = "10"b;                           /* set continue bit in idcw */
3434             idcw.chan_cmd = io_entry.prim.io_cmd;
3435             idcw.count = io_entry.prim.record_count;
3436             dcwp = addr (tolts_workspace.seek_dcw);         /* set ptr to seek dcw */
3437             string (dcw) = "0"b;                            /* initialize */
3438             dcw.address = rel (addr (tolts_workspace.seek_add)); /* set dcw address */
3439             dcw.tally = "0001"b3;                           /* set tally of one */
3440             i = fixed (rel (addrel (execp, first_dcw.address))); /* compute index to seek add */
3441             tolts_workspace.seek_add = exec_wd (i);         /* move seek address to workspace */
3442             tio_off = fixed (rel (addr (tolts_workspace.seek_idcw))); /* set dcw list offset to seek idcw */
3443          end;
3444       end;
3445 
3446 /* process dcw list */
3447 
3448       idcwp = addr (tolts_workspace.p_idcw);                /* set primary idcw ptr */
3449 
3450       if ^mpc_io then                                       /* if not controller io */
3451          if bin (io_entry.sct_add, 13) >= 512
3452           then idcw.device = io_info.altsct.device_no;
3453          else idcw.device = io_info.devsct.device_no;
3454       dcwp = addrel (execp, io_entry.dcw_ptr);              /* set dcw ptr to first dcw */
3455       if string (dcw) = "0"b then do;                       /* if non data command */
3456          tolts_workspace.buf_size, c_len = 1;               /* set buffer size to 1 word */
3457          dcwp = addr (tolts_workspace.dcw_list (1));        /* set up iotd that should not be used */
3458          string (dcw) = "0"b;                               /* initialize dcw */
3459          dcw.address = rel (addr (tolts_workspace.data_buf));
3460          dcw.tally = "0001"b3;                              /* 1 word iotd */
3461          if continue then                                   /* if idcw continue bit set */
3462             idcw.control = "00"b;                           /* reset it now */
3463          go to non_data;                                    /* bypass dcw processing */
3464       end;
3465       io_info.page_base = bin (dcw.address);                /* set first dcw address as data buf base */
3466       first, found = "0"b;                                  /* reset terminate condition */
3467       unspec (io_info.dcw_list) = "0"b;                     /* clear out saved dcw list */
3468       lstloc, nxtloc, j = 1;                                /* set initial dcw copy index */
3469       bufp = addr (tolts_workspace.data_buf (1));           /* set intial buffer ptr */
3470       do i = 1 to hbound (tolts_workspace.dcw_list, 1) while (^found); /* go through dcw list */
3471          tolts_workspace.dcw_list (j) = string (dcw);       /* copy dcws (and idcws) to work space */
3472          io_info.dcw_list (j) = string (dcw);               /* and for interrupt processor */
3473          if dcw.char_pos = "7"b3 then do;                   /* if idcw */
3474             idcwp = addr (tolts_workspace.dcw_list (j));    /* set idcw ptr */
3475             if idcw.control = "10"b then                    /* if idcw continue bit set */
3476                continue = "1"b;                             /* set continue flag */
3477             else continue = "0"b;                           /* otherwise reset it */
3478 
3479             if ^mpc_io then                                 /* if not controller io */
3480                if bin (io_entry.sct_add, 13) >= 512
3481                 then idcw.device = io_info.altsct.device_no;/* set device code */
3482                else idcw.device = io_info.devsct.device_no;
3483             j = j + 1;                                      /* increment copy dcw index */
3484          end;
3485          else if dcw.type = "10"b then                      /* if tdcw */
3486             dcwp = addrel (execp, bin (dcw.address) - 1);   /* set dcwp to list -1 */
3487          else do;                                           /* data dcws */
3488             if ^first then do;                              /* if the first time through */
3489                first = "1"b;                                /* set flag, so we don't come back */
3490                dcwb = bin (dcw.address);                    /* set dcw base address */
3491             end;
3492             mvp = addrel (execp, dcw.address);              /* get ptr to data to move */
3493             c_len = bin (dcw.tally);                        /* get length of data */
3494             if string (dcw) = "0"b then do;                 /* if illegal zero dcw */
3495                c_len = 1;                                   /* set length = 1 */
3496                dcw.address = io_entry.stat_p;               /* set address to status word */
3497                call tolts_qttyio_$rs                        /* tell user */
3498                 (0, "Tolts: Last io_entry contains an illegal dcw. Please investigate");
3499             end;
3500             if c_len = 0 then c_len = 4096;                 /* allow for a dcw tally of 4096 */
3501             cbuf_add = bin (dcw.address) - dcwb;            /* compute relative address */
3502             if cbuf_add = 0 then                            /* if this dcw address is the same last */
3503                cbuf_add = lstloc;                           /* set the same index */
3504             else cbuf_add = nxtloc;                         /* otherwise use next avail address */
3505             tolts_workspace.buf_size = cbuf_add;
3506             bufp = addr (tolts_workspace.data_buf (cbuf_add)); /* set buffer ptr */
3507             workspace_move = mvp -> workspace_move;         /* and move it */
3508             mvp = addr (tolts_workspace.dcw_list (j));      /* set ptr to workspace dcw */
3509             mvp -> dcw.address = rel (bufp);                /* set relative address */
3510             lstloc = bin (mvp -> dcw.address) - bin (rel (addr (tolts_workspace.data_buf (1)))) + 1;
3511             nxtloc = lstloc + c_len;                        /* set next available location */
3512             dcwb = bin (dcw.address);                       /* set up to look at nxt dcw */
3513             if idcw_io then do;                             /* if running mdrs */
3514                bufp = addrel (bufp, c_len);                 /* set nxt buffer address for idcw io */
3515                c_len = 0;                                   /* reset current length */
3516             end;
3517             j = j + 1;                                      /* increment copy dcw index */
3518             if dcw.type = "00"b then                        /* if iotd */
3519                if ^continue then                            /* and continue flag not set */
3520                   found = "1"b;                             /* set terminate condition */
3521          end;
3522          dcwp = addrel (dcwp, 1);                           /* increment dcw ptr to next one */
3523       end;
3524       tolts_workspace.buf_size = (bin (rel (bufp)) + c_len) - bin (rel (addr (tolts_workspace.data_buf (1))));
3525 non_data:
3526       tolts_workspace.h_pad.e = "252525252525"b3;           /* set upper buffer pad */
3527       tolts_workspace.h_pad.o = "252525252525"b3;
3528       if io_info.devsct.com_prph then do;                   /* if common prph channel */
3529          pcwa = tolts_workspace.p_idcw;                     /* pick up first idcw */
3530          tio_off = fixed (rel (addr (tolts_workspace.dcw_list (1)))); /* can't execute idcw on com prph */
3531       end;
3532       else pcwa = "000000700000"b3;                         /* otherwise set phony pcw for ioi */
3533       if substr (mme_call_w (4), 1, 1) = "1"b then do;      /* if user wants dcws traced */
3534          io_info.io_trc_flag = "1"b;                        /* set io trace flag */
3535          call ioa_$rsnnl ("^/  ^/*** i/o trace ***^/", message, mesg_len);
3536          if io_entry.prim.dev_cmd ^= io_entry.second.dev_cmd & ^idcw_io then /* if disk io */
3537             call ioa_$rsnnl ("^a^/seek idcw: - ^12.3b, seek dcw: - ^12.3b, seek address: - ^12.3b",
3538              message, mesg_len, message, tolts_workspace.seek_idcw,
3539              tolts_workspace.seek_dcw, tolts_workspace.seek_add);
3540          call ioa_$rsnnl ("^a^/^[pcw^;idcw^]: - ^12.3b^/dcw list:^/",
3541           message, mesg_len, message, io_info.devsct.com_prph, tolts_workspace.p_idcw);
3542          do i = 1 by 4 while (tolts_workspace.dcw_list (i) ^= "0"b); /* put out only valid dcws */
3543             call ioa_$rsnnl ("^12.3b ", lginfo, mesg_len, tolts_workspace.dcw_list (i));
3544             do j = 1 to 3 while (tolts_workspace.dcw_list (i + j) ^= "0"b); /* 4 wds per line */
3545                call ioa_$rsnnl ("^a ^12.3b ", lginfo, mesg_len, lginfo, tolts_workspace.dcw_list (i + j));
3546             end;
3547             call ioa_$rsnnl ("^a^/", lginfo, mesg_len, lginfo);
3548             message = rtrim (message) || lginfo;            /* add line to message */
3549          end;
3550          call tolts_qttyio_ (message, 10);
3551       end;
3552       else io_info.io_trc_flag = "0"b;                      /* reset trace flag */
3553       io_info.ext_status_add = io_entry.ext_sts;            /* copy extended status store address */
3554       io_info.ignore_term = io_entry.second.ignore_term;    /* copy ignore term flag */
3555       io_info.icivlu.ic = io_entry.ccc_p;                   /* set entry to call on io completion */
3556       io_info.icivlu.ind = "0"b;                            /* initialize indicators */
3557       io_info.status_add = fixed (io_entry.stat_p);         /* save status storage ptr */
3558       exec_wd (io_info.status_add) = "0"b;                  /* initialize test page status */
3559       exec_wd (io_info.status_add + 1) = "0"b;
3560       io_info.pcwa = pcwa;                                  /* save pcw */
3561       io_info.tio_off = tio_off;                            /* save dcw list offset */
3562       io_info.rew_wait = "0"b;                              /* not expecting special interrupt */
3563       io_info.io_in_progress = "1"b;                        /* set flag for interrupt processing */
3564       io_info.num_connects = io_info.num_connects + 1;
3565       io_info.int_time = 0;                                 /* clear out interrupt time */
3566 
3567    end io_setup;
3568 %page;
3569 /* get_px_sct - subroutine to get the correct test page index, given entry index */
3570 /* the globol variables io_sel, mpc_io and io_info_ptr are set up by this subroutine */
3571 
3572 get_px_sct: proc (mname, px, ck_alloc);
3573 
3574 dcl  mname char (6);
3575 dcl  px fixed bin;
3576 dcl  ck_alloc bit (1);
3577 
3578       if px >= 1024 then do;                                /* ck for controller sct */
3579          mpc_io = "1"b;                                     /* set flag if controller sct */
3580          io_sel = px - 1024;                                /* get device sct */
3581       end;
3582       else if px >= 512 then do;                            /* check for alt. device sct */
3583          mpc_io = "0"b;
3584          io_sel = px - 512;                                 /* get primary device sct */
3585       end;
3586       else do;                                              /* not controller sct, it is device sct */
3587          mpc_io = "0"b;                                     /* reset controller io flag */
3588          io_sel = px;                                       /* test page index is correct as is */
3589       end;
3590       io_sel = divide (io_sel, 4, 17, 0);                   /* Multics scts are mod 4 */
3591       if io_sel < 1 | io_sel > 8 | ^pages (io_sel).in_use |
3592        (ck_alloc & ^pages (io_sel).allocated) then do;      /* if error in sct */
3593          call tolts_qttyio_$rs (0, "^as: MME ^a; Invalid SCT - ^6.3b",
3594           exec, mname, bit (bin (px, 18)));
3595          call tolts_abort ("$a2");
3596       end;
3597       io_info_ptr = addr (pages (io_sel));                  /* get ptr to this test page */
3598 
3599    end get_px_sct;
3600 
3601 /* get_px_tcx - subroutine to get the correct page index, given the true channel index (ICC) */
3602 /* the global variables io_sel and io_info_ptr are set up by this subroutine */
3603 
3604 get_px_tcx: proc (mname, tci);
3605 
3606 dcl  mname char (6);
3607 dcl  tci bit (11);
3608 
3609       do io_sel = 1 to (hbound (pages, 1))
3610        while (tci ^= pages (io_sel).devsct.icc);            /* find correct page */
3611       end;
3612       if io_sel > (hbound (pages, 1)) then do;              /* no matching page */
3613          call tolts_qttyio_$rs (0, "^as: MME ^a; no matching page found for true chan. index - ^3.3b",
3614           exec, mname, tci);
3615          call tolts_abort ("$m1");
3616       end;
3617       else io_info_ptr = addr (pages (io_sel));             /* get ptr to this test page */
3618 
3619    end get_px_tcx;
3620 %page;
3621 
3622 /* output_status_code - internal procedure to queue up a status message */
3623 
3624 output_status_code: proc (ecode, mess);
3625 
3626 dcl  ecode fixed bin (35);
3627 dcl  mess char (*);
3628 
3629       call convert_status_code_ (ecode, shortinfo, lginfo);
3630       call tolts_qttyio_$rs (0, "^as: ^a^/^a", tolts_info.exec, lginfo, mess);
3631    end output_status_code;
3632 
3633 dealcp_sub: proc;
3634 
3635       dealc_err = 0;
3636       if io_info.p_att | io_info.alloc_wait then do;        /* if perp. device attached to this page */
3637          call ck_release;                                   /* go check mpc stae */
3638          if io_info.io_type = mca_io_type then do;
3639             if io_info.ipc_attached then do;
3640                call tolts_qttyio_$rs (0, "^a IPC ^a not reloaded.^/^a^/", io_info.test_hdr, io_info.ipc_number,
3641                 "Do you wish to quit leaving IPC unloaded?");
3642 ask_again:     call tolts_qttyio_$rs (19, "Please answer yes or no. - ");
3643                call message_wait;                           /* wait for users answer */
3644                if tolts_info.mult_ans = "yes"
3645                 | tolts_info.mult_ans = "y" then do;
3646                   io_info.suspend_chan = "1"b;
3647                   opr_query_info.q_sw = "0"b;
3648                   call ioa_$rsnnl ("^/^a Unrecoverable error running ipc ^a firmware.^/^-^a",
3649                    message, i, io_info.test_hdr, io_info.ipc_number,
3650                    "IPC will not be reloaded");
3651                   call opr_query_ (addr (opr_query_info),
3652                    substr (message, 1, i));                 /* tell opr bad news */
3653                end;
3654                else if mult_ans = "no"
3655                 | mult_ans = "n" then do;
3656                   io_info.io_in_progress = "1"b;            /* set flag for interrupt processing */
3657                   io_info.num_connects = io_info.num_connects + 1;
3658                   call mca_$load_ipc (io_info.mca_ioi_idx, io_info.ipc_number,
3659                    "0"b, code);
3660                end;
3661                else goto ask_again;
3662 
3663                call mca_$detach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx,
3664                 ^io_info.suspend_chan, code);
3665                io_info.ipc_attached = "0"b;
3666             end;
3667             if io_info.mca_attach_state ^= MCA_NOT_CONFIGURED then do;
3668                io_info.io_in_progress = "1"b;               /* set flag for interrupt processing */
3669                io_info.num_connects = io_info.num_connects + 1;
3670                call mca_$reset (io_info.mca_ioi_idx, "0"b, code);
3671                io_info.io_in_progress = "1"b;               /* set flag for interrupt processing */
3672                io_info.num_connects = io_info.num_connects + 1;
3673                call mca_$detach_mca (io_info.mca_ioi_idx, code);
3674             end;
3675          end;
3676          else call rcp_$detach (io_info.rcp_id, "0"b, 0, "T&D is detaching " || io_info.device_name, error);
3677          if error ^= 0 then do;                             /* error detaching device */
3678             dealc_err = 1;
3679             call output_status_code (error, "unassign error");
3680          end;
3681       end;
3682 
3683 /* This code will detach the alternate device for mtar (or anyother program). The alternate device attached
3684    flag (io_info.p2_att) is checked to see if an alternate device is attached. If so it is detached.   */
3685 
3686       if io_info.p2_att then do;                            /* detach alternate device if attached */
3687          call rcp_$detach (io_info.alt_rcp_id, "0"b, 0, "t&d is detaching " || io_info.alt_device_name, error);
3688          if error ^= 0 then do;                             /* handle detach error */
3689             dealc_err = 1;
3690             call output_status_code (error, "unassign  error");
3691          end;
3692       end;
3693       if io_info.ev_ch_ass then do;                         /* if status event channel assigned to this page */
3694          call ipc_$delete_ev_chn (io_info.status_event, error);
3695          if error ^= 0 then do;                             /* error deleting event channel */
3696             dealc_err = 1;
3697             call output_status_code (error, " deleting test io event channel ");
3698          end;
3699       end;
3700       unspec (io_info) = "0"b;                              /* clear the test page data */
3701       tolts_info.exec_page_count = tolts_info.exec_page_count - 1; /* decrement total test page count */
3702    end dealcp_sub;
3703 
3704 /*  rel_exec_chan - internal procedure to release the colts exec channel */
3705 
3706 rel_exec_chan: proc (k);
3707 
3708 dcl  k fixed bin (6);
3709       dmap = addr (tolts_info.fnp (k).dm_arg);              /* get addr of dial_manager arg         */
3710       fnp (k).dm_arg.version = dial_manager_arg_version_2;
3711       fnp (k).dm_arg.dial_qualifier = substr (fnp (k).exec_chan, 1, 22);
3712       tolts_info.fnp (k).dm_arg.dial_channel = tolts_info.dm_event; /* set dial_channel to event channel */
3713       tolts_info.fnp (k).dm_arg.channel_name = fnp (k).exec_chan; /* get channel name     */
3714 
3715       call dial_manager_$release_channel (dmap, code);
3716       if code ^= 0 then do;
3717          if debugging then call com_err_ (code, "mtdsim_", "Error releasing ^a.", dmap -> dial_manager_arg.channel_name);
3718          call convert_status_code_ (code, shortinfo, lginfo);
3719          call tolts_qttyio_$rs (0, "^as: ^a/ error doing exec channel release", tolts_info.exec, lginfo);
3720          call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */
3721          fatal_desc.version = 0;
3722          fatal_desc.fatal_code = error;
3723          if ^debugging
3724           then call terminate_process_ ("fatal_error", addr (fatal_desc));
3725          else signal tolts_error_;
3726       end;                                                  /* no need to return, as we won't be back */
3727       cltp = fnp (k).fnp_execp;
3728       call close_sw (cltp);
3729       tolts_info.fnp (k).exec_active = "0"b;
3730       return;
3731    end rel_exec_chan;
3732 
3733 /* rel_tst_chan - internal procedure to release the colts test channel */
3734 
3735 rel_tst_chan: proc (k);
3736 
3737 dcl  k fixed bin (6);
3738 
3739       dmap = addr (tolts_info.colts_pages (k).dm_arg);
3740       tolts_info.colts_pages (k).dm_arg.version = dial_manager_arg_version_2;
3741       tolts_info.colts_pages (k).dm_arg.dial_qualifier = substr (colts_pages (k).cdt_name, 1, 22);
3742       tolts_info.colts_pages (k).dm_arg.dial_channel = tolts_info.dm_event;
3743       tolts_info.colts_pages (k).dm_arg.channel_name = colts_pages (k).cdt_name;
3744       call tolts_qttyio_$rs (0, "Do you want to return the channel ^a to service?", tolts_info.colts_pages (k).cdt_name);
3745 reask: call tolts_qttyio_$rs (19, "Please answer yes or no - ");
3746       call message_wait;
3747       if tolts_info.mult_ans = "yes" | mult_ans = "y" then
3748          call dial_manager_$release_channel (dmap, code);
3749       else if tolts_info.mult_ans = "no" | mult_ans = "n" then
3750          call dial_manager_$release_channel_no_listen (dmap, code);
3751       else goto reask;
3752       if code ^= 0 then do;
3753          if debugging then call com_err_ (code, "mdtsim_", "Error releasing channel ^a.", dmap -> dial_manager_arg.channel_name);
3754          call convert_status_code_ (code, shortinfo, lginfo);
3755          call tolts_qttyio_$rs (0, "^as: ^a/ error doing channel detach", tolts_info.exec, lginfo);
3756          call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */
3757          fatal_desc.version = 0;
3758          fatal_desc.fatal_code = error;
3759          if debugging
3760           then call terminate_process_ ("fatal_error", addr (fatal_desc));
3761          else signal tolts_error_;
3762       end;                                                  /* no need to return, as we won't be back */
3763       cltp = colts_pages (k).chanp;
3764       call close_sw (cltp);
3765       colts_pages (k).in_use = "0"b;
3766       tolts_info.exec_page_count = tolts_info.exec_page_count - 1;
3767       return;
3768    end rel_tst_chan;
3769 
3770 /* close_sw - internal procedure to close and detatch colts io switches */
3771 
3772 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
3773 
3774 
3775 
3776 close_sw: proc (cltp);
3777 
3778 dcl  cltp ptr;
3779       call iox_$close (cltp, code);                         /* close a switch */
3780       if code ^= 0 then do;                                 /* if erroe */
3781          call convert_status_code_ (code, shortinfo, lginfo); /* convert the status code */
3782          call tolts_qttyio_$rs (0, "^as: ^a/ doing iox_$close", tolts_info.exec, lginfo); /* and notify the user */
3783          call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */
3784          fatal_desc.version = 0;
3785          fatal_desc.fatal_code = error;
3786          if ^debugging
3787           then call terminate_process_ ("fatal_error", addr (fatal_desc));
3788          else signal tolts_error_;
3789       end;
3790       call iox_$detach_iocb (cltp, code);                   /* detach the io switch */
3791       if code ^= 0 then do;                                 /* if error */
3792          call convert_status_code_ (code, shortinfo, lginfo); /* convert the error code */
3793          call tolts_qttyio_$rs (0, "^as: ^a/ doing iox_$detach", tolts_info.exec, lginfo); /* notify the user */
3794          call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */
3795          fatal_desc.version = 0;
3796          fatal_desc.fatal_code = error;
3797          if ^debugging
3798           then call terminate_process_ ("fatal_error", addr (fatal_desc));
3799          else signal tolts_error_;
3800       end;
3801       return;
3802    end close_sw;
3803 
3804 /* ctime - internal function to return pl1 time string */
3805 
3806 ctime: proc returns (char (16));
3807 
3808 dcl  tim char (12);
3809 dcl  ptime char (16);
3810 dcl  plen fixed bin;
3811 
3812       tim = time;                                           /* get current time */
3813       call ioa_$rsnnl ("^2a:^2a:^2a.^6a:", ptime, plen, substr (tim, 1, 2), substr (tim, 3, 2),
3814        substr (tim, 5, 2), substr (tim, 7, 6));
3815       return (ptime);                                       /* return time string */
3816 
3817    end ctime;
3818 %page;
3819 
3820 /* clean_up - entry to clean_up - our enviornment before returning to tolts command level */
3821 
3822 clean_up: entry;
3823 
3824       if exec = "colt" then do;
3825          do k = 1 to hbound (pages, 1);
3826             if colts_pages (k).in_use then call rel_tst_chan (k);
3827          end;
3828          do k = 0 to hbound (fnp, 1);
3829             if fnp (k).exec_active then call rel_exec_chan (k);
3830          end;
3831       end;
3832       do io_sel = 1 to hbound (pages, 1);                   /* deallocate all perp. devices */
3833          io_info_ptr = addr (pages (io_sel));
3834          if io_info.in_use then
3835             call dealcp_sub;
3836       end;
3837       if gicmp ^= null then free gicm;
3838       if ticmp ^= null then free ticm;
3839       term = "1"b;                                          /* set terminate condtion */
3840       if tolts_info.file_attach then do;                    /* if print file attached... */
3841          call tolts_file_util_$wdump (addr (spa.regs));
3842          call tolts_file_util_$close;                       /* go close it out */
3843       end;
3844 
3845       if tolts_info.term_io_req_cnt ^= 0 & ^tolts_info.finish_cond /* if we are still doing io */
3846        & ^q_flag then
3847          go to blk_lbl;
3848       call tolts_init_$clean_up;                            /* go delete our event channels and our slave segment */
3849       tolts_active = "0"b;                                  /* reset active state for epilogue handler */
3850 
3851       return;
3852 
3853 
3854 /* decode_den - int procedure to decode density info returned from rcp and put into sct entry */
3855 
3856 decode_den: proc;
3857 
3858       tape_info_ptr = addr (io_info.rcp_area);              /* set tape info ptr */
3859       if substr (tape_info.density, 1, 6) = "00"b3 then do; /* rcp returned bad density information */
3860 ask:
3861          call tolts_qttyio_$rs (0, " ^a RCP returned incorrect device info ^/^a^/", io_info.test_hdr,
3862           "Please input density capabilities of device to be tested");
3863          call tolts_qttyio_$rs (19, "Please input densities in the form: 200,556,800,1600,6250 ^-");
3864          call message_wait;
3865          if tolts_info.mult_ans = "200,556,800" then
3866             io_info.devsct.w2.den_cap = "0001"b;
3867          else if tolts_info.mult_ans = "200,556,800,1600" then
3868             io_info.devsct.w2.den_cap = "0100"b;
3869          else if tolts_info.mult_ans = "556,800,1600" then
3870             io_info.devsct.w2.den_cap = "0101"b;
3871          else if tolts_info.mult_ans = "556,800" then
3872             io_info.devsct.w2.den_cap = "1001"b;
3873          else if tolts_info.mult_ans = "800,1600" then
3874             io_info.devsct.w2.den_cap = "1000"b;
3875          else if tolts_info.mult_ans = "1600" then
3876             io_info.devsct.w2.den_cap = "1100"b;
3877          else if tolts_info.mult_ans = "1600,6250" then
3878             io_info.devsct.w2.den_cap = "1011"b;
3879          else if tolts_info.mult_ans = "6250" then
3880             io_info.devsct.w2.den_cap = "1010"b;
3881          else do;
3882             call tolts_qttyio_$rs (0, "Incorrect reply. ^/ ^a ^/", /* If no match we fall thru */
3883              "Do you want to run with default density");
3884             call tolts_qttyio_$rs (19, "Please answer yes or no");
3885             call message_wait;
3886             if tolts_info.mult_ans = "no" | mult_ans = "n" then goto ask; /* ask for density again */
3887             else if io_info.crcst.mtp610 then do;
3888                io_info.devsct.w2.den_cap = "1100"b;         /* if mtp610 set density to 1600 only */
3889                call tolts_qttyio_$rs (0, "Test will be run at 1600bpi ^/");
3890             end;
3891             else do;
3892                io_info.devsct.w2.den_cap = "1000"b;         /* else run at 500/800bpi */
3893                call tolts_qttyio_$rs (0, "Test will be run at 500/1600bpi ^/");
3894             end;
3895          end;
3896       end;
3897       else if substr (tape_info.density, 1, 6) = "70"b3 then/* 200,556 and 800 bpi */
3898          io_info.devsct.w2.den_cap = "0001"b;
3899       else if substr (tape_info.density, 1, 6) = "74"b3 then/* 200,556,800 and 1600 bpi */
3900          io_info.devsct.w2.den_cap = "0100"b;
3901       else if substr (tape_info.density, 1, 6) = "30"b3 then/* 556 and 800 bpi */
3902          io_info.devsct.w2.den_cap = "1001"b;
3903       else if substr (tape_info.density, 1, 6) = "14"b3 then/* 800 and 1600 bpi */
3904          io_info.devsct.w2.den_cap = "1000"b;
3905       else if substr (tape_info.density, 1, 6) = "04"b3 then/* 1600 bpi only */
3906          io_info.devsct.w2.den_cap = "1100"b;
3907       else if substr (tape_info.density, 1, 6) = "06"b3 then/* 1600 and 6250 bpi */
3908          io_info.devsct.w2.den_cap = "1011"b;
3909       else if substr (tape_info.density, 1, 6) = "02"b3 then/* 6250 bpi only */
3910          io_info.devsct.w2.den_cap = "1010"b;
3911       else if substr (tape_info.density, 1, 6) = "34"b3 then/* 556, 800, and 1600bpi */
3912          io_info.devsct.w2.den_cap = "0101"b;
3913    end decode_den;
3914 
3915 /* pop_isc - subroutine to pop the inter slave read queue and return data to slave exec */
3916 
3917 pop_isc: proc (s_add, d_add);
3918 
3919 dcl  (s_add, d_add) fixed bin;
3920 
3921       exec_wd (s_add) = "400000000000"b3;                   /* set status to complete */
3922       exec_wd (d_add) = tolts_info.exec_dta (1).word (1);   /* move isc data from queue */
3923       exec_wd (d_add + 1) = tolts_info.exec_dta (1).word (2);
3924       exec_wd (d_add + 2) = tolts_info.exec_dta (1).word (3);
3925       tolts_info.exec_dta_cnt = tolts_info.exec_dta_cnt - 1;/* decrement count */
3926       do i = 1 to tolts_info.exec_dta_cnt;
3927          tolts_info.exec_dta (i) = tolts_info.exec_dta (i + 1); /* move queue down */
3928       end;
3929 
3930    end pop_isc;
3931 %page;
3932 /* ck_release - subroutine to check to see if mpc firmware has been destoryed and reload it */
3933 
3934 ck_release: proc;
3935 
3936       if io_info.io_in_progress then do;                    /* if some io outstanding */
3937          call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* Be sure no alarm already set */
3938          call ipc_$drain_chn (tolts_info.gewake_event, error); /* In case event occured */
3939          call timer_manager_$alarm_wakeup (10, "11"b, tolts_info.gewake_event); /* Set 10 second timer */
3940          tolts_info.gewake_active = "1"b;                   /* set flag */
3941          do while (tolts_info.gewake_active);               /* wait for timer to go off or interrupt */
3942             call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); /* Wait for a second */
3943          end;
3944 
3945          if io_info.chan_suspended then                     /* if ioi_$suspend has been called */
3946             if io_info.io_type = itr_io_type
3947              | io_info.io_type = firm_ld_io_type then do;   /* and itrs have been run or attempted to load fw */
3948 retry_ld:
3949                call tolts_load_firmware_ (io_sel, error);   /* go reload firmware */
3950                if error ^= 0 then do;                       /* some problem, ask user what to do */
3951                   if tolts_info.finish_cond then            /* if we don't have a terminal... */
3952                      go to tell_opr;                        /* just tell opr bad news */
3953                   call tolts_qttyio_$rs (0, "^a Error loading mpc firmware.^/^a^/", io_info.test_hdr,
3954                    "Do you wish to retry or quit leaving mpc suspended?");
3955 retype:
3956                   call tolts_qttyio_$rs (19, "Please answer retry or quit. - ");
3957                   call message_wait;                        /* wait for users answer */
3958                   if tolts_info.mult_ans = "retry" then go to retry_ld; /* go retry load again */
3959                   else if tolts_info.mult_ans = "quit" then do;
3960 tell_opr:
3961                      opr_query_info.q_sw = "0"b;
3962                      call ioa_$rsnnl ("^/^a ^a^/^-^a", message, i, io_info.test_hdr,
3963                       "Unrecoverable error loading mpc firmware.", "I/O will remain suspended");
3964                      call opr_query_ (addr (opr_query_info), substr (message, 1, i)); /* tell opr bad news */
3965                   end;
3966                   else go to retype;                        /* user gave wrong answer */
3967                end;
3968             end;
3969 
3970             else if io_info.io_type ^= mca_io_type then do; /* must be suspended from mdr io */
3971                ioi_wksp = io_info.workspace_ptr;            /* get a ptr to our workspace */
3972                unspec (wks_init) = "0"b;                    /* initialize workspace to zero */
3973                idcwp = addr (tolts_workspace.p_idcw);       /* set up idcw ptr */
3974                idcw.code = "7"b3;                           /* set in idcw type code */
3975                idcw.command = "20"b3;                       /* set release command */
3976                idcw.chan_cmd = "40"b3;                      /* special cont. command */
3977                pcwa = "000000700000"b3;                     /* set up phony pcw */
3978                tio_off = fixed (rel (addr (tolts_workspace.p_idcw)));
3979                io_info.release_chan = "1"b;                 /* set flag for interrupt processor */
3980                call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* Be sure no alarm already set */
3981                call ipc_$drain_chn (tolts_info.gewake_event, error); /* In case event occured */
3982                call timer_manager_$alarm_wakeup (10, "11"b, tolts_info.gewake_event); /* Set 10 second timer */
3983                tolts_info.gewake_active = "1"b;             /* set flag */
3984                if pages (io_sel).p_att then do;
3985                   call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error);
3986                   if error ^= 0 then
3987                      call output_status_code (error, "cleanup io connect error");
3988                   tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1; /* increment global IO count */
3989                end;
3990                do while (tolts_info.gewake_active);         /* wait for timer to go off or interrupt */
3991                   call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); /* Wait for a second */
3992                end;
3993                if io_info.io_in_progress then do;           /* if we still got timeout... */
3994                   call ioa_$rsnnl ("^/^a ^a^/^-^a", message, i, io_info.test_hdr,
3995                    "Unable to release mpc,", "manually reset and branch to reinitialize mpc");
3996                   opr_query_info.q_sw = "0"b;
3997                   call opr_query_ (addr (opr_query_info), substr (message, 1, i));
3998                   call ioi_$release_devices (io_info.device_index, error); /* do it now */
3999                end;
4000             end;
4001       end;
4002    end ck_release;
4003 
4004 /* message_wait - subroutine to wait for terminal message to complete */
4005 
4006 message_wait: proc;
4007 
4008       do while (tolts_info.term_io_req_cnt > 0);            /* wait for all terminal io to complete */
4009          call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error);
4010       end;
4011 
4012    end message_wait;
4013 %page;
4014 
4015 /* set_gelbar - int procedure to set up information to enter gelbar mode */
4016 
4017 set_gelbar: proc;
4018 
4019 dcl  fwd bit (36);
4020 
4021 dcl  1 acc_over based (addr (fwd)) aligned,                 /* overlay of acc fault status */
4022        (2 bar bit (18),                                     /* BAR value from last mme gelbar */
4023        2 nu1 bit (1),
4024        2 fault bit (1),                                     /* "1"b = fault occurred */
4025        2 nu2 bit (1),
4026        2 overflow bit (1),                                  /* "1"b = fixed point overflow */
4027        2 ex_over bit (1),                                   /* "1"b = exponent overflow */
4028        2 ex_under bit (1),                                  /* "1"b = exponent underflow */
4029        2 ipr bit (1),                                       /* "1"b = eis data ipr fault */
4030        2 nu3 bit (4),
4031        2 dcf bit (1),                                       /* "1"b = divide check fault */
4032        2 f_type fixed bin (5)) unaligned;                   /* fault type, (refer to gcos manual DD19) */
4033 
4034       fwd = "0"b;                                           /* reset all bits */
4035       acc_over.fault = "1"b;                                /* valid gelbar fault,set the fault bit */
4036       acc_over.bar = substr (spa.acc_fault, 1, 18);         /* pick up the current bar setting */
4037       spa.acc_fault = fwd;                                  /* store accumlated ault status */
4038       spa.enter.lbar.bar = "000630"b3;                      /* reset bar to 0 lal */
4039       spa.enter.icivlu.ic = rel (addr (spa.glbflt));        /* set ic to return to gelbar fault vector */
4040       call tolts_init_$gc_tod (gcos_tod);                   /* get current time of day */
4041       spa.glbtmr = bit (fixed (gcos_tod, 35, 0) - fixed (string (spa.glbici), 35, 0), 36); /* delta time */
4042       spa.glbici.ic = bit (bin (scu.ilc, 17) + 1, 18);      /* store current ic + 1 */
4043       spa.glbici.ind = string (scu.ir);                     /* and indicators */
4044       gelbar, in_ccc = "0"b;                                /* reset gelbar mode, and in ccc  */
4045       glb_brk = "1"b;                                       /* and set gelbar break ind */
4046       call wake_disp;                                       /* go wake up dispatcher */
4047 
4048    end set_gelbar;
4049 
4050 
4051 
4052 %page;
4053 %include author_dcl;
4054 %page;
4055 %include cdt;
4056 %page;
4057 %include condition_info;
4058 %page;
4059 %include config_iom_card;
4060 %page;
4061 %include event_wait_info;
4062 %page;
4063 %include gload_data;
4064 %page;
4065 %include mc;
4066 %page;
4067 %include mca_data;
4068 %page;
4069 %include mca_data_area;
4070 %page;
4071 %include opr_query_info;
4072 %page;
4073 %include rcp_disk_info;
4074 %page;
4075 %include rcp_resource_types;
4076 %page;
4077 %include rcp_tape_info;
4078 %page;
4079 %include tolts_err_codes;
4080 %page;
4081 %include tolts_fpinfo;
4082 %page;
4083 %include tolts_info;
4084 %page;
4085 %include tolts_rspd_workspace;
4086 %page;
4087 %include tolts_workspace;
4088 
4089 
4090 
4091 
4092 
4093    end mtdsim_;
4094