1 /* ******************************************************
   2    *                                                    *
   3    *                                                    *
   4    * Copyright (c) 1972 by Massachusetts Institute of   *
   5    * Technology and Honeywell Information Systems, Inc. *
   6    *                                                    *
   7    *                                                    *
   8    ****************************************************** */
   9 
  10 /* format: style4 */
  11 
  12 load_tandd_library: ltdl: proc;
  13 
  14 /* load_tandd_library - command to load the ITR, Firmware and Diagnostic (IFAD) tape (formally the firmware tape)
  15    into a keyed sequential vfile_ named tandd_deck_file
  16    Written by J. A. Bush 11/78
  17    Modified by J. A. Bush 12/79 for multiple ifad file changes and to add copy feature
  18    Modified by J. A. Bush 8/80 to add -density control arg and spell error_table_$inconsistent correctly
  19    Modified by J. A. Bush 8/81 to add binary deck tape processing capabilities
  20    Modified by J. A. Bush 2/82 to accept gcos partial hdr label as EOV
  21    Modified by G. C. Dixon 6/83 to add -patches control argument.
  22    Modified by P. K. Farley 6/84 to fix cat_key when only FW (NO ITRs) is on tape.
  23 */
  24 
  25 /* external entries */
  26 
  27 dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
  28 dcl  iox_$close entry (ptr, fixed bin (35));
  29 dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
  30 dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
  31 dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
  32 dcl  iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
  33 dcl  iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
  34 dcl  iox_$delete_record entry (ptr, fixed bin (35));
  35 dcl  iox_$seek_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
  36 dcl  get_wdir_ entry returns (char (168));
  37 dcl  date_time_ entry (fixed bin (52), char (*));
  38 dcl  (com_err_, ioa_$ioa_switch) entry options (variable);
  39 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
  40 dcl  bcd_to_ascii_ entry (bit (*), char (*) aligned);
  41 dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
  42 dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
  43 dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
  44 dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
  45 dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
  46 dcl  gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35));
  47 dcl  gload_$allow_zero_checksums entry (char (*), char (*), char (*), ptr, ptr, fixed bin (18), ptr, fixed bin (35));
  48 dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
  49 dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
  50 
  51 /* constants */
  52 
  53 dcl  pname char (18) int static options (constant) init
  54           ("load_tandd_library");
  55 dcl  (opn_sqi init (4),                                     /* open for sequential  input */
  56      opn_sqo init (5),                                      /* open for sequential output */
  57      opn_ksu init (10),                                     /* open for keyed sequential update */
  58      opn_so init (2)) fixed bin int static options (constant); /* open for stream output */
  59 dcl  buf_size fixed bin (21) int static options (constant) init (4 * 1024); /* 1k buffer is plenty */
  60 dcl  bcd_obj bit (78) int static options (constant) init
  61           ("53202020202020462241252363"b3);                 /* "$      object" in bcd */
  62 dcl  bcd_dkend bit (72) int static options (constant) init
  63           ("532020202020202442254524"b3);                   /* "$      dkend" in bcd */
  64 dcl  g_label bit (72) int static options (constant) init    /* = "ge  600 btl " in bcd */
  65           ("272520200600002022634320"b3);
  66 dcl  hdra char (18) static options (constant) init ("Edit  Deck    Assm");
  67 dcl  hdrb char (42) static options (constant) init ("N^H__^Ha_^Hm_^He  T^H__^Hy_^Hp_^He    D^H__^Ha_^Ht_^He");
  68 dcl  hdra1 char (5) static options (constant) init ("Ident");
  69 dcl  hdrb1 char (46) static options (constant) init ("C^H__^Ho_^Hd_^He    M^H__^Ho_^Hd_^He_^Hl   R^H__^He_^Hv.^H_");
  70 dcl  hdrb2 char (12) static options (constant) init ("T^H__^Hy_^Hp_^He");
  71 dcl  hdrb3 char (111) static options (constant) init ("S^H__^He_^Ha_^Hr_^Hc_^Hh K^H__^He_^Hy         C^H__^Ho_^Hm_^Hp  O^H__^Hf_^Hf_^Hs_^He_^Ht  L^H__^He_^Hn_^Hg_^Ht_^Hh (^H_B^H__^Hy_^Ht_^He_^Hs)^H_");
  72 dcl  hdra2 char (2) static options (constant) init ("SS");
  73 dcl  hdra3 char (40) static options (constant) init ("Record             Location       Record");
  74 dcl  hdra4 char (7) static options (constant) init ("Multics");
  75 dcl  hdrb4 char (30) static options (constant) init ("A^H__^Hp_^Hp_^Hl_^Hi_^Hc_^Ha_^Hb_^Hl_^He");
  76 dcl  fmt1 char (53) static options (constant) init
  77           ("^[^5-^12s^; ^[^6x^1s^;^6a^]  ^4a  ^4a  ^2a/^2a/^2a  ");
  78 dcl  fmt2 char (33) static options (constant) init
  79           ("^[^6a  ^6a   ^2a^s^;^3s^4a^2-^]^]");
  80 dcl  fmt3 char (58) static options (constant) init
  81           ("^-^[    ^[^;^[yes^;no ^]^]^;^2s^21a   ^2d   ^6o    ^8d^]^/");
  82 dcl  density (5) char (5) static options (constant) init
  83           ("d6250", "d1600", "d800", "d556", "d200");
  84 dcl  cleanup condition;
  85 dcl  (addr, addrel, char, clock, currentsize, fixed, index, ltrim, null,
  86      rel, rtrim, substr, unspec, bin, hbound, string) builtin;
  87 
  88 /* automatic */
  89 
  90 dcl  (code, scode, tdec) fixed bin (35);
  91 dcl  rec_len fixed bin (21);
  92 dcl  (cfile, pfile, crec, nwds, dlen, c_rtrycnt, rtrycnt, bcnt, psz) fixed bin;
  93 dcl  (m, i, j, lx, al, line_count, page_no, denno) fixed bin;
  94 dcl  fnp_key fixed bin init (0);
  95 dcl  (ap, bptr, cvp, cvp1, cptr, segp, catp, svp) ptr;
  96 dcl  tempp (2) ptr;
  97 dcl  (m_att_desc, c_att_desc, l_att_desc) char (64);
  98 dcl  obj_buf char (80) aligned;                             /* buffer to hold current object card image */
  99 dcl  err_card char (80) aligned;
 100 dcl  id_buf char (18) aligned;                              /* buffer to hold current ident block image */
 101 dcl  ident_buf (40) bit (36);                               /* load buffer */
 102 dcl  dir char (168);
 103 dcl  ename char (32);
 104 dcl  (current_key, cat_key) char (24) init ("");
 105 dcl  work_key char (256) varying;
 106 dcl  tape_name char (16);
 107 dcl  time_string char (24);                                 /* Current date and time */
 108 dcl  (dtype, fnp_type) char (4);
 109 dcl  (sstype, cden) char (5);
 110 dcl  t_stat bit (12) aligned;
 111 dcl  (cat_build, first_deck, eot, one_eof, hdr_sw, first_ff, cont_sw) bit (1) init ("0"b);
 112 dcl  (list, firmware_sw, deckfile_sw, config_sw, cd_sw) bit (1) init ("0"b);
 113 dcl  (attach_copy, copy_at_eof, first_write, fnp_tape, build_fnp_cat, patches) bit (1) init ("0"b);
 114 dcl  (dk_end, trm, first_rcd, obj_card, id_ld, v_patch, eof, err, lib, at_bot) bit (1);
 115 
 116 /* static */
 117 
 118 dcl  (error_table_$wrong_no_of_args,
 119      error_table_$bad_arg,
 120      error_table_$tape_error,
 121      error_table_$no_record,
 122      error_table_$inconsistent,
 123      error_table_$end_of_info) ext fixed bin (35);
 124 dcl  (tiocb_ptr, fiocb_ptr, liocb_ptr, ciocb_ptr) ptr static;
 125 dcl  (t_attached, f_attached, l_attached, c_attached) bit (1) int static init ("0"b);
 126 
 127 /* structures and based variables */
 128 
 129 dcl  1 r_card based (cptr) aligned,                         /* template for a binary card image */
 130        (2 type bit (12),                                    /* card type */
 131        2 count fixed bin (5),                               /* number of wds controlled */
 132        2 ld_add bit (18),                                   /* loading address */
 133        2 pad (psz) bit (36),
 134        2 data (r_card.count) bit (36),
 135        2 nxt_c_wd bit (36)) unaligned;                      /* to get nxt control wd */
 136 
 137 dcl  1 id_blk based (addr (id_buf)) aligned,                /* template for ident block */
 138          (2 ident char (6),                                 /* module identification */
 139        2 revision,
 140          3 rev_dot char (4),                                /* char string "rev." */
 141          3 rev char (2),                                    /* alpa-numeric revision */
 142        2 type_code,
 143          3 pad char (3),
 144          3 type char (3)) unaligned;                        /* module type (itr, mdr or firmware) */
 145 
 146 dcl  1 o_card based (addr (obj_buf)) aligned,               /* template for an object card */
 147        (2 pad1 char (15),
 148        2 library char (6),                                  /* col 16 - either "hmpcj1" or "htnd  " */
 149        2 ld_type char (1),                                  /* col 22, module type */
 150        2 ss_type char (1),                                  /* col 23, subsystem type */
 151        2 pad2 char (3),
 152        2 m_applic char (1),                                 /* Multics applicability, non blank means not applicable */
 153        2 pad3 char (15),
 154        2 model char (6),                                    /* for hmpcj1 decks, controller model # */
 155        2 version char (6),                                  /* for hmpcj1 decks, model version # */
 156        2 pad4 char (5),
 157        2 assem char (1),                                    /* "m" for mpc assembler, "g" for gmap */
 158        2 call_name char (6),                                /* module call name, or gecall name */
 159        2 ttl_date char (6),                                 /* date module assembled */
 160        2 edit_name char (4)) unaligned;                     /* module edit name */
 161 
 162 dcl  1 o_patch based (addr (err_card)) aligned,             /* template for octal patch card */
 163        (2 add char (6),                                     /* patch address */
 164        2 blk1 char (1),
 165        2 octal char (5),                                    /* either "octal" or "mask " */
 166        2 blk2 char (3),
 167        2 p_fld char (57),                                   /* variable filed (patch data) */
 168        2 comment char (8)) unaligned;                       /* comment field */
 169 
 170 dcl  1 h_patch based (addr (err_card)) aligned,             /* template for hex patch card */
 171        (2 h_add char (6),                                   /* (c1) hex patch address */
 172        2 cr char (1),                                       /* (c7) = "c" for cs, "r" for r/w mem */
 173        2 hex char (3),                                      /* (c8) = "hex" for hex patch */
 174        2 pad1 char (5),
 175        2 inst char (8),                                     /* (c16) 2 - 4 hex digit instructions */
 176        2 pad2 char (13),
 177        2 rev char (6),                                      /* (c37) should equal word 2 of deck id block */
 178        2 pad3 char (42),
 179        2 lbl char (4)) unaligned;                           /* (c73) = deck edit name */
 180 
 181 dcl  1 p_blk aligned,                                       /* patch card image storage */
 182        2 p_cnt fixed bin,                                   /* number of valid patches */
 183        2 p_card (200) char (80);                            /* patch card image */
 184 
 185 dcl  1 cata based (catp) aligned,                           /* template for itr or mdr catalog */
 186        2 n_entries fixed bin,                               /* number of catalog entries */
 187        2 key (1 refer (cata.n_entries)) char (24);          /* entry search keys */
 188 
 189 dcl  1 rsi like rs_info aligned;                            /* auto copy of record status info */
 190 
 191 dcl  arg char (al) based (ap);
 192 dcl  id_bbuf bit (108) based (cvp);
 193 dcl  bit_buf bit (rec_len * 9) based (prptr);
 194 ^L
 195 
 196           rs_info_ptr = null;
 197           call cu_$arg_ptr (1, ap, al, code);               /* get reel id - MUST BE 1st */
 198           if code ^= 0 then do;
 199                call com_err_ (error_table_$wrong_no_of_args, pname,
 200                     "^/Usage:^-^a reel_id {-control_args}", pname);
 201                return;
 202           end;
 203           m_att_desc = "tape_nstd_ " || arg;                /* start attach description */
 204           i = index (arg, ",");                             /* Check for commas in tape name */
 205           if i > 1 then tape_name = substr (arg, 1, i - 1); /* If comma, use stuff before */
 206           else tape_name = arg;                             /* Otherwise use the whole thing */
 207           l_att_desc = "vfile_ " || tape_name;              /* start listing attach description */
 208           call date_time_ (clock (), time_string);          /* Convert date and time. */
 209           dir = get_wdir_ ();                               /* Get working directory. */
 210           j = 2;
 211           call cu_$arg_ptr (j, ap, al, code);               /* look for more arguments */
 212           do while (code = 0);                              /* do while there are args */
 213                if arg = "-track" | arg = "-tk" then do;     /* next arg must be 7 or 9 */
 214                     j = j + 1;
 215                     call cu_$arg_ptr (j, ap, al, code);     /* get track arg */
 216                     if code ^= 0 then do;                   /* error */
 217                          call com_err_ (code, pname, "obtaining ""-track"" specification.");
 218                          return;
 219                     end;
 220                     tdec = cv_dec_check_ (arg, code);       /* convert to dec. for check */
 221                     if code ^= 0 then go to bad_arg;        /* must be numeric */
 222                     if tdec ^= 7 & tdec ^= 9 then go to bad_arg; /* and only 7 or 9 */
 223                     if attach_copy then                     /* if track specification of copy tape */
 224                          c_att_desc = rtrim (c_att_desc) || " -track " || ltrim (char (tdec)); /* insert leading blank */
 225                     else m_att_desc = rtrim (m_att_desc) || " -track " || ltrim (char (tdec)); /* insert leading blank */
 226                end;
 227                else if arg = "-density" | arg = "-den" then do; /* next arg must be density value */
 228                     j = j + 1;
 229                     call cu_$arg_ptr (j, ap, al, code);
 230                     if code ^= 0 then do;
 231                          call com_err_ (code, pname, "obtaining ""-density"" specification.");
 232                          return;
 233                     end;
 234                     tdec = cv_dec_check_ (arg, code);
 235                     if code ^= 0 then go to bad_arg;
 236                     if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then do;
 237                          if attach_copy then do;            /* if setting density on copy tape */
 238                               c_att_desc = rtrim (c_att_desc) || " -density " || ltrim (char (tdec));
 239                               cd_sw = "1"b;                 /* set indicator */
 240                          end;
 241                          else m_att_desc = rtrim (m_att_desc) || " -density " || ltrim (char (tdec));
 242                     end;
 243                     else go to bad_arg;                     /* make him get it right */
 244                end;
 245                else if arg = "-output_dir" | arg = "-odr" then do; /* user will specify path */
 246                     j = j + 1;
 247                     call cu_$arg_ptr (j, ap, al, code);
 248                     if code ^= 0 then do;
 249                          call com_err_ (code, pname, "obtaining ""-output_dir"" specification.");
 250                          return;
 251                     end;
 252                     call absolute_pathname_ (arg, dir, code); /* expand it */
 253                     if code ^= 0 then do;
 254                          call com_err_ (code, pname, "expanding pathname ""^a""", arg);
 255                          return;
 256                     end;
 257                end;
 258                else if arg = "-copy" | arg = "-cp" then do; /* user wantsd to make copy of ifad tape */
 259                     j = j + 1;
 260                     call cu_$arg_ptr (j, ap, al, code);
 261                     if code ^= 0 then do;
 262                          call com_err_ (code, pname, "obtaining ""-copy"" tape reel specification.");
 263                          return;
 264                     end;
 265                     c_att_desc = "tape_nstd_ " || arg;      /* generate initial copy attach description */
 266                     attach_copy = "1"b;                     /* set flag */
 267                end;
 268                else if arg = "-list" | arg = "-ls" then list = "1"b; /* user just wants listing */
 269                else if arg = "-firmware" | arg = "-fw" then firmware_sw = "1"b; /* user just wants firmware loaded */
 270                else if arg = "-deckfile" | arg = "-dkf" then deckfile_sw = "1"b; /* user just wants deckfile loaded */
 271                else if arg = "-config" then config_sw = "1"b; /* base tape loading on current configuration */
 272                else if arg = "-fnp_tape" then fnp_tape = "1"b; /* user wants to load fnp bin. deck tape */
 273                else if arg = "-patches" then patches = "1"b;/* user wants to allow patched cards having 0 checksums */
 274                else do;
 275 bad_arg:            call com_err_ (error_table_$bad_arg, pname, "argument number ^d: ""^a""", j, arg);
 276                     return;
 277                end;
 278                j = j + 1;
 279                call cu_$arg_ptr (j, ap, al, code);
 280           end;
 281           if (firmware_sw & deckfile_sw) then do;           /* check for consistency in control args */
 282                call com_err_ (error_table_$inconsistent, pname, "-firmware and -deckfile");
 283                return;
 284           end;
 285           if (firmware_sw & list) then do;                  /* illegal combination */
 286                call com_err_ (error_table_$inconsistent, pname, "-firmware and -list");
 287                return;
 288           end;
 289           if (firmware_sw & attach_copy) then do;           /* illegal combination */
 290                call com_err_ (error_table_$inconsistent, pname, "-firmware and -copy");
 291                return;
 292           end;
 293           if (firmware_sw & fnp_tape) then do;              /* illegal combination */
 294                call com_err_ (error_table_$inconsistent, pname, "-firmware and -fnp_tape");
 295                return;
 296           end;
 297           if config_sw then                                 /* if user wants deckfile tailored */
 298                call set_fig;                                /* go set up config parameters */
 299           call get_temp_segments_ (pname, tempp, code);     /* get temp segs for tape and catalog buffers */
 300           if code ^= 0 then do;                             /* can't allocate buffer */
 301                call com_err_ (code, pname, "getting temporary segments");
 302                return;
 303           end;
 304           bptr = tempp (1);                                 /* set tape buffer segment ptr */
 305           catp = tempp (2);                                 /* set calalog buffer segment ptr */
 306           cata.n_entries = 0;                               /* initialy set to 0 entries */
 307 
 308 /* attach and open tape using the "tape_nstd_" io module */
 309 
 310           call iox_$attach_name ("tape_sw", tiocb_ptr, m_att_desc, null, code);
 311           if code ^= 0 then do;
 312                call com_err_ (code, pname, "attaching tape");
 313                return;
 314           end;
 315           t_attached = "1"b;
 316           call iox_$open (tiocb_ptr, opn_sqi, "0"b, code);  /* open for seq. input */
 317           if code ^= 0 then do;
 318                call com_err_ (code, pname, "opening tape for sequential input");
 319                call detach_tape_file;
 320                return;
 321           end;
 322 
 323 /* attach and open tandd_deck_file */
 324 
 325           if ^list & ^firmware_sw then do;                  /* don't attach deck file if we are just producing listing */
 326                call iox_$attach_name ("dkfile_sw", fiocb_ptr, "vfile_ " || rtrim (dir) || ">tandd_deck_file", null, code);
 327                if code ^= 0 then do;
 328                     call com_err_ (code, pname, "attaching tandd_deck_file");
 329                     call detach_tape_file;
 330                     return;
 331                end;
 332                f_attached = "1"b;
 333                call iox_$open (fiocb_ptr, opn_ksu, "0"b, code); /* open for keyed_sequential update */
 334                if code ^= 0 then do;
 335                     call com_err_ (code, pname, "opening tandd_deck_file for keyed_sequential_update");
 336                     call detach_tape_file;
 337                     return;
 338                end;
 339           end;
 340 
 341 /* attach and open copy tape using the "tape_nstd_" io module */
 342 
 343           if attach_copy then do;                           /* only attach copy if indicated */
 344                c_att_desc = rtrim (c_att_desc) || " -write";/* add write ring spec */
 345                call iox_$attach_name ("copy_sw", ciocb_ptr, c_att_desc, null, code);
 346                if code ^= 0 then do;
 347                     call com_err_ (code, pname, "attaching copy tape");
 348                     call detach_tape_file;
 349                     return;
 350                end;
 351                c_attached = "1"b;
 352                call iox_$open (ciocb_ptr, opn_sqo, "0"b, code); /* open for seq. output */
 353                if code ^= 0 then do;
 354                     call com_err_ (code, pname, "opening copy tape for sequential output");
 355                     call detach_tape_file;
 356                     return;
 357                end;
 358           end;
 359 
 360           on cleanup call detach_tape_file;                 /* set up clean up handler */
 361 ^L
 362 /* main processing loop */
 363 
 364           pfile, cfile, page_no = 1;                        /* set first file number and listing page number */
 365           denno, crec = 0;                                  /* and record */
 366           unspec (rsi) = "0"b;                              /* clear rcecord status structure */
 367           rsi.version = rs_info_version_2;                  /* set structure version for vfile_ */
 368           at_bot = "1"b;                                    /* set bot indicator */
 369 
 370           do while (^eot);                                  /* read tape until 2 eofs */
 371                call read_deck (eof, err);                   /* read in next object deck */
 372                if err | (eof & one_eof) | eot then do;      /* if error condition or 2 eofs */
 373                     eot = "1"b;                             /* thats all there is to do */
 374                     if attach_copy then call copy_eof;      /* if we are copying tape,write out 2nd eof */
 375                     if fnp_tape & ^err & ^list then do;     /* write out fnp catalog record */
 376                          current_key = "cata." || rtrim (cat_key); /* form completed key */
 377                          call insert_deck (catp, cata.n_entries * 24 + 4, err); /* and write catalog to deck file */
 378                          if ^err then call update_list (3); /* add catalog record to listing file */
 379                     end;
 380                end;
 381                else if eof then do;                         /* if eof */
 382                     one_eof = "1"b;                         /* set flag */
 383                     if attach_copy then                     /* if we are copying tape */
 384                          if ^copy_at_eof then               /* and copy tape is not already at end of file */
 385                               call copy_eof;                /* go write eof on copy tape */
 386                     if cat_build & ^fnp_tape then do;       /* if we were building catalog */
 387                          cat_build, first_deck = "0"b;      /* reset flags */
 388                          if index (cat_key, "itr.") ^= 0 then do; /* if building itr catalog */
 389                               if id_blk.type = "itr" | id_blk.type = "mdr" then do; /* last entry must be firmware */
 390                                    call com_err_ (0, pname, "Last object deck on itr file is not firmware");
 391                                    call com_err_ (0, pname, "Last object card image is:^/""^a""", obj_buf);
 392                                    eot = "1"b;              /* set flag to abort */
 393                                    go to exit;
 394                               end;
 395                               else do;                      /* no errors form catalog name */
 396                                    do i = cata.n_entries to 1 by -1 while (index (cata.key (i), ".") > 4);
 397                                    end;                     /* find first firmware deck */
 398                                    cat_key = rtrim (cat_key) || substr (cata.key (i + 1), 8, 6) ||
 399                                         "." || substr (cata.key (i + 1), 20, 2);
 400                               end;
 401                          end;
 402                          current_key = "cata." || rtrim (cat_key) || "." || ltrim (char (cfile - 1)); /* set current key */
 403                          call insert_deck (catp, cata.n_entries * 24 + 4, err); /* and write catalog to deck file */
 404                          if err then eot = "1"b;            /* if fatal error */
 405                          else call update_list (3);         /* add catalog record to listing file */
 406                     end;
 407                     if ^fnp_tape then                       /* if not loading fnp deck tape.. */
 408                          hdr_sw, cont_sw = "0"b;            /* reset continue flag for listing file */
 409                end;
 410                else do;                                     /* good read, process deck */
 411                     one_eof = "0"b;                         /* reset eof flag if set */
 412                     if list then                            /* if just producing listing, take all decks */
 413                          call update_list (1);              /* go add entry to listing file */
 414                     else if fnp_tape then go to i_deck;     /* no applicability check for fnp decks */
 415                     else if ck_applic () then               /* only take deck if Multics applicable */
 416                          if ^firmware_sw then do;           /* if just loading firmware, don't insert deck into deckfile */
 417 i_deck:                       call make_key;                /* produce insertion key */
 418                               call insert_deck (bptr, dlen * 4, err); /* copy current deck into deckfile */
 419                               if err then eot = "1"b;       /* if error return, abort */
 420                               else call update_list (2);    /* add current deck entry to listing file */
 421                          end;
 422                end;
 423 exit:
 424           end;
 425           call detach_tape_file;                            /* we are all done, cleanup */
 426           return;                                           /* and return */
 427 ^L
 428 
 429 /* read_deck - internal procedure to read in the next sequential object deck from the tape */
 430 
 431 read_deck: proc (end_file, abort);
 432 
 433 dcl  (end_file, abort) bit (1);
 434 
 435           obj_card, id_ld, first_rcd, end_file, abort = "0"b; /* reset flags */
 436           dk_end = "0"b;                                    /* reset deck end flag */
 437           p_blk.p_cnt = 0;                                  /* initialize patch count */
 438           if pfile < cfile then pfile = cfile;              /* update listing file designator if necessary */
 439           prptr = bptr;                                     /* set initial blk ptr to base of tape buff */
 440           cvp, cvp1 = null;
 441 
 442           do while (^dk_end);                               /* loop until entire deck is read in */
 443                rtrycnt = 0;                                 /* reset retries */
 444 retry_rd:
 445                call iox_$read_record (tiocb_ptr, prptr, buf_size, rec_len, code);
 446                if code ^= 0 then do;
 447                     if code ^= error_table_$end_of_info then/* if not end of file */
 448                          if code = error_table_$tape_error then do;
 449                               if at_bot then do;            /* still at bot probably wrong density */
 450                                    denno = denno + 1;       /* increment density number */
 451                                    if denno > hbound (density, 1) then /* can't set it so abort */
 452                                         go to get_stat;
 453                                    call iox_$control (tiocb_ptr, "rewind", null, code);
 454                                    call iox_$control (tiocb_ptr, density (denno), null, code); /* set density */
 455                                    go to retry_rd;          /* and go try again */
 456                               end;
 457                               rtrycnt = rtrycnt + 1;        /* increment retry count */
 458                               if rtrycnt = 11 then do;      /* if we have retried max number of times */
 459 get_stat:
 460                                    call iox_$control (tiocb_ptr, "saved_status", addr (t_stat), scode);
 461                                    call com_err_ (code, pname,
 462                                         "Tape status = ^4.3b, while reading record ^d, file ^d after 10 retries",
 463                                         t_stat, crec, cfile);
 464                                    abort = "1"b;            /* set abort indicator */
 465                                    return;
 466                               end;
 467                               call iox_$control (tiocb_ptr, "backspace_record", null, code);
 468                               go to retry_rd;
 469                          end;
 470                          else do;                           /* not a tape error report it and abort */
 471                               call com_err_ (code, pname, "While reading record ^d, file ^d", crec, cfile);
 472                               abort = "1"b;                 /* set abort indicator */
 473                               return;                       /* and return */
 474                          end;
 475                     else do;                                /* end of file */
 476                          end_file = "1"b;                   /* set eof indicator */
 477                          cfile = cfile + 1;                 /* increment position indicators */
 478                          crec = 0;
 479                          return;
 480                     end;
 481                end;
 482                if rec_len = 56 then                         /* check for partial hdr label (GCOS EOV) */
 483                     if substr (bit_buf, 1, 72) = g_label then
 484                          if substr (bit_buf, 145, 216) = "0"b then do; /* if true, partial hdr label */
 485                               eot = "1"b;                   /* set EOV flags */
 486                               return;
 487                          end;
 488                if ^first_rcd then do;                       /* if first record of deck */
 489                     bcnt = bcw.bsn;                         /* load block serial number */
 490                     first_rcd = "1"b;
 491                     if fnp_tape & at_bot then               /* get set to build  fnp catalog key */
 492                          build_fnp_cat = "1"b;
 493                     at_bot = "0"b;                          /* cannot be at bot anymore */
 494                end;
 495                else do;                                     /* if not first record, check BSN */
 496                     bcnt = bcnt + 1;                        /* increment our block count */
 497                     if bcw.bsn ^= bcnt then do;             /* something wrong here */
 498                          call com_err_ (0, pname,
 499                               "Block serial number error at record ^d, file ^d", crec, cfile);
 500                          call com_err_ (0, pname, "Block serial number was ^d, S/B ^d", bcw.bsn, bcnt);
 501                          abort = "1"b;                      /* set abort flag */
 502                          return;
 503                     end;
 504                end;
 505                lrptr = addr (gc_phy_rec.gc_phy_rec_data (1)); /* get pointer to first logical record */
 506                nwds = 0;
 507 
 508                do while (nwds < bcw.blk_size);              /* iterate through all logical records */
 509                     if rcw.media_code = 2 then do;          /* bcd card image */
 510                          if substr (gc_log_rec_bits, 1, 78) = bcd_obj then do; /* object card */
 511                               call bcd_to_ascii_ (gc_log_rec_bits, obj_buf); /* convert to ascii */
 512                               obj_card = "1"b;              /* indicate that we have gotten object card */
 513                               if build_fnp_cat then do;     /* if we need to build fnp catalog record */
 514                                    if o_card.edit_name = "2000" then /* is this an 18x fnp */
 515                                         fnp_type = "6670";  /* yes, set type */
 516                                    else if o_card.edit_name = "0300" then /* is it a 355 fnp */
 517                                         fnp_type = "6600";
 518                                    else do;                 /* neither one, can't be fnp tape */
 519                                         call com_err_ (0, pname, "^a ""^a"", ^a",
 520                                              "First object deck image on fnp tape  has edit name", o_card.edit_name,
 521                                              "which is not the first deck on a fnp binary deck tape");
 522                                         abort = "1"b;
 523                                         return;
 524                                    end;
 525                                    cat_key = "fnp.pol." || fnp_type; /* start catalog key */
 526                                    l_att_desc = rtrim (l_att_desc) || ".fnp." || fnp_type; /* add to list att. desc. */
 527                                    build_fnp_cat = "0"b;
 528                               end;
 529 
 530                          end;
 531                          else do;                           /* must be dkend or patch card */
 532                               if o_card.library = "hmpcj1" & ^id_ld then do; /* if hmpcj1 lib and we haven't been here */
 533                                    id_ld = "1"b;            /* set flag so we don't come back */
 534                                    if cvp1 = null then      /* if only 1 binary card */
 535                                         cvp1 = cvp;
 536                                    call load_ident;         /* load ident block */
 537                               end;
 538                               if substr (gc_log_rec_bits, 1, 72) = bcd_dkend then /* dkend card */
 539                                    dk_end = "1"b;           /* set terminate condition */
 540                               else call ck_patch (abort);   /* go check for patch card */
 541                               if abort then return;         /* if error, get out */
 542                          end;
 543                     end;
 544                     else if rcw.media_code = 1 then         /* binary card image */
 545                          if ^obj_card then do;              /* but no $ object card yet */
 546                               call com_err_ (0, pname,
 547                                    "Binary card image preceeds $ object card at record ^d, file ^d",
 548                                    crec, cfile);
 549                               abort = "1"b;
 550                               return;
 551                          end;
 552                          else do;
 553                               cvp1 = cvp;                   /* save ptr to last logical record */
 554                               cvp = lrptr;                  /* save ptr to current logical record */
 555                          end;
 556                     else do;                                /* not a bcd or binary card image */
 557                          call com_err_ (0, pname, "Card type ^o detected at record ^d, file ^d",
 558                               rcw.media_code, crec, cfile);
 559                          abort = "1"b;
 560                          return;
 561                     end;
 562                     nwds = nwds + rcw.rsize + 1;            /* increment number of words */
 563                     lrptr = addrel (lrptr, currentsize (gc_log_rec)); /* set next logical record */
 564                end;
 565                crec = crec + 1;                             /* increment current record number */
 566                prptr = addrel (prptr, currentsize (gc_phy_rec)); /* append next block */
 567           end;
 568           dlen = fixed (rel (prptr)) + 1;                   /* set total deck length in words */
 569 
 570      end read_deck;
 571                                                             /*^L                                                        */
 572 
 573 /* load_ident - int procedure to load last 2 binary card images of hmpcj1 deck and extract the ident block */
 574 
 575 load_ident: proc;
 576 
 577           svp = lrptr;                                      /* save logical record ptr */
 578           lrptr = cvp1;                                     /* set rcw ptr */
 579           lx = 0;                                           /* set initial load index */
 580 
 581           do while (gc_log_rec.rcw.media_code = 1);         /* process only binary cards */
 582                cptr = addrel (lrptr, 1);
 583                psz = 4;                                     /* set initial pad size to 4 */
 584                m = r_card.count;                            /* set initial count */
 585                trm = "0"b;
 586                do while (^trm);                             /* load all words on card */
 587                     do i = 1 to r_card.count;
 588                          ident_buf (lx + i) = r_card.data (i); /* copy data */
 589                     end;
 590                     lx = lx + r_card.count;                 /* update load index */
 591                     if m = rcw.rsize - 8 | substr (r_card.nxt_c_wd, 1, 12) ^= "2005"b3 then
 592                          trm = "1"b;                        /* all done */
 593                     else do;
 594                          cptr = addr (r_card.nxt_c_wd);     /* set for nxt control word */
 595                          psz = 0;                           /* pad size = 0 */
 596                          m = m + r_card.count;              /* increment counter */
 597                     end;
 598                end;
 599                lrptr = addrel (lrptr, currentsize (gc_log_rec)); /* set next logical record */
 600                if rcw.media_code ^= 1 & rcw.media_code ^= 2 then /* ck for new blk */
 601                     if lrptr -> bcw.bsn = bcnt then         /* if looks like bcw */
 602                          lrptr = addrel (lrptr, 1);         /* go to nxt word */
 603           end;
 604 
 605 /* we have all of the ident block loaded, now lets find the words we are interested in */
 606 
 607           trm = "0"b;
 608           do i = 1 to 40 while (^trm);
 609                if ident_buf (i) = "444723224663"b3 then     /* if word = "mpcbot" in bcd */
 610                     trm = "1"b;
 611           end;
 612           cvp = addr (ident_buf (i - 10));                  /* cvp pts to beginning of ident block */
 613           call bcd_to_ascii_ (id_bbuf, id_buf);             /* convert ident block to ascii */
 614           lrptr = svp;                                      /* restore logical record ptr */
 615 
 616      end load_ident;
 617 ^L
 618 
 619 /* update_list - int procedure to add current deck entry to listing file */
 620 
 621 update_list: proc (ltype);
 622 
 623 dcl  ltype fixed bin (2);
 624 
 625           if ^l_attached then do;                           /* if listing file not attached, do it now */
 626                call iox_$attach_name ("list_sw", liocb_ptr, rtrim (l_att_desc) || ".list", null, code);
 627                if code ^= 0 then do;
 628                     call com_err_ (code, pname, "attaching listing file");
 629                     eot = "1"b;
 630                     go to exit;
 631                end;
 632                l_attached = "1"b;
 633                call iox_$open (liocb_ptr, opn_so, "0"b, code); /* open for stream output */
 634                if code ^= 0 then do;
 635                     call com_err_ (code, pname, "opening listing file for stream_output");
 636                     eot = "1"b;
 637                     go to exit;
 638                end;
 639           end;
 640           dtype, sstype = "";
 641           lib = "0"b;                                       /* reset lib switch */
 642           if fnp_tape then do;                              /* if loading fnp bin. deck tape */
 643                sstype = "pol ";                             /* this stands for Partial OnLine */
 644                dtype = "fnp ";
 645           end;
 646           else if o_card.library = "hmpcj1" then do;        /* mpc library */
 647                lib = "1"b;                                  /* set lib switch */
 648                if id_blk.type ^= "itr" & id_blk.type ^= "mdr" then /* if firmware */
 649                     dtype = " fw ";
 650                else substr (dtype, 2, 3) = id_blk.type;     /* set itr or mdr type */
 651           end;
 652           else do;                                          /* must be htnd library */
 653                if o_card.ld_type = "m" then dtype = "mast"; /* pas2 master deck */
 654                else if o_card.ld_type = "s" then dtype = "slav";
 655                else if o_card.ld_type = "p" then dtype = "prog"; /* program deck */
 656                else if o_card.ld_type = "r" then dtype = "rloc"; /* relocatable deck */
 657                else dtype = "data";
 658                if o_card.ss_type = "p" then sstype = "polt";
 659                else if o_card.ss_type = "m" then sstype = "molt";
 660                else if o_card.ss_type = "c" then sstype = "colt";
 661                else if o_card.ss_type = "h" then sstype = "heal";
 662                else if o_card.ss_type = "u" then sstype = "util";
 663                else if o_card.ss_type = "s" then
 664                     if o_card.m_applic = " " then sstype = "isol";
 665                     else sstype = "solt";
 666           end;
 667           if ^list then                                     /* if just producing a listing, don't bother */
 668                call iox_$control (fiocb_ptr, "record_status", addr (rsi), code); /* get record position */
 669           if ^hdr_sw & (ltype ^= 3 | (ltype = 3 & line_count > 26)) then /* if we need a header */
 670                call put_hdr;                                /* put it out */
 671           call ioa_$ioa_switch (liocb_ptr, fmt1 || fmt2 || fmt3, (ltype = 3), fnp_tape,
 672                o_card.call_name, o_card.edit_name, dtype, substr (o_card.ttl_date, 1, 2),
 673                substr (o_card.ttl_date, 3, 2), substr (o_card.ttl_date, 5, 2), lib, id_blk.ident, o_card.model,
 674                id_blk.rev, sstype, list, fnp_tape, (o_card.m_applic = " "), current_key,
 675                addr (rsi.descriptor) -> rs_desc.comp_num, fixed (rel (rsi.record_ptr), 18), rsi.record_length);
 676           line_count = line_count + 1;                      /* increment line count */
 677           if line_count >= 25 then hdr_sw = "0"b;           /* we need a new page header */
 678           if p_blk.p_cnt ^= 0 then                          /* if patches exist... */
 679                call put_patch;                              /* list them too */
 680           if attach_copy then                               /* if we are writing copy tape */
 681                if ltype ^= 3 then                           /* and this is not a catalog record */
 682                     call write_copy;                        /* copy this deck too */
 683 
 684      end update_list;
 685 ^L
 686 
 687 /* put_hdr - internal procedure to output a listing page header */
 688 
 689 put_hdr: proc;
 690 
 691           call ioa_$ioa_switch (liocb_ptr,
 692                "^[^|^]^-^a ^[POL^4s^;^a,^-^a ^2d^[ (cont't)^;^]^],^61tTime - ^a,  Page - ^2d^/",
 693                first_ff, "Library -", fnp_tape, o_card.library, "Tape File Number -", pfile,
 694                cont_sw, time_string, page_no);
 695           call ioa_$ioa_switch (liocb_ptr,
 696                "^a ^[FNP ^a ^a^1s^;^2s^a^] ^a^[^;^71tContents of ^a>tandd_deck_file^]^/",
 697                "Contents of", fnp_tape, fnp_type, "Binary Deck Tape",
 698                "ITR, Firmware And Diagnostic (IFAD) Tape", tape_name, list, dir);
 699           call ioa_$ioa_switch (liocb_ptr, " ^[ call^;     ^]   ^a     ^[^a^2-^s^;^s ^a^2-^]^-^[ ^[^a^]^;^2s      ^a^]",
 700                (o_card.call_name ^= "" & ^fnp_tape), hdra, lib, hdra1, hdra2, list, ^fnp_tape, hdra4, hdra3);
 701           call ioa_$ioa_switch (liocb_ptr, " ^[ N^H__^Ha_^Hm_^He^;     ^]   ^a     ^[^a^s^;^s^a^2-^]^-^[^[^a^]^;^2s    ^a^]^/",
 702                (o_card.call_name ^= "" & ^fnp_tape), hdrb, lib, hdrb1, hdrb2, list, ^fnp_tape, hdrb4, hdrb3);
 703           hdr_sw, cont_sw, first_ff = "1"b;                 /* form feeds no longer inhibited */
 704           line_count = 0;                                   /* reset line counter */
 705           page_no = page_no + 1;                            /* increment listing page number */
 706 
 707      end put_hdr;
 708 
 709 /* put_patch - internal procedure to add patch card images to listing file */
 710 
 711 put_patch: proc;
 712 
 713           if ^hdr_sw then call put_hdr;                     /* if we need a new page header, do it */
 714           call ioa_$ioa_switch (liocb_ptr, "The following patch cards are contained in the above deck:^/");
 715           line_count = line_count + 1;                      /* increment line count */
 716           if line_count >= 25 then call put_hdr;            /* put out header if required */
 717           do i = 1 to p_blk.p_cnt;                          /* output all patches */
 718                call ioa_$ioa_switch (liocb_ptr, "^-^a^/", p_blk.p_card (i));
 719                line_count = line_count + 1;
 720                if line_count >= 25 then call put_hdr;       /* put out header if requeired */
 721           end;
 722           p_blk.p_cnt = 0;                                  /* initialize count */
 723 
 724      end put_patch;
 725 ^L
 726 
 727 /* ck_patch - internal procedure to check a bcd card image for a ligit patch card */
 728 
 729 ck_patch: proc (err_bit);
 730 
 731 dcl  err_bit bit (1);
 732 
 733           call bcd_to_ascii_ (gc_log_rec_bits, err_card);
 734           v_patch = "0"b;                                   /* reset patch flag */
 735           if h_patch.hex = "hex" then                       /* if hex patch */
 736                if o_card.assem = "m" then                   /* and deck produced with mpc assembler */
 737                     if h_patch.cr = "c" | h_patch.cr = "r" then /* for cs or r/w mem */
 738                          if h_patch.lbl = o_card.edit_name then /* if label matches */
 739                               if h_patch.rev = string (id_blk.revision) then /* and rev matches */
 740                                    v_patch = "1"b;          /* valid hex patch */
 741           if ^v_patch then                                  /* if  it wasn't hex patch */
 742                if o_patch.octal = "octal" | o_patch.octal = "mask" then
 743                     v_patch = "1"b;                         /* valid octal patch */
 744           if v_patch then do;                               /* if one of the above */
 745                p_blk.p_cnt = p_blk.p_cnt + 1;               /* increment patch count */
 746                p_blk.p_card (p_blk.p_cnt) = err_card;       /* copy image */
 747           end;
 748           else do;                                          /* not valid patch abort */
 749                call com_err_ (0, pname,
 750                     "BCD card image at record ^d, file ^d is not $ object, $ dkend, or valid patch card:^/""^a""",
 751                     crec, cfile, err_card);
 752                err_bit = "1"b;
 753           end;
 754      end ck_patch;
 755 
 756 /* make_key - int procedure to make up a key for insertion into the deckfile based on object card info */
 757 
 758 make_key: proc;
 759           current_key = "";                                 /* initialize key first */
 760           if fnp_tape then do;                              /* make special key for fnp bin deck tapes */
 761                fnp_key = fnp_key + 1;                       /* increment fnp key number */
 762                current_key = "fnp." || fnp_type || ".pol." || ltrim (char (fnp_key)) || "." ||
 763                     substr (o_card.edit_name, 1, 2);
 764           end;
 765           else if o_card.library = "hmpcj1" then do;        /* if mpc deck */
 766                if id_blk.type ^= "itr" & id_blk.type ^= "mdr" then /* if firmware deck */
 767                     current_key = string (id_blk.type_code) || "."; /* set firmware identification */
 768                else current_key = id_blk.type || ".";       /* itr or mdr */
 769                current_key = rtrim (current_key) || id_blk.ident || "." || o_card.edit_name;
 770                current_key = rtrim (current_key) || "." || id_blk.rev; /* set revision */
 771           end;
 772           else do;                                          /* must be htnd deck */
 773                if o_card.ss_type = "s" then                 /* take care of special cases first */
 774                     current_key = "pas." || substr (o_card.edit_name, 1, 3); /* isolts deck */
 775                else if o_card.ss_type = "u" then            /* utility deck */
 776                     current_key = "utl." || o_card.call_name;
 777                else current_key = o_card.ss_type || "lt." || o_card.call_name; /* most common case */
 778                return;
 779           end;
 780           cata.n_entries = cata.n_entries + 1;              /* increment  number of catalog entries */
 781           cata.key (n_entries) = current_key;               /* and add current entry to catalog */
 782      end make_key;
 783 ^L
 784 
 785 /* insert_deck - int procedure to insert current deck into the T & D deckfile */
 786 
 787 insert_deck: proc (bufp, buf_len, isd_abort);
 788 
 789 dcl  bufp ptr;
 790 dcl  buf_len fixed bin (21);
 791 dcl  isd_abort bit (1);
 792 
 793           isd_abort = "0"b;                                 /* reset abort flag */
 794 reseek:
 795           work_key = current_key;                           /* copy working key */
 796           call iox_$seek_key (fiocb_ptr, work_key, rec_len, code); /* set key for insertion */
 797           if code ^= error_table_$no_record then do;        /* if record already exists */
 798                if code = 0 then do;                         /* check for common itr */
 799                     if index (current_key, ".common.") ^= 0 then /* common itr */
 800                          return;                            /* its already in deckfile */
 801                     call iox_$delete_record (fiocb_ptr, code);
 802                     go to reseek;                           /* try again */
 803                end;
 804                else do;                                     /* some other problem, tell user */
 805                     call com_err_ (code, pname,
 806                          "attempting to seek to record whose key is ""^a""", work_key);
 807                     isd_abort = "1"b;                       /* and abort */
 808                     return;
 809                end;
 810           end;
 811           call iox_$write_record (fiocb_ptr, bufp, buf_len, code); /* write the record */
 812           if code ^= 0 then do;                             /* fatal error */
 813                call com_err_ (code, pname,
 814                     "attempting to write record whose key is ""^a"" to the tandd_deck_file", work_key);
 815                isd_abort = "1"b;                            /* set abort flag */
 816           end;
 817 
 818      end insert_deck;
 819 ^L
 820 
 821 /* ld_fw_deck - procedure to load core image of firmware deck into a segment named "fw.<ident>.<pgm_name>" */
 822 
 823 ld_fw_deck: proc;
 824 
 825           ename = "fw." || id_blk.ident || "." || o_card.edit_name ||
 826                "." || id_blk.rev;                           /* form firmware seg name */
 827           call hcs_$initiate (dir, ename, "", 0, 0, segp, code); /* attempt to initiate seg */
 828           if segp = null then do;                           /* seg does not exist, create it */
 829                call hcs_$make_seg (dir, ename, "", 01010b, segp, code);
 830                if segp = null then do;                      /* error creating segment */
 831                     call com_err_ (code, pname, "Unable to create ^a>^a", dir, ename);
 832                     return;
 833                end;
 834           end;
 835           if patches then
 836                call gload_$allow_zero_checksums (pname, dir, ename,
 837                     bptr, segp, 0, addr (gload_data), code);/* load the core image */
 838           else call gload_ (bptr, segp, 0, addr (gload_data), code); /* load the core image */
 839           if code ^= 0 then do;                             /* loading error */
 840                call com_err_ (code, pname, "^a^/attempting to load core image of ^a>^a",
 841                     gload_data.diagnostic, dir, ename);
 842                return;
 843           end;
 844           call hcs_$set_bc_seg (segp, fixed (gload_data.text_len) * 36, code); /* set bit count of fw seg */
 845           if code ^= 0 then do;                             /* error setting bit count */
 846                call com_err_ (code, pname, "Unable to set bit count of ^a>^a",
 847                     dir, ename);
 848                return;
 849           end;
 850 
 851      end ld_fw_deck;
 852 ^L
 853 
 854 /* ck_applic - int procdure to check for current deck Multics Applicability. If deck is appicable, "1"b is returned */
 855 
 856 ck_applic: proc returns (bit (1));
 857 
 858           if o_card.m_applic ^= " " then do;                /* only take deck if Multics applicable */
 859                if o_card.library = "hmpcj1" then            /* if itr deck */
 860                     if id_blk.type = "itr" then             /* space to nxt file */
 861                          call space_file;                   /* space to nxt file */
 862                     else ;
 863                else if o_card.ss_type = "h" then            /* space over heals files */
 864                     call space_file;                        /* space to nxt file */
 865                return ("0"b);                               /* return false */
 866           end;
 867           else do;                                          /* Multics applicable */
 868                if config_sw then                            /* if tailoring deckfile via current config */
 869                     if ^ck_fig () then                      /* and current deck does not meet requirments */
 870                          return ("0"b);                     /* return false */
 871                if o_card.library = "hmpcj1" then do;        /* if itr, mdr or firmware deck */
 872                     if id_blk.type = "mdr" then             /* if current deck an mdr */
 873                          if firmware_sw then do;
 874                               eot = "1"b;                   /* and we are only loading firmware, thats it */
 875                               return ("0"b);
 876                          end;
 877                          else ;
 878                     else if id_blk.type ^= "itr" then       /* else if firmware deck */
 879                          if ^deckfile_sw then               /* and not just loading deckfile */
 880                               call ld_fw_deck;              /* go load core image for BOS */
 881                     if ^first_deck & ^firmware_sw then do;  /* if first deck of current file */
 882                          cat_build, first_deck = "1"b;      /* set flag so we don't come back */
 883                          cata.n_entries = 0;                /* reset number of catalog entries */
 884                          if id_blk.type = "mdr" then cat_key = "mdr."; /* mdr deck */
 885                          else cat_key = "itr.";             /* itr or fw */
 886                          if id_blk.type = "mdr" then do;    /* if building mdr catalog */
 887                               if o_card.ss_type = "t" then sstype = "tape "; /* tape catalog */
 888                               else if o_card.ss_type = "p" then sstype = "print"; /* printer catalog */
 889                               else if o_card.ss_type = "c" then sstype = "card "; /* card catalog */
 890                               else if o_card.ss_type = "d" then sstype = "disk "; /* disk catalog */
 891                               else do;                      /* unknown type */
 892                                    call com_err_ (0, pname,
 893                                         "Unknown subsystem type (col 23) on $ object card");
 894                                    call com_err_ (0, pname, "Last $ object card image is: ^/""^a""", obj_buf);
 895                                    first_deck = "0"b;       /* check next $ object card */
 896                                    return ("1"b);
 897                               end;
 898                               cat_key = rtrim (cat_key) || sstype; /* complete mdr catalog key */
 899                          end;
 900                     end;
 901                end;
 902           end;
 903           return ("1"b);                                    /* return true */
 904      end ck_applic;
 905 ^L
 906 /* write_copy - subroutine to write current deck to copy tape */
 907 
 908 write_copy: proc;
 909 
 910           if ^first_write then do;                          /* if this is the first time thru, set density */
 911                first_write = "1"b;                          /* set flag so we don't come back */
 912                if cd_sw | denno ^= 0 then do;               /* if user specified density */
 913                     if denno ^= 0 & ^cd_sw then             /* if master tape not standard density */
 914                          cden = density (denno);            /* set copy to same  (if not user specified) */
 915                     call iox_$control (ciocb_ptr, cden, null, code);
 916                end;
 917           end;
 918           prptr = bptr;                                     /* set block ptr to first phy. record */
 919           do while (bin (rel (prptr)) < dlen - 1 & ^eot);   /* wrt entire deck */
 920                c_rtrycnt = 0;                               /* initialize retry count */
 921 retry_cp:
 922                call iox_$write_record (ciocb_ptr, prptr, (bcw.blk_size + 1) * 4, code);
 923                if code ^= 0 then                            /* if error */
 924                     if code = error_table_$tape_error then do; /* if write error */
 925                          c_rtrycnt = c_rtrycnt + 1;         /* increment retry count */
 926                          if c_rtrycnt > 10 then do;         /* exceeded error threshold */
 927                               call iox_$control (ciocb_ptr, "saved_status", addr (t_stat), scode);
 928                               call com_err_ (code, pname,
 929                                    "Tape status = ^4.3b, while writing copy tape after 10 retrys", t_stat);
 930                               eot = "1"b;
 931                          end;
 932                          else do;
 933                               call iox_$control (ciocb_ptr, "backspace_record", null, scode);
 934                               call iox_$control (ciocb_ptr, "erase", null, scode);
 935                               go to retry_cp;
 936                          end;
 937                     end;
 938                     else do;                                /* not a tape error */
 939                          call com_err_ (code, pname, "while writing copy tape");
 940                          eot = "1"b;                        /* set abort flag */
 941                     end;
 942                else prptr = addrel (prptr, currentsize (gc_phy_rec)); /* no error advance to next block */
 943           end;
 944           copy_at_eof = "0"b;                               /* we are no longer at an eof mark */
 945 
 946      end write_copy;
 947 ^L
 948 
 949 /* set_fig - int procedure to set up config parameters for the "-config" option */
 950 
 951 set_fig: proc;
 952 
 953 /* this procedure will be implemented later when new config cards are installed */
 954 
 955      end set_fig;
 956 ^L
 957 
 958 /* ck_fig - internal procedure to check current deck against config parameters */
 959 
 960 ck_fig: proc returns (bit (1));
 961 
 962 /* this procedure will be implemented later when new config cards are installed */
 963 
 964           return ("1"b);
 965 
 966      end ck_fig;
 967 ^L
 968 
 969 /* detach_tape_file - internal procedure to detach and close tape and file */
 970 
 971 detach_tape_file: proc;                                     /* procedure to close and detach tape */
 972           if t_attached then do;
 973                call iox_$close (tiocb_ptr, code);
 974                call iox_$detach_iocb (tiocb_ptr, code);
 975                call release_temp_segments_ (pname, tempp, code); /* release our temp segments */
 976                t_attached = "0"b;
 977           end;
 978           if l_attached then do;
 979                call iox_$close (liocb_ptr, code);
 980                call iox_$detach_iocb (liocb_ptr, code);
 981                l_attached = "0"b;
 982           end;
 983           if f_attached then do;
 984                call iox_$close (fiocb_ptr, code);
 985                call iox_$detach_iocb (fiocb_ptr, code);
 986                f_attached = "0"b;
 987           end;
 988           if c_attached then do;                            /* if copy tape attached */
 989                call iox_$close (ciocb_ptr, code);
 990                call iox_$detach_iocb (ciocb_ptr, code);
 991                c_attached = "0"b;
 992           end;
 993 
 994      end detach_tape_file;
 995 
 996 /* space_file - int procedure to formward space to nxt tape file */
 997 
 998 space_file: proc;
 999 
1000           call iox_$control (tiocb_ptr, "forward_file", null, code);
1001           cfile = cfile + 1;                                /* set correct position */
1002           crec = 0;
1003           one_eof = "1"b;                                   /* set eof flag */
1004 
1005      end space_file;
1006 
1007 /* copy_eof - subroutine to write end of file mark on copy tape */
1008 
1009 copy_eof: proc;
1010 
1011           call iox_$control (ciocb_ptr, "write_eof", null, code);
1012           copy_at_eof = "1"b;                               /* set copy eof flag */
1013 
1014      end copy_eof;
1015 ^L
1016 %include gcos_ssf_records;
1017 %include gload_data;
1018 %include rs_info;
1019 
1020      end load_tandd_library;