1 /****^  ********************************************
   2         *                                          *
   3         * Copyright, (C) Honeywell Bull Inc., 1987 *
   4         *                                          *
   5         ******************************************** */
   6 
   7 
   8 /****^  HISTORY COMMENTS:
   9   1) change(87-05-28,TLNguyen), approve(87-05-28,MCR7692),
  10      audit(87-07-15,Blair), install(87-07-28,MR12.1-1048):
  11      convert read_tape_and_query (rtq) nonstandard subsystem to a standard
  12      ssu_ subsystem.
  13   2) change(87-07-14,TLNguyen), approve(87-07-14,MCR7701),
  14      audit(87-07-15,Blair), install(87-07-28,MR12.1-1048):
  15      bug fixes.
  16   3) change(87-07-14,TLNguyen), approve(87-07-14,MCR7727),
  17      audit(87-07-15,Blair), install(87-07-28,MR12.1-1048):
  18      add two new requests: "eof" and "rif".
  19   4) change(87-07-28,TLNguyen), approve(87-07-28,PBF7701),
  20      audit(87-07-28,Blair), install(87-07-28,MR12.1-1050):
  21      PBF to ID1048:  expand file names'declaration from char (32) to char
  22      (168) and attach output description (specified by -ods) from char (64) to
  23      char (200).
  24                                                    END HISTORY COMMENTS */
  25 
  26 rtq_: proc ();
  27 
  28 /* formated by default */
  29 
  30 /* external entries */
  31           dcl     bcd_to_ascii_          entry (bit (*), char (*));
  32           dcl     comp_8_to_ascii_       entry (bit (*), char (*));
  33           dcl     cv_dec_check_          entry (char (*), fixed bin (35)) returns (fixed bin (35));
  34           dcl     cv_oct_check_          entry (char (*), fixed bin (35)) returns (fixed bin (35));
  35           dcl     date_time_             entry (fixed bin (71), char (*));
  36           dcl     ebcdic_to_ascii_       entry (char (*), char (*));
  37           dcl     ebcdic8_to_ascii_      entry (bit (*), char (*));
  38           dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
  39           dcl     ioa_                   entry options (variable);
  40           dcl     ioa_$rsnnl             entry options (variable);
  41           dcl     iox_$attach_name       entry (char (*), ptr, char (*), ptr, fixed bin (35));
  42           dcl     iox_$close             entry (ptr, fixed bin (35));
  43           dcl     iox_$control           entry (ptr, char (*), ptr, fixed bin (35));
  44           dcl     iox_$detach_iocb       entry (ptr, fixed bin (35));
  45           dcl     iox_$open              entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
  46           dcl     iox_$read_record       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
  47           dcl     iox_$put_chars         entry (ptr, ptr, fixed bin (21), fixed bin (35));
  48           dcl     iox_$write_record      entry (ptr, ptr, fixed bin (21), fixed bin (35));
  49           dcl     iox_$get_line          entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
  50           dcl     pathname_              entry (char (*), char (*)) returns (char (168));
  51           dcl     ssu_$abort_line        entry () options (variable);
  52           dcl     ssu_$abort_subsystem   entry () options (variable);
  53           dcl     ssu_$arg_count         entry (ptr, fixed bin);
  54           dcl     ssu_$arg_ptr           entry (ptr, fixed bin, ptr, fixed bin);
  55           dcl     ssu_$get_subsystem_and_request_name entry (ptr) returns (char (72) var);
  56           dcl     ssu_$print_message     entry () options (variable);
  57 
  58 /* condition */
  59           dcl     (cleanup, conversion, program_interrupt) condition;
  60 
  61 /* builtin */
  62           dcl     (addr, addrel, bin, char, currentsize, divide, fixed, hbound, index, length, ltrim, mod, null, rtrim,
  63                   revert, search, substr, translate, unspec) builtin;
  64 
  65 /* automatic storage */
  66           dcl     BINARY_MODE            fixed bin static options (constant) init (1);
  67           dcl     LABEL                  (0:6) char (9) int static options (constant) init
  68                                          ("unlabeled", "Multics", "Multics", "GCOS", "IBM", "ANSI", "CP5");
  69           dcl     NL                     char (1) int static options (constant) init ("
  70 ");
  71           dcl     NINE_MODE              fixed bin static options (constant) init (3);
  72           dcl     NUMB_OF_CHARS_PER_WORD fixed bin static options (constant) init (4);
  73           dcl     YES_FLG                bit (1) aligned;
  74           dcl     Nargs                  fixed bin;         /* number of input arguments */
  75           dcl     al                     fixed bin;         /* argument length */
  76           dcl     ansid                  bit (1) aligned;   /* ANSI db format */
  77           dcl     ansi_mode              fixed bin;         /* ANSI mode */
  78           dcl     ap                     ptr;               /* argument pointer */
  79           dcl     arg_dex                fixed bin;
  80           dcl     att_desc               char (200);        /* 168 chars for pathname + 32 chars for "vfile_ " */
  81           dcl     attach_desc_output     char (200) varying;
  82           dcl     bcnt                   fixed bin (24);    /* block count */
  83           dcl     binck                  bit (1) aligned;   /* binary card */
  84           dcl     blocksize              fixed bin (35);    /* block size */
  85           dcl     (c_b_a,
  86                   c_c_a,
  87                   c_e_a,
  88                   cont,
  89                   cp5)                   bit (1) aligned;   /* convert bcd; comp8; ebcdic; continuing ; cp5 */
  90           dcl     code                   fixed bin (35);
  91           dcl     dec_sw                 bit (1) aligned;   /* DEC switch */
  92           dcl     direction              bit (1) aligned;
  93           dcl     eoj_card               char (14) static options (constant) init
  94                                          ("$      endjob
  95 ");
  96           dcl     first_record_flg       bit (1) aligned;
  97           dcl     g_label                bit (72) int static options (constant) init /* = "ge  600 btl " in bcd */
  98                                          ("272520200600002022634320"b3);
  99           dcl     gssf                   bit (1) aligned;   /* Gcos standard system format */
 100           dcl     (i, j)                 fixed bin;         /* indices */
 101           dcl     ibm_label              fixed bin int static options (constant) init (4);
 102           dcl     ibmv                   bit (1) aligned;   /* IBM vb format */
 103           dcl     imcv                   bit (1) aligned;   /* suffix name of $ snumb card in Gcos standard format */
 104           dcl     it_cnt                 fixed bin;         /* count it */
 105           dcl     iterations             fixed bin (35);
 106           dcl     l_cnt                  fixed bin (35);    /* loop count */
 107           dcl     l_rec                  bit (1) aligned;   /* logical record */
 108           dcl     l_rec_len              fixed bin (35);    /* logical record length */
 109           dcl     last_record_flg        bit (1) aligned;
 110           dcl     lrp                    ptr;               /* logical record pointer */
 111           dcl     mode                   (3) char (7) int static options (constant) init
 112                                          ("binary", "bcd", "nine");
 113           dcl     mssf                   bit (1) aligned;   /* Multics standard system format */
 114           dcl     nchars                 fixed bin (21);    /* number of characters */
 115           dcl     nnl_sw                 bit (1) aligned;   /* no new line switch */
 116           dcl     n_ops                  fixed bin;         /* number of operations */
 117           dcl     nunits                 fixed bin (35);    /* number of units */
 118           dcl     nwds                   fixed bin (35);    /* number of words to dump */
 119           dcl     open_mode              fixed bin;
 120           dcl     order                  char (16);
 121           dcl     pname                  char (19) int static options (constant) init
 122                                          ("read_tape_and_query");
 123           dcl     rf                     bit (1) aligned;   /* file requests (e.g. bsf, fsf) */
 124           dcl     rpt                    bit (1) aligned;   /* space requests (e.g. bsf, bsr, fsf, fsr) */
 125           dcl     rtq_info_ptr           ptr;
 126           dcl     s_filename             char (32) varying; /* source file name */
 127           dcl     save_status_code       fixed bin (35);
 128           dcl     sci_ptr                ptr;
 129           dcl     scode                  fixed bin (35);
 130           dcl     schar                  fixed bin (35);    /* skip characters */
 131           dcl     spill                  fixed bin (21);
 132           dcl     status_story           char (100) varying;
 133           dcl     t_stat                 bit (12) aligned;  /* tape status */
 134           dcl     temp_logical_rec_len   fixed bin (21);
 135           dcl     time_string            char (24);
 136           dcl     tr_cnt                 fixed bin (35);    /* truncate count */
 137           dcl     trim_trailing_blanks_log_rec_len fixed bin (21);
 138           dcl     trunc_sw               bit (1) aligned;   /* truncate switch */
 139           dcl     who_asked              char (32) varying;
 140 
 141 /* external static */
 142           dcl     (error_table_$end_of_info,
 143                   error_table_$not_closed,
 144                   error_table_$not_detached,
 145                   error_table_$tape_error) fixed bin (35) ext;
 146 
 147           dcl     iox_$user_output ptr ext;
 148           dcl     sys_info$max_seg_size  fixed bin (35) ext static;
 149           dcl     tape_status_table_$tape_status_table_ ext static;
 150 
 151 /* based */
 152           dcl     1 ansi_db_lrec         based (rtq_info.rptr) unaligned, /* template for ansi "DB" formated records */
 153                     2 lrl                char (4),          /* log rec length in ascii chars */
 154                     2 alrd               char (l_rec_len),  /* log rec data */
 155                     2 nxt_lrec           bit (0);           /* to get to nxt record */
 156 
 157           dcl     1 conv_buf             based (lrp),       /* conversion buffer, no logical records */
 158                     2 skip_char          char (schar),      /* characters to skip */
 159                     2 conv_dta           char (rtq_info.rec_len - schar + 1); /* good char data */
 160 
 161           dcl     1 cp5_phy_rec          based (rtq_info.tptr) aligned, /* cp5 standard tape record */
 162                   ( 2 pbs                fixed bin (18) unsigned, /* previous block size */
 163                     2 nky                fixed bin (18) unsigned, /* number of log records in this block */
 164                     2 first              bit (1)) unaligned;/* to get to first log record */
 165 
 166           dcl     1 cp5_log_rec          based (rtq_info.rptr) aligned, /* cp5 variable logical record */
 167                   ( 2 pad1               bit (36),          /* not used - yet */
 168                     2 pad2               fixed bin,         /* ditto */
 169                     2 rlen               fixed bin (18) unsigned, /* size of record in bytes */
 170                     2 cp5_log_rec_data   char (1 refer (cp5_log_rec.rlen))) unaligned; /* data bytes in EBCDIC */
 171 
 172           dcl     1 dec_mult             (it_cnt) based (lrp) aligned, /* convert DEC to Multics word */
 173                   ( 2 first_32           bit (32),          /* first 32 bits */
 174                     2 last_4             bit (4)) unaligned;/* last four bits */
 175 
 176           dcl     1 dec_tape_raw         based (rtq_info.tptr) aligned, /* strange format for DEC tape */
 177                     2 ps_wd              (it_cnt) unaligned,/* pseudo DEC word (40 bits) */
 178                       3 first_32         bit (32),          /* first 32 bits of word */
 179                       3 pad              bit (4),           /* next 4 bits ignored */
 180                       3 last_4           bit (4);           /* last 4 bits */
 181 
 182           dcl     1 ibm_log_rec          based (rtq_info.rptr) unaligned, /* IBM VB log record */
 183                     2 rdw,                                  /* record data word */
 184                       3 pad1             bit (1),
 185                       3 msl              bit (8),           /* most sign. 8 bits of length */
 186                       3 pad2             bit (1),
 187                       3 lsl              bit (8),           /* least sign. 8 bits of length */
 188                       3 pad3             bit (18),
 189                     2 ilrd               char (l_rec_len),  /* ebcdic data */
 190                     2 nxt_lrec           bit (0);           /* to get to nxt log record */
 191 
 192           dcl     1 ibm_phy_rec          based (rtq_info.tptr) aligned, /* IBM VB phy record */
 193                   ( 2 bdw,                                  /* block data word */
 194                       3 pad1             bit (1),
 195                       3 msl              bit (8),           /* most sign. 8 bits of length */
 196                       3 pad2             bit (1),
 197                       3 lsl              bit (8),           /* least sign. 8 bits of length */
 198                       3 pad3             bit (18),
 199                     2 iprd               char (blocksize - 4)) unaligned;
 200 
 201           dcl     1 lrec_cbuf            based (lrp),       /* logical record template */
 202                     2 skip_char          char (schar),
 203                     2 chcv_buf           (it_cnt) char (l_rec_len);
 204 
 205           dcl     1 mult                 based (rtq_info.tptr) unaligned,
 206                     2 lab_id             bit (36),          /* this will be 670314355245 in octal */
 207                     2 pad                (7) bit (36),      /* we ignore this */
 208                     2 vol_info           like volume_identifier; /* mstr.incl.pl1 must be included */
 209 
 210           dcl     1 gcos                 based (rtq_info.tptr) unaligned,
 211                     2 lab_id             bit (72),          /* this will be "GE  600 BTL " in bcd */
 212                     2 pad                bit (36),          /* we ignore this */
 213                     2 vol_id             bit (36);          /* this is in bcd */
 214 
 215           dcl     1 ibm_ansi             based (rtq_info.tptr) unaligned, /* IBM or ANSI label structure */
 216                     2 lab_id             bit (32),          /* this will be "VOL1" in ebcdic or 8 bit ascii */
 217                     2 vol_id             bit (48);          /* this is in ebcdic or 8 bit ascii */
 218 
 219           dcl     1 cp5_lab              based (rtq_info.tptr) unaligned, /* CP5 label structure */
 220                     2 lab_id             bit (32),          /* This will be ":LBL" in 8 bit ebcdic */
 221                     2 vol_id             bit (32);          /* this is 8 bit ebcdic */
 222 
 223           dcl     arg                    char (al) based (ap);
 224 
 225           dcl     bit_buf                bit (rtq_info.bits) based (rtq_info.tptr); /* tape buffer in bits pointed by tape pointer */
 226 
 227           dcl     char_buf               char (rtq_info.rec_len) based (rtq_info.tptr); /* tape buffer in characters pointed by tape pointer */
 228 
 229           dcl     cdkbuf                 char (136) based (rtq_info.cdkp);
 230 
 231           dcl     cbuf                   char (rtq_info.buf_size) based (rtq_info.cbufp);
 232 
 233           dcl     cv_buf                 char (rtq_info.cvbl) based (rtq_info.cvbp);
 234 
 235           dcl     gssf_ascii             char (gc_log_rec.rcw.rsize * 4) based (rtq_info.cvp);
 236 
 237           dcl     lab_buf                char (rtq_info.rec_len) based (rtq_info.lblp);
 238 
 239           dcl     mult_move              char (rtq_info.clen) based;
 240 
 241           dcl     1 rtq_info             aligned like rtq_structure_info based (rtq_info_ptr);
 242 
 243           dcl     rtq_area               area based (rtq_info.rtq_area_ptr);
 244 
 245           dcl     sentinel               char (4) based (rtq_info.lblp);
 246 
 247 /* like statement */
 248           dcl     1 ai                   like area_info aligned;
 249 
 250 /***************************************************************************/
 251 %page;
 252 set_up: entry (sci_ptr, rtq_info_ptr, code);
 253 
 254 /*   initiate variables and area info block.  Establish                    */
 255 /*   cleanup and program_interrupt conditions.  Get an area and save its   */
 256 /*   pointer.  Get temporary segments for rtq subsubsystem.  Attach and    */
 257 /*   open tape using the "tape_nstd_" i/o module.  Set conversion buffer   */
 258 /*   to maximum size.  Determine an user's density.  If the density is     */
 259 /*   valid then report to an user and determine the tape types.  Report    */
 260 /*   the tape type to users.  Invoke "check_mode" internal procedure if    */
 261 /*   the tape type is either IBM label or ANSI label.  Perform the         */
 262 /*   "forward_record" control order to the HDR2 label record and read it   */
 263 /*   in by invoking "read_tape_record" internal procedure.  Check the      */
 264 /*   input/output eof argument value.  If not end of file then report to   */
 265 /*   users and invoke the "valid_label_record".  Report to user, perform   */
 266 /*   the "forward_file" control order and return.  If end of file          */
 267 /*   encountered, report to users, perform the "rewind" control order and  */
 268 /*   return.  If the given density is invalid then set the density to the  */
 269 /*   default density, report to users, and return.                         */
 270 
 271 /*   constant */
 272           dcl     NUMB_OF_BITS_PER_BYTE  fixed bin static options (constant) init (9);
 273           dcl     NUMB_OF_BYTES_PER_WORD fixed bin static options (constant) init (4);
 274           dcl     CP5_label              bit (32) int static options (constant) init /* ":LBL" in 8 bit ebcdic */
 275                                          ("72D3C2D3"b4);
 276 
 277           dcl     a_label                bit (32) int static options (constant) init /* "VOL1" in 8 bit ascii (ansi stand label) */
 278                                          ("564F4C31"b4);
 279 
 280           dcl     ansi_label             fixed bin int static options (constant) init (5);
 281           dcl     cp5_label              fixed bin int static options (constant) init (6);
 282           dcl     i_label                bit (32) int static options (constant) init /* "VOL1" in 8 bit ebcdic (ibm stand label) */
 283                                          ("E5D6D3F1"b4);
 284 
 285           dcl     (v1_mult_label         init (1),
 286                   v3_mult_label          init (2)) fixed bin int static options (constant);
 287 
 288 /* automatic storage */
 289           dcl     get_line_length        fixed bin;
 290           dcl     rcd_volid              char (32);
 291           dcl     terminate_read_sw      bit (1);
 292 
 293 /* base */
 294           dcl     blab                   (0:15) bit (9) unaligned based (addr (rcd_volid));
 295 
 296 /*   external entry */
 297           dcl     define_area_           entry (ptr, fixed bin (35));
 298           dcl     get_temp_segment_      entry (char (*), ptr, fixed bin (35));
 299           dcl     get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
 300 
 301 
 302 /* begin coding */
 303           mssf = "0"b;                                      /* initialize Multics standard system format flag */
 304           rcd_volid = "";
 305           unspec (ai) = "0"b;                               /* clear out area info */
 306           ai.version = area_info_version_1;                 /* set up area info block */
 307           ai.control.extend = "1"b;
 308           ai.control.zero_on_alloc = "1"b;
 309           ai.owner = pname;
 310           ai.size = sys_info$max_seg_size;
 311           ai.version_of_area = area_info_version_1;
 312           ai.areap = null;
 313 
 314 /* set up clean up handler */
 315           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
 316 
 317 /* establish program_interrupt (pi) handler */
 318           on program_interrupt goto SET_UP_EXIT;
 319 
 320 /* find terminal line length */
 321           get_line_length = get_line_length_$switch (null, scode);
 322           if get_line_length < 118 & scode = 0 then
 323                rtq_info.short_output_flg = "1"b;            /* set short output switch */
 324           else rtq_info.short_output_flg = "0"b;            /* otherwise long output */
 325 
 326 /* get an area */
 327           call define_area_ (addr (ai), code);
 328           if code ^= 0 then do;
 329                     call ssu_$print_message (sci_ptr, code, "Cannot define an area");
 330                     return;
 331                end;
 332 
 333           rtq_info.rtq_area_ptr = ai.areap;
 334 
 335 /* get a temporary segment for our tape buffer */
 336           call get_temp_segment_ (pname, rtq_info.tptr, code);
 337           if code ^= 0 then do;                             /* can't alocate buffer */
 338                     call ssu_$print_message (sci_ptr, code, "Getting temporary tape buffer segment");
 339                     call detach_tape_file (sci_ptr, rtq_info_ptr);
 340                     return;
 341                end;
 342 
 343 
 344 /* allocate intermediate buffers */
 345           allocate cv_buf in (rtq_area);
 346           allocate cdkbuf in (rtq_area);
 347           allocate cbuf in (rtq_area);
 348 
 349 /* attach and open tape using the "tape_nstd_" io module */
 350 TRY_AGAIN:
 351           call iox_$attach_name ("tape_sw", rtq_info.tiocb_ptr, (rtq_info.tape_atd), null, code);
 352           if code ^= 0 then do;
 353                     if code = error_table_$not_detached then do;
 354                               call iox_$detach_iocb (rtq_info.tiocb_ptr, code);
 355                               if code ^= error_table_$not_closed then do;
 356                                         call ssu_$print_message (sci_ptr, code);
 357                                         return;
 358                                    end;
 359                               else do;
 360                                         call iox_$close (rtq_info.tiocb_ptr, (0));
 361                                         goto TRY_AGAIN;
 362                                    end;
 363                          end;
 364                     else do;
 365                               call ssu_$print_message (sci_ptr, code, "^/ Attempting to attach tape.");
 366                               call detach_tape_file (sci_ptr, rtq_info_ptr); /* go cleanup */
 367                               return;
 368                          end;
 369                end;
 370 
 371           call iox_$open (rtq_info.tiocb_ptr, Sequential_input, "0"b, code); /* open for seq. input */
 372           if code ^= 0 then do;
 373                     call ssu_$print_message (sci_ptr, code, "^/Opening tape for sequential input");
 374                     call detach_tape_file (sci_ptr, rtq_info_ptr);
 375                     return;
 376                end;
 377 
 378 /* set conversion buffer to max size */
 379           rtq_info.cvbl = divide (rtq_info.buf_size * NUMB_OF_BITS_PER_BYTE, NUMB_OF_BYTES_PER_WORD, 21, 0);
 380 
 381 /* loop through the array index from 1 to 5 to find the matched density value if an user specifies a density value */
 382           j = hbound (rtq_info.density, 1);
 383           terminate_read_sw = "0"b;
 384           do i = 1 to j while (^terminate_read_sw);
 385                call iox_$control (rtq_info.tiocb_ptr, (rtq_info.density (i)), null, scode);
 386                if scode = 0 then do;
 387                          call iox_$read_record (rtq_info.tiocb_ptr, rtq_info.tptr, rtq_info.buf_size, rtq_info.rec_len, code);
 388                          if code ^= error_table_$tape_error then do; /* if some other type of error, then warn users */
 389                                    if (code ^= 0) & (code ^= error_table_$end_of_info) then
 390                                         call ssu_$print_message (sci_ptr, code, "^/Attempting to determine density of tape volume ^a", rtq_info.tape_name);
 391 
 392                                    terminate_read_sw = "1"b;/* set terminate condition */
 393                               end;
 394                          call iox_$control (rtq_info.tiocb_ptr, "rewind", null, scode);
 395                     end;                                    /* scode = 0 */
 396           end;                                              /* do i = 1 to 5 */
 397 
 398 /* use the default density if could not find the valid density; otherwise, get it */
 399           rtq_info.tmr = terminate_read_sw;
 400 
 401           if ^rtq_info.tmr | (code ^= 0 & code ^= error_table_$end_of_info) then do;
 402                     if rtq_info.ddec ^= 0 then rtq_info.c_den = "d" || ltrim (char (rtq_info.ddec)); /* if density was specified.. */
 403                     else rtq_info.c_den = rtq_info.density (1); /* otherwise use default */
 404                                                             /* perform a density control order on an i/o switch */
 405                     call iox_$control (rtq_info.tiocb_ptr, (rtq_info.c_den), null, scode);
 406                                                             /* display a warning message */
 407                     call ssu_$print_message (sci_ptr, 0,
 408                          "Unable to determine density of tape volume ^a.^/     Density is currently set to ^a (bpi).",
 409                          rtq_info.tape_name, substr (rtq_info.c_den, 2));
 410 
 411                     code = 0;
 412                     scode = 0;                              /* since it is not an error, so want to continue */
 413                end;
 414 
 415 /* report the density to users and determine the tape label types */
 416           else do;
 417                     rtq_info.c_den = rtq_info.density (i - 1); /* save current density */
 418 
 419                     call ioa_ ("Tape density is ^a bpi", substr (rtq_info.density (i - 1), 2));
 420 
 421                     call determine_tape_label_types;
 422 
 423                     if rtq_info.return_subsys_loop_flg then do;
 424                               rtq_info.return_subsys_loop_flg = "0"b;
 425                               return;
 426                          end;
 427                end;
 428 
 429 SET_UP_EXIT:
 430 
 431           return;
 432 
 433 
 434 /***************************************************************************/
 435 %page;
 436 bof_request: entry (sci_ptr, rtq_info_ptr);
 437 
 438 /* Establish cleanup and program_interrupt conditions.  Invoke the         */
 439 /* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
 440 /* message if users specify any control arguments.  Invoke the             */
 441 /* "process_control_order" internal procedure to the beginning of the file */
 442 
 443 /* begin coding */
 444           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
 445 
 446           on program_interrupt goto BOF_EXIT;
 447 
 448           call ssu_$arg_count (sci_ptr, Nargs);
 449           if Nargs ^= 0 then do;
 450                     call ssu_$print_message (sci_ptr, 0, "Usage:  bof");
 451                     return;
 452                end;
 453 
 454 /* initialization */
 455           scode = 0;
 456           l_cnt = 1;
 457           rf, rpt = "1"b;
 458           direction = "0"b;
 459           order = "begin_file";
 460 
 461 /* process control order */
 462           call process_control_order (order, rpt, direction, rf, l_cnt);
 463 
 464 BOF_EXIT:
 465           return;
 466 
 467 /***************************************************************************/
 468 %page;
 469 bsf_request: entry (sci_ptr, rtq_info_ptr);
 470 
 471 /* Establish cleanup and program_interrupt handlers.  Invoke the           */
 472 /* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
 473 /* message if users specify two or more control arguments.                 */
 474 /* Process the specified control argument.  Invoke the                     */
 475 /* "process_control_order" internal procedure to backspace N files.        */
 476 /* The default is to backspace 1 file.                                     */
 477 
 478 /* begin coding */
 479           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
 480 
 481           on program_interrupt goto BSF_EXIT;
 482 
 483 /* initialization */
 484           l_cnt = 1;
 485           scode = 0;
 486           rf, rpt = "1"b;
 487           direction = "0"b;
 488           order = "backspace_file";
 489 
 490 /* find number of input arguments */
 491           call ssu_$arg_count (sci_ptr, Nargs);
 492           if Nargs >= 2 then do;
 493 ERROR_BSF:
 494                     call ssu_$print_message (sci_ptr, scode, "^/     Usage:  bsf {n}");
 495                     return;
 496                end;
 497 
 498 /* then validate them */
 499           do arg_dex = 1 to Nargs;
 500                call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
 501                l_cnt = cv_dec_check_ (arg, scode);
 502                if scode ^= 0 then goto ERROR_BSF;
 503           end;
 504 
 505 /* go process control order */
 506           call process_control_order (order, rpt, direction, rf, l_cnt);
 507 
 508 /* must reset the flag fields of the "rtq_info" structure before returning to rtq request loop */
 509           rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;
 510 
 511 BSF_EXIT:
 512           return;
 513 
 514 /***************************************************************************/
 515 %page;
 516 bsr_request: entry (sci_ptr, rtq_info_ptr);
 517 
 518 /* Establish cleanup and program_interrupt handlers.  Invoke the           */
 519 /* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
 520 /* message if users specify two or more 2 control arguments.               */
 521 /* Process the specified control argument.  Invoke the                     */
 522 /* "process_control_order" internal procedure to backspace N records.      */
 523 /* The default is to backspace 1 record.                                   */
 524 
 525 /* begin coding */
 526           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
 527 
 528           on program_interrupt goto BSR_EXIT;
 529 
 530 /* initialization */
 531           l_cnt = 1;
 532           scode = 0;
 533           rpt = "1"b;
 534           rf, direction = "0"b;
 535           order = "backspace_record";
 536 
 537 /* find number of input arguments */
 538           call ssu_$arg_count (sci_ptr, Nargs);
 539           if Nargs >= 2 then do;
 540 ERROR_BSR:
 541                     call ssu_$print_message (sci_ptr, scode, "Usage:  bsr {N}");
 542                     return;
 543                end;
 544 
 545 /* then validate them */
 546           do arg_dex = 1 to Nargs;
 547                call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
 548                l_cnt = cv_dec_check_ (arg, scode);
 549                if scode ^= 0 then goto ERROR_BSR;
 550                else ;
 551           end;
 552 
 553 /* go process control order */
 554           call process_control_order (order, rpt, direction, rf, l_cnt);
 555 
 556 BSR_EXIT:
 557           return;
 558 
 559 /***************************************************************************/
 560 
 561 %page;
 562 density_request: entry (sci_ptr, rtq_info_ptr);
 563 
 564 /* Establish cleanup and program_interrupt handlers.  Invoke the           */
 565 /* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
 566 /* message if users specify no CA or two or more control arguments.        */
 567 /* Validate the control argument which is the density.  Display an usage   */
 568 /* message for the invalid density.  Otherwise, invoke the                 */
 569 /* "process_control_order" internal procedure to perform the specified     */
 570 /* density control order.                                                  */
 571 
 572 
 573           dcl     array_index            fixed bin;
 574           dcl     match                  bit (1) aligned;
 575 
 576 /* begin coding */
 577           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
 578 
 579           on program_interrupt goto DENSITY_EXIT;
 580 
 581 /* initialization */
 582           l_cnt = 1;
 583           match = "0"b;
 584           scode = 0;
 585           rpt, rf, direction = "0"b;                        /* reset command flags */
 586 
 587 /* find the number of input arguments */
 588           call ssu_$arg_count (sci_ptr, Nargs);
 589           if Nargs = 0 | Nargs >= 2 then do;
 590 ERROR_DENSITY:
 591                     call ssu_$print_message (sci_ptr, scode, "Usage:  density (den) <6250 | 1600 | 800 | 556 | 200>");
 592                     return;
 593                end;
 594 
 595 /* then validate the tape density */
 596           call ssu_$arg_ptr (sci_ptr, Nargs, ap, al);
 597           do array_index = 1 to 5 while (^match);
 598                if arg = substr (rtq_info.density (array_index), 2, 4) then
 599                     match = "1"b;
 600           end;
 601           if ^match then
 602                goto ERROR_DENSITY;
 603           else do;
 604                     rtq_info.ddec = cv_dec_check_ (arg, scode);
 605                     if scode ^= 0 then goto ERROR_DENSITY;
 606                     else rtq_info.c_den, order = "d" || ltrim (char (rtq_info.ddec));
 607                end;
 608 
 609 /* go process control order */
 610           call process_control_order (order, rpt, direction, rf, l_cnt);
 611 
 612 DENSITY_EXIT:
 613 
 614           return;
 615 
 616 /***************************************************************************/
 617 %page;
 618 dot_request: entry (sci_ptr, rtq_info_ptr);
 619 
 620 /* displays the request name read_tape_and_query with its short name, rtq, */
 621 /* in parentheses.                                                         */
 622 
 623 /* begin coding */
 624           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
 625 
 626           on program_interrupt goto RETURNS_TO_SUBSYS;
 627 
 628 /* find number of input arguments */
 629           call ssu_$arg_count (sci_ptr, Nargs);
 630           if Nargs ^= 0 then do;
 631                     call ssu_$print_message (sci_ptr, 0, "No argument is allowed for this request.");
 632                     return;
 633                end;
 634 
 635 /* response to user's request */
 636           call ioa_ ("read_tape_and_query (rtq):  Reading tape volume ""^a"" in ""^a"" mode.^/                            Currently positioned to Physical file ^d, record ^d.",
 637                rtq_info.tape_name, mode (rtq_info.c_mode), rtq_info.c_file, rtq_info.c_rec);
 638 
 639 RETURNS_TO_SUBSYS:
 640 
 641           return;
 642 
 643 /***************************************************************************/
 644 %page;
 645 dump_record_request: entry (sci_ptr, rtq_info_ptr);
 646 
 647 /* Establish cleanup and program_interrupt handlers.  Initialize           */
 648 /* intermediate variables.  Get optional control arguments and process     */
 649 /* them by invoking the "set_dump_fmt" internal procedure.                 */
 650 /* Dump the tape record in the requested format by invoking the            */
 651 /* "dump_segment_" standard system subroutine.                             */
 652 
 653 /* external entry */
 654           dcl     dump_segment_          entry (ptr, ptr, fixed bin, fixed bin (35), fixed bin (35), bit (*));
 655 
 656 /* automatic storage */
 657           dcl     NUMB_OF_BITS_PER_CHAR  fixed bin static options (constant) init (9);
 658           dcl     NUMB_OF_BITS_PER_WORD  fixed bin static options (constant) init (36);
 659           dcl     doffset                fixed bin;         /* dump off set */
 660           dcl     dump_index             fixed bin;
 661           dcl     format                 (4) bit (11);
 662           dcl     n_words_specified_flg  bit (1) aligned;
 663           dcl     ndumps                 fixed bin;         /* number of dumps */
 664           dcl     offset_specified_flg   bit (1) aligned;
 665 
 666 /* begin coding */
 667           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
 668 
 669           on program_interrupt goto WANTS_TO_EXIT;
 670 
 671 /* validate data */
 672           if ^rtq_info.buf_ful then do;                     /* we don't have any data yet */
 673                     call ssu_$print_message (sci_ptr, 0, "Record buffer empty");
 674                     return;
 675                end;
 676 
 677 /* set up for dump request */
 678           scode = 0;
 679           ndumps = 1;                                       /* set defaults first (entire buffer in octal format) */
 680           doffset = 0;
 681           format (1) = "01000000000"b;
 682           nwds = divide (rtq_info.rec_len * NUMB_OF_BITS_PER_CHAR + 35, NUMB_OF_BITS_PER_WORD, 35, 0);
 683           offset_specified_flg, n_words_specified_flg = "0"b;
 684 
 685 /* find number of arguments */
 686           call ssu_$arg_count (sci_ptr, Nargs);
 687 
 688 /* then validate them */
 689           do arg_dex = 1 to Nargs;                          /* user specifies some input args */
 690                call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);/* process each argument */
 691                if substr (arg, 1, 1) ^= "-" then do;        /* some number spec */
 692 
 693                          if ^offset_specified_flg then do;  /* offset spec must be first */
 694                                    offset_specified_flg = "1"b; /* set switch so we don't come back */
 695                                    doffset = cv_oct_check_ (arg, scode); /* convert ascii to oct */
 696                                    if scode ^= 0 then do;
 697 ERROR_DUMP:
 698                                              call ssu_$print_message (sci_ptr, scode,
 699                                                   "^/     Usage:  dump {offset (oct)} {n_words (oct)} {-bcd} {-ascii} {-ebcdic} {-hex}");
 700                                              return;
 701                                         end;
 702 
 703                                    nwds = nwds - doffset;   /* correct number of words to dump */
 704                               end;                          /* if ^offset_specified_flg then do */
 705 
 706                          else if ^n_words_specified_flg then do; /* user wants to specify number of words */
 707                                    n_words_specified_flg = "1"b; /* set switch so we won't be back */
 708                                    nwds = cv_oct_check_ (arg, scode);
 709                                    if scode ^= 0 then goto ERROR_DUMP; /* tell user what to do, he goofed */
 710                               end;                          /* else if ^n_words_specified_flg */
 711 
 712                          else goto ERROR_DUMP;              /* ditto */
 713                     end;                                    /* if substr (arg, 1, 1) ^= "-"  */
 714 
 715                else if arg = "-bcd" then /* requesting bcd dump */
 716                     call set_dump_fmt ("01010000000"b);
 717 
 718                else if arg = "-ascii" then /* user requesting ascii dump */
 719                     call set_dump_fmt ("01001000000"b);
 720 
 721                else if arg = "-ebcdic" then do;             /* user wants ebcdic dump */
 722                          if rtq_info.c_mode = 3 then /* if in 9 bit mode */
 723                               call set_dump_fmt ("01000010000"b);
 724                          else call set_dump_fmt ("01000001000"b); /* else 8 bit mode */
 725                     end;
 726 
 727                else if arg = "-hex" then do;                /* user wants hex dump */
 728                          if rtq_info.c_mode = 3 then /* if in 9 bit mode */
 729                               call set_dump_fmt ("01000000001"b);
 730                          else call set_dump_fmt ("01000000010"b); /* else 8 bit mode */
 731                     end;
 732 
 733                else goto ERROR_DUMP;                        /* user goofed tell him how to use dump request */
 734           end;                                              /* do arg_dex = 1 to Nargs */
 735 
 736           if ndumps > 1 then ndumps = ndumps - 1;           /* correct number of dumps */
 737 
 738           do dump_index = 1 to ndumps;                      /* dump requested number of formats */
 739                call ioa_ (" ");
 740                call dump_segment_ (iox_$user_output, addrel (rtq_info.tptr, doffset), 0, 0, nwds, format (dump_index));
 741           end;
 742 
 743 WANTS_TO_EXIT:
 744 
 745           return;
 746 
 747 
 748 
 749 set_dump_fmt: proc (fmt);
 750 
 751 /* sets dump type */
 752 
 753           dcl     fmt                    bit (11);
 754 
 755 /* begin coding */
 756           format (ndumps) = fmt;                            /* set desired format */
 757           ndumps = ndumps + 1;                              /* increment number of dumps to do */
 758 
 759           if ndumps > (hbound (format, 1) + 1) then /* user wants to many */
 760                goto ERROR_DUMP;                             /* tell him what he can do */
 761 
 762      end set_dump_fmt;
 763 
 764 /***************************************************************************/
 765 %page;
 766 eof_request: entry (sci_ptr, rtq_info_ptr);
 767 
 768 /* positions to the end of the current physical tape file, after the last   */
 769 /* record.  Establish cleanup and program_interrupt handlers.  No           */
 770 /* optional control arguments are allowed.  Perform "forward_record"        */
 771 /* control orders until end of file encountered.  Note that the current     */
 772 /* record is incremented by one until end of file reached.                  */
 773 /* Then perform "backspace_record" order to position before end of file     */
 774 /* mark since the last forward record order positioned the tape after end   */
 775 /* of file mark.  Report to users after the request is successfully done.   */
 776 
 777 /* begin coding */
 778           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
 779 
 780           on program_interrupt goto SUBSYSTEM_RETURNED;
 781 
 782 /* display an error message if any optional control argument is specified */
 783           call ssu_$arg_count (sci_ptr, Nargs);
 784 
 785           if Nargs ^= 0 then do;
 786                     call ssu_$print_message (sci_ptr, 0, "Usage:  eof");
 787                     return;
 788                end;
 789 
 790 /* initialization */
 791           rtq_info.eof_request_flg = "1"b;
 792           scode = 0;
 793           order = "forward_record";
 794           rpt = "1"b;
 795           direction = "1"b;
 796           rf = "0"b;
 797           l_cnt = 1;
 798 
 799 /* perform several "forward_record" orders until end of current file reached */
 800           do while (scode ^= error_table_$end_of_info);
 801                call process_control_order (order, rpt, direction, rf, l_cnt);
 802 
 803                if scode = 0 then
 804                     rtq_info.c_rec = rtq_info.c_rec + 1;    /* to find the last record in the current file */
 805 
 806                if scode = error_table_$tape_error then do;  /* exit loop if tape error occured */
 807                          call ssu_$print_message (sci_ptr, scode,
 808                               "Attempting to perform ""forward_record"" order");
 809                          rtq_info.eof_request_flg = "0"b;
 810                          return;
 811                     end;
 812           end;
 813 
 814 /* perform the "backspace_record" control order to position to the end of the current file */
 815           direction = "0"b;                                 /* must reset intermediate variables */
 816           rpt = "0"b;
 817           rf = "0"b;
 818           l_cnt = 1;
 819           order = "backspace_record";
 820 
 821           call process_control_order (order, rpt, direction, rf, l_cnt);
 822 
 823 /* report to users after the "eof" request is successfully done */
 824           if rtq_info.c_rec = 1 then
 825                /* case of an empty file or a file has no data record */
 826                call ssu_$print_message (sci_ptr, 0,
 827                     "Positioned the tape to the beginning of the current file # ^d which has no data record.", rtq_info.c_file);
 828 
 829 /* case of a file contains 1 data record or more */
 830           else call ssu_$print_message (sci_ptr, 0,
 831                     "Positioned the tape to the end of the current file # ^d, after the last record # ^d.",
 832                     rtq_info.c_file, rtq_info.c_rec - 1);
 833 
 834           rtq_info.one_eof = "0"b;                          /* must reset these flags before returning to rtq request loop */
 835           rtq_info.eof_request_flg = "0"b;
 836 
 837 SUBSYSTEM_RETURNED:
 838           return;
 839 
 840 /****************************************************************************/
 841 %page;
 842 fsf_request: entry (sci_ptr, rtq_info_ptr);
 843 
 844 /* Establish cleanup and program_interrupt handlers.  Invoke the           */
 845 /* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
 846 /* message if users specify at least 2 control arguments.                  */
 847 /* Process the specified control argument.  Invoke the                     */
 848 /* "process_control_order" internal procedure to forward space N files.    */
 849 /* The default is to forward space 1 file.                                 */
 850 
 851 /* begin coding */
 852           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
 853 
 854           on program_interrupt goto RETURNS_TO_REQUEST_LOOP;
 855 
 856 /* initialization */
 857           scode = 0;
 858           l_cnt = 1;
 859           direction, rpt, rf = "1"b;
 860           order = "forward_file";
 861 
 862 /* find number of input arguments */
 863           call ssu_$arg_count (sci_ptr, Nargs);
 864           if Nargs >= 2 then do;
 865 ERROR_FSF:
 866                     call ssu_$print_message (sci_ptr, scode, "Usage:  fsf {N}");
 867                     return;
 868                end;
 869 
 870 /* then validate them */
 871           do arg_dex = 1 to Nargs;
 872                call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
 873                l_cnt = cv_dec_check_ (arg, scode);
 874                if scode ^= 0 then goto ERROR_FSF;
 875                else ;
 876           end;
 877 
 878 /* go process control order */
 879           call process_control_order (order, rpt, direction, rf, l_cnt);
 880 
 881 RETURNS_TO_REQUEST_LOOP:
 882 
 883           return;
 884 
 885 /*****************************************************************************/
 886 %page;
 887 fsr_request: entry (sci_ptr, rtq_info_ptr);
 888 
 889 /* Establish cleanup and program_interrupt handlers.  Invoke the           */
 890 /* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
 891 /* message if users specify more than one control arguments.               */
 892 /* Process the specified control argument.  Invoke the                     */
 893 /* "process_control_order" internal procedure to forward space N record.   */
 894 /* The default is to forward space 1 record.                               */
 895 
 896 /* begin coding */
 897           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); /* set up clean up handler */
 898 
 899           on program_interrupt goto FSR_RETURN;
 900 
 901 /* initialization */
 902           scode = 0;
 903           l_cnt = 1;
 904           direction, rpt = "1"b;
 905           rf = "0"b;
 906           order = "forward_record";
 907 
 908 /* find number of input arguments */
 909           call ssu_$arg_count (sci_ptr, Nargs);
 910           if Nargs >= 2 then do;
 911 ERROR_FSR:
 912                     call ssu_$print_message (sci_ptr, scode, "Usage:  fsr {N}");
 913                     return;
 914                end;
 915 
 916 /* then validate them */
 917           do arg_dex = 1 to Nargs;
 918                call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
 919                l_cnt = cv_dec_check_ (arg, scode);
 920                if scode ^= 0 then goto ERROR_FSR;
 921                else ;
 922           end;
 923 
 924 /* go process control order */
 925           call process_control_order (order, rpt, direction, rf, l_cnt);
 926 
 927 FSR_RETURN:
 928           return;
 929 
 930 /*****************************************************************************/
 931 %page;
 932 list_tape_contents: entry (sci_ptr, rtq_info_ptr);
 933 
 934 /* Establish cleanup and program_interrupt handlers.  Initialize both        */
 935 /* intermediate global and local variables.  Find terminal line length.      */
 936 /* Get optional control arguments and process them.  Position tape to the    */
 937 /* beginning of tape if not already there.  If the tape type is either       */
 938 /* MULTICS or GCOS tape then set mode to binary mode.  Set to nine mode for  */
 939 /* IBM or ANSI tape.  Report the mode to users.  Read in each tape record in */
 940 /* the tape until end of tape is encountered:  this can be done by invoking  */
 941 /* the "read_tape_record" internal procedure.  Set up nessary things if      */
 942 /* want to return to subsystem request loop.  If not end of file then if     */
 943 /* this is the first record of the file then report the current file read to */
 944 /* users.  Determine the record type.  If the record read is not a label     */
 945 /* record then if the record read is the first record of the file then       */
 946 /* assign the number of bits to last record length, reset the number of      */
 947 /* records to zero, and increment logical file number by one.  Report to     */
 948 /* users if tape type is a label tape or Multics tape.  If the number of     */
 949 /* bits of the record read is the same as the last record length then        */
 950 /* increment the number of record by one.  Otherwise, report to users.       */
 951 /* If the record read is a nonlabel record then assign zero to the last      */
 952 /* record length.  If end of file is encountered then report to user, reset  */
 953 /* record number and logical file flag and set up appropriate mode for the   */
 954 /* next file to be read.  When end of tape is encountered, perform the       */
 955 /* "rewind" control order to the beginning of tape and then report to users. */
 956 
 957           dcl     logical_file_num       fixed bin;
 958           dcl     label_flg              bit (1) aligned;
 959           dcl     last_length            fixed bin;
 960           dcl     logical_file_flg       bit (1) aligned;
 961           dcl     long_list_flg          bit (1) aligned;
 962           dcl     nrecords               fixed bin (35);
 963           dcl     unlabeled              fixed bin int static options (constant) init (0);
 964 
 965 /* begin coding */
 966           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
 967 
 968           on program_interrupt goto SUBSYSTEM_REQUEST_LOOP;
 969 
 970 /* clear global switches */
 971           scode = 0;
 972           mssf = "0"b;
 973           iterations = 1;                                   /* set default iterations to 1 */
 974           rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.set_bin, rtq_info.set_nine, rtq_info.two_eofs = "0"b;
 975 
 976 /* initialize local flags and variables */
 977           long_list_flg, label_flg, logical_file_flg = "0"b;
 978           logical_file_num, last_length, nrecords = 0;
 979 
 980 /* find number of input arguments */
 981           call ssu_$arg_count (sci_ptr, Nargs);
 982 
 983 /* process optional control arguments */
 984           do arg_dex = 1 to Nargs;
 985                call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);/* process them */
 986 
 987                if arg = "-long" | arg = "-lg" then long_list_flg = "1"b; /* user wants long list */
 988 
 989                else if arg = "-label" | arg = "-lbl" then
 990                     if rtq_info.l_type = unlabeled then do; /* illegal on unlabeled tapes */
 991                               call ssu_$print_message (sci_ptr, 0, """-label"" argument not allowed on unlabeled tapes");
 992                               return;
 993                          end;
 994                     else label_flg = "1"b;                  /* user only wants label rcds */
 995 
 996                else do;
 997                          call ssu_$print_message (sci_ptr, 0, "Usage:  list_tape_contents (ltc) {-long (-lg)} {-label (-lbl)}");
 998                          return;
 999                     end;
1000           end;                                              /* do arg_dex = 1 to Nargs */
1001 
1002 /* position to bot if not already there */
1003           if rtq_info.c_rec ^= 1 | rtq_info.c_file ^= 1 then
1004                call process_control_order ("rewind", "0"b, "0"b, "0"b, 1);
1005           else ;
1006 
1007 /* for Multics or Gcos tape, set to binary mode */
1008           if rtq_info.l_type > 0 & rtq_info.l_type <= 3 then
1009                call check_mode (BINARY_MODE);
1010 
1011 /* for IBM or ANSI tape, set to nine mode */
1012           else if rtq_info.l_type > 3 then
1013                call check_mode (NINE_MODE);
1014 
1015 /* report to users */
1016           call ioa_ ("Listing tape contents of tape volume ^a in ^a mode.^/     Starting at BOT (physical file# 1, record# 1)^/     ",
1017                rtq_info.tape_name, mode (rtq_info.c_mode));
1018 
1019 /* read until the end of tape is encountered */
1020           do while (^rtq_info.two_eofs);
1021                call read_tape_record ("skip", rtq_info.eof, "1"b, mssf); /* read next record */
1022 
1023                if rtq_info.return_subsys_loop_flg then do;
1024                          rtq_info.return_subsys_loop_flg = "0"b;
1025                          revert cleanup;
1026                          call ssu_$abort_line (sci_ptr);
1027                     end;
1028 
1029                if ^rtq_info.eof then do;                    /* if not end of file */
1030 
1031                          if rtq_info.c_rec = 2 then /* if first  record of this file */
1032                               call ioa_ ("Physical tape file # ^d.", rtq_info.c_file);
1033 
1034                          if ^valid_label_record (long_list_flg) then do; /* and not label record */
1035 
1036                                    if rtq_info.c_rec = 2 then do; /* if this is first record of file */
1037                                              last_length = rtq_info.bits; /* set for equal record processing */
1038                                              nrecords = 0;
1039                                              logical_file_num = logical_file_num + 1; /* increment logical file number */
1040 
1041                                              if rtq_info.l_type > 1 then do; /* if not unlabeled or Multics tape */
1042                                                        call ioa_ ("Logical tape file # ^d.^[^/     ^]", logical_file_num, ^label_flg);
1043                                                        logical_file_flg = "1"b;
1044                                                   end;
1045                                              else call ioa_ (" "); /* otherwise just write blank line */
1046                                         end;                /* first record of the file */
1047 
1048                                    if last_length = rtq_info.bits then /* this record length is the same as the last record length */
1049                                         nrecords = nrecords + 1; /* just tally it */
1050                                    else do;                 /* otherwise, display a message */
1051                                              if nrecords = 0 then nrecords = 1; /* set up for at least 1 record */
1052 
1053                                              if ^label_flg then call record_information (nrecords, (last_length), "1"b);
1054 
1055                                              last_length = rtq_info.bits; /* restart tally */
1056                                              nrecords = 0;
1057                                         end;                /* the current record length is different from the last record length */
1058                               end;                          /* if ^valid_label_record (long_list_flg) */
1059 
1060                          else last_length = 0;              /* a label record */
1061                     end;                                    /* if ^eof */
1062                else do;                                     /* tape end of file */
1063                          if last_length > 0 & ^rtq_info.two_eofs then do; /* only display valid records */
1064                                    if nrecords = 0 then nrecords = 1; /* set up for at least 1 record */
1065 
1066                                    if ^label_flg then call record_information (nrecords, (last_length), "1"b);
1067                               end;
1068 
1069                          call ioa_ ("End of physical tape file # ^d, ^[(^a # ^d),^[^/     ^; ^]^;^3s^]^a:  ^d.^/     ",
1070                               rtq_info.c_file - 1, logical_file_flg, "logical tape file", logical_file_num,
1071                               rtq_info.short_output_flg, "total records read", rtq_info.c_rec - 1);
1072 
1073                          logical_file_flg = "0"b;
1074                          rtq_info.c_rec = 1;                /* reset record number */
1075 
1076                          if rtq_info.set_bin & ^label_flg then do; /* if we need to switch next file to bin mode */
1077                                    call check_mode (BINARY_MODE);
1078                                    call ioa_ (" ");         /* write blank line */
1079                                    rtq_info.set_bin = "0"b; /* reset switch */
1080                               end;
1081                          else if rtq_info.set_nine & ^label_flg then do; /* switch back to nine mode */
1082                                    call check_mode (NINE_MODE);
1083                                    call ioa_ (" ");         /* write blank line */
1084                                    rtq_info.set_nine = "0"b;/* reset switch */
1085                               end;                          /* else if */
1086                     end;                                    /* eof */
1087           end;                                              /* do while (^two_eofs) */
1088 
1089 /* position to beginning of tape (bot) */
1090           call process_control_order ("rewind", "0"b, "0"b, "0"b, 1);
1091 
1092 /* report to users */
1093           call ioa_ ("Logical end of tape, positioning to BOT");
1094 
1095 SUBSYSTEM_REQUEST_LOOP:
1096 
1097           return;
1098 
1099 /*****************************************************************************/
1100 %page;
1101 
1102 mode_request: entry (sci_ptr, rtq_info_ptr);
1103 
1104 /* Establish cleanup and program_interrupt handlers.  Get and process the    */
1105 /* optional control argument.  Perform the specified mode control order by   */
1106 /* invoking the "process_control_order" internal procedure.  Note that if    */
1107 /* control argument is given then set "binary" mode as the defaulf mode.     */
1108 
1109           dcl     mode_dex               fixed bin;
1110 
1111 /* begin coding */
1112           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1113 
1114           on program_interrupt goto WANTS_TO_RETURN;
1115 
1116 /* initialization */
1117           scode = 0;
1118           l_cnt = 1;                                        /* 1 iteration default */
1119           rpt, rf, direction = "0"b;                        /* reset command flags */
1120 
1121 /* find number of input arguments */
1122           call ssu_$arg_count (sci_ptr, Nargs);
1123           if Nargs >= 2 then do;
1124 ERROR_MODE:
1125                     call ssu_$print_message (sci_ptr, 0, "Usage:  mode <bcd | bin | nine>");
1126                     return;
1127                end;
1128 
1129 /* then validate them */
1130           if Nargs = 0 then do;
1131                     order = "binary";                       /* default mode */
1132                     rtq_info.c_mode = 1;                    /* subscript of "bin" mode value */
1133                end;
1134           else ;
1135 
1136           do arg_dex = 1 to Nargs;
1137                call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
1138                if arg = "bcd" | arg = "bin" | arg = "nine" then do;
1139                          do mode_dex = 1 to 3;              /* try to find the right mode */
1140                               if substr (arg, 1, 3) = substr (mode (mode_dex), 1, 3) then
1141                                    rtq_info.c_mode = mode_dex;
1142                               else ;
1143                          end;
1144                          order = mode (rtq_info.c_mode);
1145                     end;
1146                else goto ERROR_MODE;
1147           end;
1148 
1149 /* go process control order */
1150           call process_control_order (order, rpt, direction, rf, l_cnt);
1151 
1152 WANTS_TO_RETURN:
1153 
1154           return;
1155 
1156 /***************************************************************************/
1157 %page;
1158 position_request: entry (sci_ptr, rtq_info_ptr);
1159 
1160 /* The rtq "position" request displays the current physical tape file and  */
1161 /* record position to the user.                                            */
1162 
1163 /* begin coding */
1164           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1165 
1166           on program_interrupt goto SUBSYS_QUERY;
1167 
1168 /* find number of input arguments */
1169           call ssu_$arg_count (sci_ptr, Nargs);
1170           if Nargs ^= 0 then do;
1171                     call ssu_$print_message (sci_ptr, 0, "No argument is allowed for this request.");
1172                     return;
1173                end;
1174 
1175 /* response to user's request */
1176           call ssu_$print_message (sci_ptr, 0,
1177                "Reading tape volume ""^a"" in ""^a"" mode.^/Currently positioned to physical file ^d, record ^d.",
1178                rtq_info.tape_name, mode (rtq_info.c_mode), rtq_info.c_file, rtq_info.c_rec);
1179 
1180 SUBSYS_QUERY:
1181 
1182           return;
1183 
1184 /*****************************************************************************/
1185 %page;
1186 
1187 quit_request: entry (sci_ptr, rtq_info_ptr);
1188 
1189 /* returns to the command line */
1190 
1191           call ssu_$abort_subsystem (sci_ptr, 0);
1192 
1193           return;
1194 
1195 /*****************************************************************************/
1196 %page;
1197 read_file_request: entry (sci_ptr, rtq_info_ptr);
1198 
1199 /* reads the current tape file into the segment described by the optional    */
1200 /* control argument:  Initialize intermediate global and local variables.    */
1201 /* Detach the file if already attached.  Get and process optional control    */
1202 /* arguments.  Check for argument inconsistencies.  Perform the              */
1203 /* "begin_file" control order to position to the beginning of the file if    */
1204 /* not already there.  Do 1 to multilple files if was asked while not end of */
1205 /* tape mark.  Note that read in one file (by default).  Report the          */
1206 /* current file which will be read in to the user.  Set the open mode to the */
1207 /* default mode.  If the user wants output attach description then query the */
1208 /* user for it by invoking the "get_output_descript_and_attach" internal     */
1209 /* procedure.  Invoke the " read_in_the_entire_file" internal procedure      */
1210 /* to read in the entire current file.  Check essential flags.  If we have   */
1211 /* written file already then increment file name by one, expand this file    */
1212 /* name and reset the written file switch.  Read in the next file and do     */
1213 /* the same operations until end of tape mark is encountered.  Finally,      */
1214 /* invoke the "detach_file_if_attached" internal procedure if the "-extend"  */
1215 /* is specified to detach the file if already attached.   Return to the      */
1216 /* subsystem request.                                                        */
1217 
1218           dcl     conversion_flg         bit (1) aligned;
1219 
1220 /* begin coding */
1221           conversion_flg, first_record_flg, last_record_flg = "0"b;
1222 
1223 /* set up cleanup handler and program_interrupt (pi) command */
1224           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1225 
1226           on program_interrupt goto RETURN;
1227 
1228           rtq_info.return_subsys_loop_flg = "0"b;           /* make the read_record request happy */
1229 
1230 /* the following flgs of "rtq_info" structure must reset so that if users already deleted some data record */
1231 /* in specified files then his can read them back beyond the tape mark */
1232           rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;
1233 
1234           rtq_info.atd_sw, rtq_info.extend_sw, rtq_info.fw_file, rtq_info.last_job_deck_flg, rtq_info.set_bin = "0"b;
1235           rtq_info.filename = "";
1236 
1237 /* find number of arguments */
1238           call ssu_$arg_count (sci_ptr, Nargs);
1239 
1240 /* set up for processing input arguments */
1241           scode = 0;
1242           iterations = 1;                                   /* set default iteration set to 1 */
1243           s_filename = "";
1244           prptr, lrp = rtq_info.tptr;                       /* set equivilent pointers */
1245           n_ops, schar = 0;
1246           cont, trunc_sw, cp5, ibmv, ansid, dec_sw, gssf, mssf, nnl_sw, l_rec, c_e_a, c_b_a, c_c_a, imcv = "0"b;
1247 
1248 /* just in case we had a file attached */
1249           call detach_file_if_attached;
1250 
1251 /* process optional control arguments */
1252           call read_file_get_control_args;
1253           if scode ^= 0 | rtq_info.return_subsys_loop_flg then
1254                goto SUBSYSTEM_LOOP_RETURN;
1255 
1256 /* check for argument inconsistancies */
1257           if (n_ops > 1) & ^(l_rec & (c_e_a | c_b_a | c_c_a)) then do;
1258                     call ssu_$print_message (sci_ptr, 0, "Inconsistent combination of optional control arguments.");
1259                     return;
1260                end;
1261 
1262 /* position to the beginning of the tape file */
1263           if rtq_info.c_rec > 1 then
1264                call process_control_order ("begin_file", "1"b, "0"b, "1"b, 1);
1265 
1266 /* read multiple files if required */
1267           do nunits = 1 to iterations while (^rtq_info.two_eofs);
1268 
1269                call ioa_ ("Reading tape file # ^d in ^a mode", rtq_info.c_file, mode (rtq_info.c_mode));
1270 
1271                open_mode = Stream_output;                   /* set open mode to default mode */
1272                                                             /* if users want output attach description then ask for it */
1273                if (rtq_info.atd_sw & rtq_info.fw_file) | (rtq_info.atd_sw & nunits = 1) then do;
1274                          call get_output_descript_and_attach;
1275 
1276                          if rtq_info.return_subsys_loop_flg then
1277                               goto SUBSYSTEM_LOOP_RETURN;
1278                     end;
1279 
1280 /* read in the entire tape file */
1281                call read_in_the_entire_file;
1282 
1283                if conversion_flg then return;
1284 
1285                if rtq_info.return_subsys_loop_flg then do;
1286 
1287 SUBSYSTEM_LOOP_RETURN:
1288                          rtq_info.return_subsys_loop_flg = "0"b;
1289                          return;
1290                     end;
1291 
1292 /* if we have written file already */
1293                if rtq_info.fw_file & ^rtq_info.extend_sw then do;
1294 
1295                          if s_filename = "" then
1296                               s_filename = rtq_info.filename; /* save filename on first iteration */
1297 
1298                          rtq_info.filename = rtrim (s_filename) || "." || ltrim (char (nunits + 1)); /* increment file name */
1299 
1300                          if ^valid_pathname ((rtq_info.filename), "") then do;
1301                                    call ssu_$print_message (sci_ptr, scode,
1302                                         "^/     Expanding pathname for file name ""^a""", rtq_info.filename);
1303                                    return;
1304                               end;
1305 
1306                          rtq_info.fw_file = "0"b;           /* reset switch */
1307                     end;                                    /* if fw_file & ^extend_sw  */
1308 
1309           end;                                              /* do nunits = 1 to iterations while (^two_eofs) */
1310 
1311 /* if this is end, detach it */
1312           if rtq_info.extend_sw then
1313                call detach_file_if_attached;                /* just in case we had a file attached */
1314 
1315 RETURN:
1316           return;
1317 
1318 /***************************************************************************/
1319 %page;
1320 read_record_request: entry (sci_ptr, rtq_info_ptr);
1321 
1322 /* reads the current record into a temporary buffer.                       */
1323 /* Establish cleanup and program_interrupt handlers.  Initialize           */
1324 /* intermediate global and local variables.  Find the terminal line        */
1325 /* length.  Get and process optional control arguments.                    */
1326 /* Do 1 to N records  while not end of tape mark .                         */
1327 /* Report the current record of the file to user before reading it in.     */
1328 /* Invoke the "read_tape_record" internal procedure to read in the tape    */
1329 /* record.  If not end of file then report information of each record read */
1330 /* to user.  Read in the next record and do the same operations until      */
1331 /* end of tape mark is encountered.  Return to the subsystem request.      */
1332 
1333 /* begin coding */
1334           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1335 
1336           on program_interrupt goto SUBSYS_REQUEST_LOOP;
1337 
1338           rtq_info.return_subsys_loop_flg = "0"b;           /* make the read_record request happy */
1339 
1340 /* the following flgs of "rtq_info" structure must be reset so that if users already deleted some data record */
1341 /* from specified files then he can read them back beyond the tape mark */
1342           rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;
1343 
1344 /* initialize global variables */
1345           scode = 0;                                        /* must initialize scode value */
1346           mssf = "0"b;                                      /* reset Multics standard system format flag */
1347           iterations = 1;                                   /* set default iteration set to 1 */
1348 
1349 /* find number of input arguments */
1350           call ssu_$arg_count (sci_ptr, Nargs);
1351 
1352 /* then process them */
1353           do arg_dex = 1 to Nargs;
1354                call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
1355                if arg = "-count" | arg = "-ct" then do;     /* user wants to read mutiple rcds */
1356                          if arg_dex < Nargs then do;
1357                                    arg_dex = arg_dex + 1;
1358                                    call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
1359                                    iterations = cv_dec_check_ (arg, scode); /* check for rdrec iterations */
1360                                    if scode ^= 0 then goto ERROR_RDREC;
1361                               end;
1362                          else goto ERROR_RDREC;             /* missing N for -count */
1363                     end;                                    /* -count (-cnt) */
1364                else do;                                     /* no other control arg allowed */
1365 ERROR_RDREC:
1366                          call ssu_$print_message (sci_ptr, scode, "^/     Usage:  read_record (rdrec) {-count (-ct) N}");
1367                          return;
1368                     end;
1369 
1370           end;                                              /* do arg_dex = 1 to Nargs */
1371 
1372           do nunits = 1 to iterations while (^rtq_info.two_eofs);
1373 
1374                call ssu_$print_message (sci_ptr, 0, "Reading record ^d, File ^d in ^a mode", rtq_info.c_rec,
1375                     rtq_info.c_file, mode (rtq_info.c_mode));
1376 
1377                call read_tape_record ("stop", rtq_info.eof, "0"b, mssf); /* go read tape record */
1378 
1379                if rtq_info.return_subsys_loop_flg then do;
1380                          rtq_info.return_subsys_loop_flg = "0"b;
1381                          return;
1382                     end;
1383 
1384                if ^rtq_info.eof then
1385                     call record_information (1, rtq_info.bits, "0"b); /* display record length info */
1386           end;                                              /* do nunits = 1 to iterations while (^two_eofs) */
1387 
1388 SUBSYS_REQUEST_LOOP:
1389           return;
1390 
1391 /***************************************************************************/
1392 %page;
1393 records_in_file_request: entry (sci_ptr, rtq_info_ptr);
1394 
1395 /* is a request which will report to users the number of records in the    */
1396 /* current file.  Establish cleanup and program_interrupt handlers.        */
1397 /* Report to users if any optional control argument is specified.          */
1398 /* Set up for reading records in the current file.  Read them in until     */
1399 /* end of file encountered.  Report the total records counted and the tape */
1400 /* position to users.  Invoke the "process_control_order" existing         */
1401 /* internal procedure to backspace to the original tape position.  Reset   */
1402 /* the "one_eof" and "records_in_file_flg" flag fields of the "rtq_info"   */
1403 /* structure before returning to the rtq request loop.                     */
1404 
1405           dcl     end_file_flg           bit (1) aligned;
1406           dcl     numb_of_recs_to_be_backspaced fixed bin;
1407           dcl     save_current_record    fixed bin;
1408           dcl     save_current_file      fixed bin;
1409 
1410 /* begin coding */
1411           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1412 
1413           on program_interrupt goto RETURNED;
1414 
1415           call ssu_$arg_count (sci_ptr, Nargs);
1416           if Nargs ^= 0 then do;
1417                     call ssu_$print_message (sci_ptr, 0, "Usage:  records_in_file, rif");
1418                     return;
1419                end;
1420 
1421 /* set up for reading records of the current file */
1422           rtq_info.eov, rtq_info.two_eofs, rtq_info.one_eof = "0"b; /* must reset in case they were previously set */
1423           scode = 0;
1424           rtq_info.records_in_file_flg = "1"b;
1425           rtq_info.return_subsys_loop_flg = "0"b;           /* make the records_in_file request happy */
1426           save_current_record = rtq_info.c_rec;
1427           save_current_file = rtq_info.c_file;
1428           end_file_flg = "0"b;
1429           mssf = "0"b;
1430 
1431 /* read in each record in the current file until end of file encountered */
1432           do while (^end_file_flg);
1433                call read_tape_record ("skip", end_file_flg, "1"b, mssf);
1434           end;
1435 
1436 /* report the number of records counted in the current file */
1437           call ioa_ ("The current file # ^d contains ^d record^[s^]." ||
1438                "^/Repositioned the tape to its original position:  record # ^d, file # ^d.", save_current_file,
1439                rtq_info.c_rec - 1, (rtq_info.c_rec > 1), save_current_record, save_current_file);
1440 
1441           rtq_info.c_file = rtq_info.c_file - 1;            /* the actual current file number */
1442 
1443 /* perform the "backspace_record" control order to its original position */
1444           order = "backspace_record";
1445           rpt = "1"b;
1446           direction = "0"b;
1447           rf = "0"b;
1448           numb_of_recs_to_be_backspaced = rtq_info.c_rec - save_current_record;
1449 
1450 /* case of file containing no data record */
1451           if numb_of_recs_to_be_backspaced = 0 then
1452                call iox_$control (rtq_info.tiocb_ptr, order, null, (0));
1453 
1454 /* case of a file containing 1 data record or more */
1455           else call process_control_order (order, rpt, direction, rf, (numb_of_recs_to_be_backspaced));
1456 
1457           rtq_info.one_eof = "0"b;                          /* reset after the tape is repositioned to its original position */
1458 
1459           rtq_info.records_in_file_flg = "0"b;              /* reset this flg after the request is done. */
1460 
1461 RETURNED:
1462           return;
1463 
1464 /***************************************************************************/
1465 %page;
1466 rewind_request: entry (sci_ptr, rtq_info_ptr);
1467 
1468 /* Establish cleanup and program_interrupt handlers.  Display an usage     */
1469 /* message if any control argument is given.  Perform the "rewind" control */
1470 /* order by invoking the "process_control_order" internal procedure.       */
1471 /* Return to the subsystem request loop.                                   */
1472 
1473 /* begin coding */
1474           on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);
1475 
1476           on program_interrupt goto PI_RETURN;
1477 
1478           call ssu_$arg_count (sci_ptr, Nargs);
1479           if Nargs ^= 0 then do;
1480                     call ssu_$print_message (sci_ptr, 0, "Usage:  rewind (rew)");
1481                     return;
1482                end;
1483 
1484 /* initialization */
1485           scode = 0;
1486           l_cnt = 1;                                        /* 1 iteration default */
1487           rpt, rf, direction = "0"b;                        /* reset command flags */
1488           order = "rewind";
1489 
1490           call process_control_order (order, rpt, direction, rf, l_cnt); /* go process control order */
1491 
1492 /* must reset the following flags if they were previously set */
1493           rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;
1494 
1495 PI_RETURN:
1496           return;
1497 
1498 /****************************************************************************/
1499 %page;
1500 ANSI_DB_records: proc (conversion_flg);
1501 
1502 /* process each ANSI DB record of the input tape file for the "rdfile" request */
1503 
1504           dcl     conversion_flg         bit (*) aligned;
1505 
1506 /* begin coding */
1507           nchars = 0;
1508           rtq_info.rptr = rtq_info.tptr;                    /* set first log record ptr */
1509 
1510           on conversion begin;
1511                     call ssu_$print_message (sci_ptr, 0,
1512                          "Conversion condition detected attempting to convert ANSI log rec len (""^a"") to binary",
1513                          ansi_db_lrec.lrl);
1514 
1515                     conversion_flg = "1"b;
1516                     goto BACK_TO_RTQ_REQUEST_LOOP;          /* return to rtq subsystem request loop */
1517                end;
1518 
1519           do while (nchars < rtq_info.rec_len - 3);         /* process entire block */
1520                l_rec_len = bin (ansi_db_lrec.lrl) - NUMB_OF_CHARS_PER_WORD; /* compute logical record size */
1521 
1522                if l_rec_len = 0 then do;                    /* if null record, write empty line */
1523                          call write_file (addr (NL), 1, s_filename);
1524 
1525                          if rtq_info.return_subsys_loop_flg then return;
1526                     end;
1527                else do;                                     /* record contains data */
1528                          if c_e_a then /* if ebcdic record */
1529                               call ebcdic_to_ascii_ (ansi_db_lrec.alrd, rtq_info.cbufp -> cbuf);
1530                          else rtq_info.cbufp -> cbuf = ansi_db_lrec.alrd; /* otherwise, copy it */
1531 
1532                          trim_trailing_blanks_log_rec_len = length (rtrim (rtq_info.cbufp -> cbuf));
1533 
1534                          if ^nnl_sw then do;                /* add New Line character to each record */
1535                                    trim_trailing_blanks_log_rec_len = trim_trailing_blanks_log_rec_len + 1;
1536                                    substr (rtq_info.cbufp -> cbuf, trim_trailing_blanks_log_rec_len, 1) = NL;
1537                               end;
1538 
1539                          call write_file (rtq_info.cbufp, trim_trailing_blanks_log_rec_len, s_filename); /* write out log record */
1540 
1541                          if rtq_info.return_subsys_loop_flg then return;
1542                     end;                                    /* record contains data */
1543 
1544                rtq_info.rptr = addr (ansi_db_lrec.nxt_lrec);
1545                nchars = nchars + l_rec_len + NUMB_OF_CHARS_PER_WORD; /* increment total # of chars */
1546 
1547           end;                                              /* do while ... */
1548 
1549 BACK_TO_RTQ_REQUEST_LOOP:
1550           return;
1551 
1552      end ANSI_DB_records;
1553 
1554 /****************************************************************************/
1555 %page;
1556 CP5_variable_length_records: proc ();
1557 
1558 /* process each logical record of the input tape file in the CP5 standard   */
1559 /* system format for the read_file request.                                 */
1560 
1561 /* begin coding */
1562           rtq_info.rptr = addr (cp5_phy_rec.first);         /* get ptr to first record */
1563 
1564           do i = 1 to cp5_phy_rec.nky;
1565                call ebcdic_to_ascii_ (cp5_log_rec.cp5_log_rec_data, rtq_info.cbufp -> cbuf);
1566 
1567                substr (rtq_info.cbufp -> cbuf, cp5_log_rec.rlen + 1, 1) = NL; /* add new line char to end */
1568 
1569                call write_file (rtq_info.cbufp, cp5_log_rec.rlen + 1, s_filename); /* write out this logical record */
1570 
1571                if rtq_info.return_subsys_loop_flg then
1572                     return;
1573 
1574                rtq_info.rptr = addrel (rtq_info.rptr, currentsize (cp5_log_rec)); /* go to next one */
1575           end;
1576 
1577           return;
1578 
1579      end CP5_variable_length_records;
1580 
1581 /****************************************************************************/
1582 %page;
1583 DEC_tape_records: proc ();
1584 
1585 /* process each record of the input tape file in DEC standard system format */
1586 /* for the read_file request.                                               */
1587 
1588           dcl     DEC_40_bits_per_word   fixed bin static options (constant) init (40);
1589 
1590 /* convert DEC to MULTICS standard words */
1591           it_cnt = divide (rtq_info.bits, DEC_40_bits_per_word, 17, 0); /* get number of 40 bit words  */
1592 
1593           do i = 1 to it_cnt;                               /* each record is 512 40 bit words */
1594                dec_mult (i).first_32 = dec_tape_raw.ps_wd (i).first_32; /* copy 1st 32 bits */
1595 
1596                dec_mult (i).last_4 = dec_tape_raw.ps_wd (i).last_4; /* copy last 4 bits */
1597           end;
1598 
1599           call write_file (lrp, it_cnt * 4, s_filename);    /* write out this record */
1600 
1601           return;
1602 
1603      end DEC_tape_records;
1604 
1605 /****************************************************************************/
1606 %page;
1607 IBM_VB_records: proc ();
1608 
1609 /* process each IBM VB_formated variable_length record of the input tape   */
1610 /* file for the "rdfile" request.                                          */
1611 
1612 /* begin coding */
1613           nchars = 0;
1614           blocksize = bin (bdw.msl || bdw.lsl) - NUMB_OF_CHARS_PER_WORD;
1615           rtq_info.rptr = addr (ibm_phy_rec.iprd);          /* set first logical record ptr */
1616 
1617           do while (nchars < blocksize);                    /* process entire block */
1618                l_rec_len = bin (rdw.msl || rdw.lsl) - NUMB_OF_CHARS_PER_WORD; /* compute logical record size */
1619 
1620                if c_e_a then /* if ebcdic record */
1621                     call ebcdic_to_ascii_ (ibm_log_rec.ilrd, rtq_info.cbufp -> cbuf);
1622                else rtq_info.cbufp -> cbuf = ibm_log_rec.ilrd; /* otherwise, copy it */
1623 
1624                trim_trailing_blanks_log_rec_len = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rtq_info.rec_len)));
1625 
1626                if ^nnl_sw then do;                          /* add new line character to each record */
1627                          trim_trailing_blanks_log_rec_len = trim_trailing_blanks_log_rec_len + 1;
1628                          substr (rtq_info.cbufp -> cbuf, trim_trailing_blanks_log_rec_len, 1) = NL;
1629                     end;
1630 
1631                call write_file (rtq_info.cbufp, trim_trailing_blanks_log_rec_len, s_filename); /* write out log record */
1632 
1633                if rtq_info.return_subsys_loop_flg then
1634                     return;
1635 
1636                rtq_info.rptr = addr (ibm_log_rec.nxt_lrec);
1637                nchars = nchars + l_rec_len + NUMB_OF_CHARS_PER_WORD; /* increment total  # of chars */
1638           end;
1639 
1640           return;
1641 
1642      end IBM_VB_records;
1643 
1644 /****************************************************************************/
1645 %page;
1646 GCOS_ssf: proc (cont, imcv, nchars, binck, first_record_flg, s_filename);
1647 
1648 /* process GCOS standard system format records.                           */
1649 
1650           dcl     binck                  bit (1) aligned;
1651           dcl     card_cnt               fixed bin;
1652           dcl     cont                   bit (1) aligned;
1653           dcl     dkend_card             bit (1) aligned;
1654           dcl     eoc                    bit (1) aligned;
1655           dcl     (fc, fl)               bit (1) aligned;
1656           dcl     first_record_flg       bit (1) aligned;
1657           dcl     gcos_trans             (9) char (6) static options (constant) init
1658                                          ("gmap  ", "355map", "355sim", "algol ", "forta ", "forty ", "cobol ", "cob68 ", "jovial");
1659           dcl     imcv                   bit (1) aligned;
1660           dcl     nchars                 fixed bin (21);    /* will reference in get_file_name procedure */
1661           dcl     obj_card               bit (1) aligned;
1662           dcl     p_arg                  char (168) varying init ("");
1663           dcl     s_filename             char (32) var;     /* save for calling write_file procedure */
1664 
1665 /* based */
1666           dcl     1 comdk                aligned based (rtq_info.cdptr), /* structure of a comdeck card */
1667                   ( 2 type               bit (12),          /* bin card type, "5005"b3 for comdeck */
1668                     2 bin_seq            bit (24),          /* binary sequence number */
1669                     2 ckeck_sum          bit (36),          /* check sum word */
1670                     2 data               bit (21 * 36),     /* 21 data words */
1671                     2 h_seq              (4) bit (12),      /* holorith seq number */
1672                     2 pad                bit (12)) unaligned;
1673 
1674           dcl     1 com_fld              unaligned based (rtq_info.cfptr), /* template for compression */
1675                     2 f_len              bit (6),           /* field length */
1676                     2 s_len              bit (6),           /* string length */
1677                     2 bcd_str            bit (fixed (com_fld.s_len, 6) * 6), /* bcd char string */
1678                     2 nxt                bit (6),           /* field or card fence */
1679                     2 nxt_fld            bit (6);           /* to get to next field */
1680 
1681 /* begin coding */
1682           if ^first_record_flg then do;                     /* if first record of file */
1683                     bcnt = gc_phy_rec.bcw.bsn;              /* load block serial number */
1684                     first_record_flg = "1"b;
1685                end;
1686           else do;                                          /* if not first record, check block serial number */
1687                     bcnt = bcnt + 1;                        /* increment our block count */
1688                     if gc_phy_rec.bcw.bsn ^= bcnt then do;  /* something wrong here */
1689                               call ssu_$print_message (sci_ptr, 0,
1690                                    "Block serial number error; BSN was ^d, S/B ^d", gc_phy_rec.bcw.bsn, bcnt);
1691 
1692                               YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop?  Answer ""yes"" or ""no"".", "Stop?");
1693 
1694                               if YES_FLG then do;           /* users want to stop */
1695                                         call detach_file_if_attached; /* just in case we had a file attached */
1696 
1697                                         rtq_info.return_subsys_loop_flg = "1"b; /* users want to return to subsystem request loop */
1698 
1699                                         return;
1700                                    end;
1701                               else bcnt = gc_phy_rec.bcw.bsn; /* reset block number */
1702                          end;                               /* something wrong */
1703                end;                                         /* not first record */
1704 
1705           if gc_phy_rec.bcw.blk_size > rtq_info.wd_buf_size then do; /* is our buffer big enough? */
1706                     call ssu_$print_message (sci_ptr, 0, "Phyical record size (^d) is larger than buffer size (^d)",
1707                          gc_phy_rec.bcw.blk_size, rtq_info.wd_buf_size);
1708 
1709                     YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop?  Answer ""yes"" or ""no"".", "Stop?");
1710 
1711                     if YES_FLG then do;                     /* users want to stop */
1712                               call detach_file_if_attached; /* just in case we had a file attached */
1713 
1714                               rtq_info.return_subsys_loop_flg = "1"b; /* users want to return to subsystem request loop */
1715 
1716                               return;
1717                          end;
1718                end;                                         /* our buffer is big enough */
1719 
1720           lrptr = addr (gc_phy_rec.gc_phy_rec_data (1));    /* get pointer to first logical record */
1721           nwds = 0;                                         /* initialize number of words */
1722           card_cnt = 1;                                     /* set initial card count for this block */
1723           obj_card, dkend_card = "0"b;                      /* clear bin card indicators */
1724 
1725           do while (nwds < gc_phy_rec.bcw.blk_size);        /* iterate through all logical records */
1726                if ^cont then rtq_info.cbufp -> cbuf = "";
1727                go to media_type (rcw.media_code);           /* take appropriate action */
1728 %page;
1729 /* media code 1 is binary card image */
1730 
1731 media_type (1):                                             /* Binary card image */
1732                rtq_info.cdptr = addr (gc_log_rec.gc_log_rec_data); /* set ptr to data */
1733                if comdk.type = "5005"b3 then do;            /* compressed deck? */
1734                          rtq_info.cfptr = addr (comdk.data);/* lets decompress it */
1735                          fc = "0"b;                         /* reset terminate condition */
1736 
1737                          do while (^fc);                    /* go through entire card */
1738                               if ^cont then do;             /* not continuing from last card */
1739                                         nchars = 1;         /* set line position to 1 */
1740                                         rtq_info.cbufp -> cbuf = ""; /* add blanks to line buffer */
1741                                    end;
1742 
1743                               fl = "0"b;
1744                               do while (^fl & ^fc);         /* decompress each line */
1745                                    i = fixed (f_len, 6);    /* get field length */
1746                                    j = fixed (s_len, 6);    /* get string length */
1747 
1748                                    if f_len = "77"b3 then do; /* end of line */
1749                                              cont = "0"b;   /* reset continue */
1750                                              fl = "1"b;
1751                                              rtq_info.cfptr = addr (com_fld.s_len); /* skip over it */
1752                                         end;                /* end of line */
1753 
1754                                    else if i < j | (i = 0 & j = 0) then do; /* end of card */
1755                                              eoc, fc = "1"b;
1756                                              cont = "0"b;   /* turn off continue flag */
1757                                         end;                /* end of card */
1758 
1759                                    else do;
1760                                              eoc = "0"b;
1761                                              if j ^= 0 then do;
1762                                                        rtq_info.cdkp -> cdkbuf = "";
1763                                                        call bcd_to_ascii_ (bcd_str, rtq_info.cdkp -> cdkbuf); /* convert  string to ascii */
1764                                                        substr (rtq_info.cbufp -> cbuf, nchars + (i - j), j) = rtq_info.cdkp -> cdkbuf; /* set string in position */
1765                                                   end;      /* not end of line and not end of card */
1766 
1767                                              nchars = nchars + i; /* update line position */
1768 
1769                                              if com_fld.nxt = "76"b3 then do; /* end of compressed deck */
1770                                                        fc = "1"b;
1771                                                        cont = "0"b; /* turn off continue so we will write this line */
1772                                                   end;      /* end of compressed deck */
1773 
1774                                              else if com_fld.nxt = "77"b3 then do; /* end of this line */
1775                                                        fl = "1"b; /* set terminate condition */
1776                                                        cont = "0"b; /* not a continued line */
1777                                                        rtq_info.cfptr = addr (com_fld.nxt_fld); /* set ptr to skip line fence */
1778                                                   end;      /* end of this line */
1779 
1780                                              else if com_fld.nxt = "00"b3 then /* line continued in next card */
1781                                                   cont, fc = "1"b;
1782 
1783                                              else rtq_info.cfptr = addr (com_fld.nxt); /* otherwise just go to nxt field */
1784                                         end;                /* not end of line and not end of card */
1785                               end;                          /* do while ^fl &^fc */
1786 
1787                               if ^cont & ^eoc then do;      /* line continues on next card */
1788                                         substr (rtq_info.cbufp -> cbuf, nchars, 1) = NL; /* add new line to end of line */
1789                                         call write_file (rtq_info.cbufp, nchars, s_filename); /* write out the line */
1790                                    end;                     /* if line continues on next card */
1791                          end;                               /* do while not end of card */
1792                     end;                                    /* compressed deck */
1793                else do;                                     /* user wants copy */
1794 
1795 ck_obj:
1796                          if obj_card then do;               /* we have passed a $ object card */
1797                                    obj_card = "0"b;
1798                                    if card_cnt ^= 2 then do;/* not first card of blk */
1799                                              call ssu_$print_message (sci_ptr, 0, "$ object card not first card of blk");
1800                                              rtq_info.return_subsys_loop_flg = "1"b;
1801                                              return;        /* return to subsystem */
1802                                         end;
1803 
1804 /* nchars = current card size + prev card size + bcw */
1805                                    nchars = (rtq_info.cvp -> rcw.rsize + rcw.rsize + 3) * NUMB_OF_CHARS_PER_WORD;
1806                                    rtq_info.cvp = addrel (rtq_info.cvp, -1); /* don't forget bcw */
1807                               end;                          /* if we have passed a $ object card */
1808 
1809                          else if card_cnt = 1 then do;      /* include only bcw */
1810                                    nchars = (rcw.rsize + 2) * NUMB_OF_CHARS_PER_WORD;
1811                                    rtq_info.cvp = addrel (lrptr, -1);
1812                               end;
1813 
1814                          else do;                           /* include just this card */
1815                                    nchars = (rcw.rsize + 1) * NUMB_OF_CHARS_PER_WORD;
1816                                    rtq_info.cvp = lrptr;
1817                               end;
1818 
1819                          call write_file (rtq_info.cvp, nchars, s_filename);
1820 
1821                          if dkend_card then do;             /* if last card of deck */
1822                                    dkend_card = "0"b;
1823 
1824                                    call detach_file_if_attached; /* just in case we had a file attached */
1825                               end;                          /* last card of deck */
1826                     end;                                    /* user wants copy */
1827 
1828                go to gssf_end;
1829 %page;
1830 /* media codes 0, 2, 3, and 9 - bcd records */
1831 
1832 media_type (0):                                             /* Not a media conversion record */
1833 media_type (2):                                             /* BCD card image */
1834 media_type (3):                                             /* BCD print line image */
1835 media_type (9):                                             /* Bcd print line image (with user defined rpt code) */
1836 
1837                call bcd_to_ascii_ (gc_log_rec_bits, rtq_info.cbufp -> cbuf); /* convert bcd to ascii */
1838                rtq_info.cbufp -> cbuf = translate (rtq_info.cbufp -> cbuf, "='+)(", "#@&]%"); /* take care of stange conversion chars */
1839                if rcw.media_code = 2 then do;               /* if bcd card */
1840                          nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, 80))) + 1; /* set max length to 80 char */
1841                          if substr (rtq_info.cbufp -> cbuf, 1, 13) = "$      object" then do; /* and object card */
1842                                    obj_card = "1"b;
1843                                    rtq_info.cvp = addrel (lrptr, currentsize (gc_log_rec)); /* look at nxt card */
1844                                    if rtq_info.cvp -> rcw.media_code = 1 then do; /* if binary card */
1845                                              binck = "1"b;  /* set flag so we don't come back */
1846                                              call detach_file_if_attached; /* this should not happen but ... */
1847 
1848                                              call get_file_name ("obj", nchars); /* get filename */
1849                                              if rtq_info.return_subsys_loop_flg then
1850                                                   return;   /* return to subsystem */
1851 
1852                                              go to gssf_end;/* card will be written with next one */
1853                                         end;                /* binary card */
1854                               end;                          /* object card */
1855 
1856                          else if substr (rtq_info.cbufp -> cbuf, 1, 12) = "$      dkend" then /* dkend card */
1857                               if binck then do;             /* process only if we have been doing something with  bin cards */
1858                                         if substr (rtq_info.cbufp -> cbuf, 16, 8) ^= "continue" then /* if continue card keep on going */
1859                                              dkend_card = "1"b;
1860                                         go to ck_obj;       /* copy this one too */
1861                                    end;
1862                               else ;
1863 
1864                          else if substr (rtq_info.cbufp -> cbuf, 1, 12) = "$      snumb" then do; /* snumb card */
1865                                    i = search (substr (rtq_info.cbufp -> cbuf, 16, 6), ","); /* if any commas, find out */
1866                                    if i = 0 then /* no commas, use name as is */
1867                                         p_arg = substr (rtq_info.cbufp -> cbuf, 16, 6); /* generate filename */
1868                                    else p_arg = substr (rtq_info.cbufp -> cbuf, 16, i - 1); /* don't like commas in seg names */
1869 
1870                                    if ^valid_pathname ((p_arg), "imcv") then do;
1871                                              rtq_info.return_subsys_loop_flg = "1"b;
1872                                              return;        /* return to subsystem */
1873                                         end;
1874 
1875                                    call detach_file_if_attached; /* detach old file, if attached */
1876 
1877                                    imcv = "1"b;             /* set indicator switch */
1878                                    rtq_info.fw_file, cont = "0"b; /* reset so file name will appear on terminal */
1879                               end;                          /* snumb card */
1880 
1881                          else if ^imcv then do;             /* a $ language card */
1882                                    rtq_info.tmr = "0"b;     /* reset terminate condition */
1883                                    do i = 1 to hbound (gcos_trans, 1) while (^rtq_info.tmr);
1884                                         if substr (rtq_info.cbufp -> cbuf, 8, 6) = gcos_trans (i) then rtq_info.tmr = "1"b;
1885                                    end;
1886                                    if rtq_info.tmr then do; /* found a valid language card */
1887                                              if rtq_info.f_attached then do; /* if we had a file attached before... */
1888                                                        call write_file (addr (eoj_card), length (eoj_card), s_filename); /* complete jcl */
1889 
1890                                                        if rtq_info.return_subsys_loop_flg then
1891                                                             return;
1892 
1893                                                        call detach_file_if_attached;
1894                                                   end;
1895 
1896                                              call get_file_name ("ascii", nchars); /* get filename */
1897 
1898                                              if rtq_info.return_subsys_loop_flg then
1899                                                   return;
1900 
1901                                              rtq_info.last_job_deck_flg = "1"b; /* set flag for last job deck */
1902                                              call ioa_$rsnnl ("$      snumb   ^a^/$      ident^/^a^/$      limits  8,64k,,50000^/",
1903                                                   rtq_info.cbufp -> cbuf, rtq_info.clen, substr (rtq_info.filename, 1, 3),
1904                                                   substr (rtq_info.cbufp -> cbuf, 1, nchars));
1905 
1906                                              call write_file (rtq_info.cbufp, rtq_info.clen, s_filename); /* write out jcl */
1907 
1908                                              cont = "0"b;   /* reset continue flag */
1909 
1910                                              if rtq_info.return_subsys_loop_flg then
1911                                                   return;
1912 
1913                                              go to gssf_end;
1914                                         end;                /* a valid language card */
1915                               end;                          /* a $ language card */
1916                     end;                                    /*  a bcd card */
1917 
1918                else if rcw.media_code = 9 then do;          /* if user rpt code present */
1919                          rtq_info.cbufp -> cbuf = substr (rtq_info.cbufp -> cbuf, 3); /* wipe it out */
1920                          nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rcw.rsize * 6))) - 2; /* get length of string */
1921                     end;                                    /* user rpt code */
1922 
1923                else nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rcw.rsize * 6))) + 1; /* get length of string */
1924 
1925                substr (rtq_info.cbufp -> cbuf, nchars, 1) = NL; /* append new line to end of string */
1926 
1927                call write_file (rtq_info.cbufp, nchars, s_filename); /* write out this logical record */
1928 
1929                if rtq_info.return_subsys_loop_flg then
1930                     return;
1931 
1932                go to gssf_end;
1933 %page;
1934 /* media codes 6, 7, 10, and 13 are ascii records */
1935 
1936 media_type (6):                                             /* ssf ascii */
1937 media_type (7):                                             /* Ascii print line image */
1938 media_type (10):                                            /* Ascii card image */
1939 media_type (13):                                            /* Ascii print line image (with user defined rpt code) */
1940 
1941                rtq_info.cvp = addr (gc_log_rec.gc_log_rec_data);
1942                if rcw.nchar_used ^= 0 then /* if we have a partial word */
1943                     nchars = ((rcw.rsize - 1) * NUMB_OF_CHARS_PER_WORD) + rcw.nchar_used + 1;
1944                else nchars = rcw.rsize * NUMB_OF_CHARS_PER_WORD + 1;
1945 
1946                rtq_info.cbufp -> cbuf = substr (gssf_ascii, 1, nchars - 1) || NL;
1947                if rcw.media_code = 13 then do;              /* if user rpt code present */
1948                          rtq_info.cbufp -> cbuf = substr (rtq_info.cbufp -> cbuf, 3); /* wipe it out */
1949                          nchars = nchars - 2;
1950                     end;
1951 
1952                call write_file (rtq_info.cbufp, nchars, s_filename); /* write out this logical record */
1953 
1954                if rtq_info.return_subsys_loop_flg then
1955                     return;                                 /* return to subsystem */
1956 
1957                go to gssf_end;
1958 
1959 
1960 /* media codes 4, 5, 11, 12, 14, and 15 are illegal media codes */
1961 
1962 media_type (4):                                             /* Reserved for user */
1963 media_type (5):                                             /* Tss ascii (before release E) */
1964 media_type (11):                                            /* Illegal media code */
1965 media_type (12):                                            /* Illegal media code */
1966 media_type (14):                                            /* Illegal media code */
1967 media_type (15):                                            /* Illegal media code */
1968 
1969                call ssu_$print_message (sci_ptr, 0, "Illegal media code ^o detected in card number ^d of block ^d",
1970                     rcw.media_code, card_cnt, bcnt);
1971                rtq_info.return_subsys_loop_flg = "1"b;
1972                return;                                      /* this is not a gcos deck, return */
1973 
1974 
1975 media_type (8):                                             /* tss info record, ignore */
1976 
1977 gssf_end:
1978                nwds = nwds + rcw.rsize + 1;                 /* increment number of words */
1979                rtq_info.cvp = lrptr;                        /* save ptr to current logical record */
1980                lrptr = addrel (lrptr, currentsize (gc_log_rec)); /* set next logical record */
1981                card_cnt = card_cnt + 1;                     /* increment card count */
1982 
1983           end;                                              /* do while nwds < gc_phy_rec.bcw.blk_size */
1984 
1985      end GCOS_ssf;
1986 
1987 /****************************************************************************/
1988 %page;
1989 MULT_ssf: proc (first_record_flg, last_record_flg, s_filename);
1990 
1991 /* process MULTICS standard system format records.                           */
1992 
1993           dcl     first_record_flg       bit (1) aligned;
1994           dcl     last_record_flg        bit (1) aligned;
1995           dcl     s_filename             char (32) varying; /* save for calling write_file procedure */
1996 
1997           dcl     1 mult_buf             based (rtq_info.tptr) aligned, /* buffer for MULTICS standard tape record */
1998                     2 cur_rec            (1040) bit (36),   /* storage for current record */
1999                     2 last_rec           char (rtq_info.clen); /* storage for last record read */
2000 
2001 /* begin coding */
2002           mstrp = rtq_info.tptr;                            /* set Multics standard record ptr */
2003 
2004           if ^first_record_flg then do;                     /* if this is the first rcd set flag */
2005                     first_record_flg = "1"b;
2006                     bcnt = mstr.head.rec_within_file;       /* set initial record number within file */
2007                end;
2008 
2009           else if ^mstr.head.flags.repeat then do;          /* if not repeat record */
2010                     bcnt = bcnt + 1;                        /* increment record counter */
2011                     if bcnt ^= mstr.head.rec_within_file & ^last_record_flg then do; /* sequence error */
2012                               call ssu_$print_message (sci_ptr, 0,
2013                                    "Record sequence number error; Record sequence number was ^d; S/B ^d",
2014                                    mstr.head.rec_within_file, bcnt);
2015 
2016                               YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop?  Answer ""yes"" or ""no"".", "Stop?");
2017 
2018                               if YES_FLG then do;           /* users want to stop */
2019                                         call detach_file_if_attached; /* just in case we had a file attached */
2020 
2021                                         rtq_info.return_subsys_loop_flg = "1"b; /* users want to return to subsystem request loop */
2022 
2023                                         return;
2024                                    end;
2025                               else bcnt = mstr.head.rec_within_file; /* reset block number */
2026                          end;                               /* sequential error */
2027 
2028                     call write_file (addr (mult_buf.last_rec), rtq_info.clen, s_filename); /* write out last record */
2029 
2030                     if rtq_info.return_subsys_loop_flg then return;
2031 
2032                end;                                         /* not repeat record */
2033 
2034           if ^last_record_flg then do;                      /* if current record is not eof */
2035                     rtq_info.clen = divide (mstr.head.data_bits_used, 9, 17, 0); /* get char length */
2036                     addr (mult_buf.last_rec) -> mult_move = addr (mstr.data) -> mult_move; /* move it */
2037                end;
2038 
2039      end MULT_ssf;
2040 
2041 /****************************************************************************/
2042 %page;
2043 attach_and_open_output_file: proc;
2044 
2045 /* attach file */
2046 RETRY:
2047           call iox_$attach_name ("file_sw", rtq_info.fiocb_ptr, att_desc, null, scode);
2048           if scode ^= 0 then do;
2049 
2050                     if scode = error_table_$not_detached then do;
2051                               call iox_$detach_iocb (rtq_info.fiocb_ptr, scode);
2052                               if scode ^= error_table_$not_closed then
2053                                    goto ERR_ATTACHED;
2054                               else do;
2055                                         call iox_$close (rtq_info.fiocb_ptr, scode);
2056                                         goto RETRY;
2057                                    end;
2058                          end;
2059                     else do;                                /* display error messages */
2060 
2061 ERR_ATTACHED:
2062                               call ssu_$print_message (sci_ptr, scode,
2063                                    "^/     Attempting to attach file.^/     Attach description: ^a", att_desc);
2064 
2065                               rtq_info.return_subsys_loop_flg = "1"b;
2066                               return;
2067                          end;
2068                end;                                         /* scode ^= 0 */
2069 
2070           rtq_info.f_attached = "1"b;                       /* set attached switch */
2071 
2072 /*  open file */
2073           call iox_$open (rtq_info.fiocb_ptr, open_mode, "0"b, scode);
2074 
2075           if scode ^= 0 then do;
2076                     call ssu_$print_message (sci_ptr, scode,
2077                          "^/     Opening ^a for ^a", att_desc, iox_modes (open_mode));
2078 
2079                     call detach_file_if_attached;           /* just in case we had a file attached */
2080 
2081                     rtq_info.return_subsys_loop_flg = "1"b;
2082                     return;
2083                end;
2084 
2085 
2086      end attach_and_open_output_file;
2087 
2088 /****************************************************************************/
2089 %page;
2090 check_mode: proc (a_mode);
2091 
2092 /* check and set tape dim in a specified reading mode.                      */
2093 
2094           dcl     a_mode                 fixed bin;
2095 
2096 /* set desired mode if required and tell user what we have done */
2097           if rtq_info.c_mode ^= a_mode then do;
2098                     rtq_info.c_mode = a_mode;
2099 
2100                     call ioa_ ("Setting tape dim to read in ^a mode", mode (rtq_info.c_mode));
2101 
2102                     call process_control_order (mode (rtq_info.c_mode), "0"b, "0"b, "0"b, 1);
2103                end;
2104 
2105      end check_mode;
2106 
2107 /**************************************************************************/
2108 %page;
2109 command_query_no_entrypoint:  proc (explain_to_users, ask_users_question) returns (char (200) varying);
2110 
2111 
2112           dcl     ask_users_question     char (*);
2113           dcl     explain_to_users       char (*);
2114           dcl     get_users_answer       char (64);
2115 
2116 /* external entry */
2117           dcl     command_query_         entry options (variable);
2118 
2119 %page;
2120 %include query_info;
2121 %page;
2122 /* begin coding */
2123           who_asked = ssu_$get_subsystem_and_request_name (sci_ptr);
2124 
2125           unspec (query_info) = "0"b;                       /* clear out query_info structure */
2126 
2127           query_info.version = query_info_version_6;
2128           query_info.prompt_after_explanation = "1"b;
2129           query_info.question_iocbp, query_info.answer_iocbp = null;
2130           query_info.explanation_ptr = addr (explain_to_users);
2131           query_info.explanation_len = length (explain_to_users);
2132 
2133           call command_query_ (addr (query_info), get_users_answer, (who_asked), ask_users_question);
2134 
2135           return (rtrim (get_users_answer));
2136 
2137      end command_query_no_entrypoint;
2138 
2139 /**************************************************************************/
2140 %page;
2141 command_query_yes_no: proc (interpretation_string, query_string) returns (bit (1) aligned);
2142 
2143 /* ask users for a yes or no answer.                                      */
2144 
2145           dcl     A_YES_OR_NO_ANSWER     bit (1) aligned;
2146           dcl     interpretation_string  char (95);
2147           dcl     query_string           char (28);
2148 
2149 /* external entry */
2150           dcl     command_query_$yes_no  entry options (variable);
2151 
2152 /* begin coding */
2153           A_YES_OR_NO_ANSWER = "0"b;
2154 
2155           who_asked = ssu_$get_subsystem_and_request_name (sci_ptr);
2156 
2157           call command_query_$yes_no (A_YES_OR_NO_ANSWER, 0, (who_asked), interpretation_string, query_string);
2158 
2159           return (A_YES_OR_NO_ANSWER);
2160 
2161      end command_query_yes_no;
2162 
2163 /**************************************************************************/
2164 %page;
2165 detach_file_if_attached: proc ();
2166 
2167 /* detach an old file if it was already attached.                         */
2168 
2169 /* begin coding */
2170           if rtq_info.f_attached then do;
2171                     call iox_$close (rtq_info.fiocb_ptr, (0));
2172                     call iox_$detach_iocb (rtq_info.fiocb_ptr, (0));
2173                     rtq_info.last_job_deck_flg, rtq_info.f_attached = "0"b;
2174                end;
2175 
2176      end detach_file_if_attached;
2177 
2178 /***************************************************************************/
2179 %page;
2180 detach_tape_file: proc (sci_ptr, rtq_info_ptr);
2181 
2182 /* detach and close tape and file.                                         */
2183 
2184           dcl     release_area_          entry (ptr);
2185           dcl     release_temp_segment_  entry (char (*), ptr, fixed bin (35));
2186           dcl     (rtq_info_ptr, sci_ptr) ptr;
2187 
2188 /* close and detach  tape switch which was attached and opened earlier */
2189           if rtq_info.tiocb_ptr ^= null then do;
2190                     call iox_$close (rtq_info.tiocb_ptr, (0));
2191                     call iox_$detach_iocb (rtq_info.tiocb_ptr, (0));
2192                     rtq_info.tiocb_ptr = null;
2193                end;
2194 
2195 /* release temp segment if already allocated */
2196           if rtq_info.tptr ^= null then
2197                call release_temp_segment_ (pname, rtq_info.tptr, (0)); /* release our tape buffer */
2198 
2199 /* release an area which already assigned */
2200           if rtq_info.rtq_area_ptr ^= null then do;
2201                     call release_area_ (rtq_info.rtq_area_ptr);
2202                     ai.areap = null;
2203                end;
2204 
2205 /* if file was attached then detach it */
2206           call detach_file_if_attached;
2207 
2208           return;
2209 
2210      end detach_tape_file;
2211 
2212 /**************************************************************************/
2213 %page;
2214 determine_tape_label_types: proc ();
2215 
2216 /* determine the tape label type and then process the specified tape type */
2217 /* (e.g. MULTICS, GCOS, IBM, ANSI)                                        */
2218 
2219 /* begin code */
2220           if rtq_info.tptr -> mult.lab_id = header_c1 then do; /* Multics standard tape */
2221                     rcd_volid = rtq_info.tptr -> mult.tape_reel_id; /* copy volume id directly */
2222                     rtq_info.l_type = v1_mult_label;
2223                end;                                         /* MULTICS standard tape */
2224 
2225           else if rtq_info.tptr -> mult.lab_id = label_c1 then do; /* is this a bootable MST? */
2226 
2227                     if (rtq_info.tptr -> mst_label.head.c1 = header_c1) & (rtq_info.tptr -> mst_label.head.label) then do;
2228                               rcd_volid = rtq_info.tptr -> mst_label.tape_reel_id; /* copy volume id directly */
2229                               rtq_info.l_type = v3_mult_label;
2230                          end;
2231                end;
2232 
2233           else if rtq_info.tptr -> gcos.lab_id = g_label then do; /* GCOS standard tape */
2234                     call bcd_to_ascii_ (rtq_info.tptr -> gcos.vol_id, rcd_volid); /* convert bcd */
2235                     rtq_info.l_type = 3;                    /* gcos_label value */
2236                end;                                         /* GCOS standard tape */
2237 
2238           else if rtq_info.tptr -> ibm_ansi.lab_id = i_label then do; /* IBM standard tape */
2239                     call ebcdic8_to_ascii_ (rtq_info.tptr -> ibm_ansi.vol_id, rcd_volid); /* convert packed ebcdic to ascii */
2240                     rtq_info.l_type = ibm_label;
2241                end;                                         /* IBM standard tape */
2242 
2243           else if rtq_info.tptr -> ibm_ansi.lab_id = a_label then do; /* ANSI standard tape */
2244                     do i = 0 to 5;                          /* unpack 8bit ascii to 9bit ascii */
2245                          blab (i) = "0"b || substr (rtq_info.tptr -> ibm_ansi.vol_id, (i * 8) + 1, 8);
2246                     end;
2247                     rtq_info.l_type = ansi_label;
2248                end;                                         /* ANSI standard tape */
2249 
2250           else if rtq_info.tptr -> cp5_lab.lab_id = CP5_label then do; /* cp5 stand tape */
2251                     call ebcdic8_to_ascii_ (rtq_info.tptr -> cp5_lab.vol_id, rcd_volid); /* convert tape name */
2252                     rtq_info.l_type = cp5_label;
2253                end;                                         /* CP5 standard tape */
2254 
2255           else do;                                          /* unlabeled tape */
2256                     call ioa_ ("Tape ^a is ^a or has unrecognized label.^/Tape will remain positioned at BOT.",
2257                          rtq_info.tape_name, LABEL (rtq_info.l_type));
2258 
2259                     return;
2260                end;
2261 
2262           call ioa_ ("Tape ^a is a labeled ^a tape.^/Volume name recorded on tape label is ^a.",
2263                rtq_info.tape_name, LABEL (rtq_info.l_type), rcd_volid);
2264 
2265           if rtq_info.l_type = ibm_label | rtq_info.l_type = ansi_label then do; /* if IBM or ANSI tape */
2266                     call check_mode (NINE_MODE);            /* set reading mode to nine */
2267 
2268                     call process_control_order ("forward_record", "1"b, "1"b, "0"b, 2); /* space to HDR2 record */
2269 
2270                     call read_tape_record ("stop", rtq_info.eof, "0"b, mssf); /* and read it in */
2271 
2272                     if rtq_info.return_subsys_loop_flg then
2273                          return;
2274 
2275                     if ^rtq_info.eof then do;               /* if no error */
2276 
2277                               call ioa_ ("First data file format:");
2278 
2279                               if ^valid_label_record ("0"b) then /* if hdr2 rcd does not exist */
2280 
2281                                    call ssu_$print_message (sci_ptr, 0, "Could not find ^a HDR2 record.", LABEL (rtq_info.l_type));
2282                          end;                               /* if ^eof  */
2283                     else do;                                /* error reading hdr2 record */
2284                               call ssu_$print_message (sci_ptr, 0, "Error reading HDR2 record, tape will be rewound to BOT");
2285 
2286                               call process_control_order ("rewind", "0"b, "0"b, "0"b, 1);
2287 
2288                               return;
2289                          end;                               /* else do */
2290                end;                                         /* if l_type = ibm_label | l_type = ansi_label */
2291 
2292           call ioa_ ("Positioning to beginning of physical tape file # 2, (logical file # 1)");
2293 
2294           call process_control_order ("forward_file", "1"b, "1"b, "1"b, 1);
2295 
2296           return;
2297 
2298      end determine_tape_label_types;
2299 
2300 /***************************************************************************/
2301 %page;
2302 get_file_name: proc (dtype, nchars);
2303 
2304 /* get file name from gcos card or query user.                             */
2305 
2306           dcl     dtype                  char (5);
2307           dcl     nchars                 fixed bin (21);
2308           dcl     output_filename        char (168) aligned;
2309 
2310 /* begin coding */
2311           if nchars >= 73 then /* if full card */
2312                if substr (rtq_info.cbufp -> cbuf, 73, 4) ^= "" |
2313                     substr (rtq_info.cbufp -> cbuf, 73, 4) ^= "0000" then do; /* and not garbage */
2314                          rtq_info.filename = rtrim (substr (rtq_info.cbufp -> cbuf, 73, 4)); /* extract name */
2315                          i = index (rtq_info.filename, NL); /* check for imbedded newline */
2316                          if i ^= 0 then /* remove it if so */
2317                               substr (rtq_info.filename, i) = substr (rtq_info.filename, i + 1);
2318                     end;
2319                else ;
2320           else do;                                          /* name not on card, query user */
2321                     call ioa_ ("^a", substr (rtq_info.cbufp -> cbuf, 1, 80)); /* display card image for user */
2322 
2323                     rtq_info.tmr = "0"b;                    /* initialize terminate condition */
2324                     output_filename = "";
2325                     do while (^rtq_info.tmr);               /* if no filename */
2326                          output_filename = command_query_no_entrypoint ("Please enter an output file name.", "Ouput file name:  ");
2327 
2328                          rtq_info.tmr = valid_pathname ((output_filename), "");
2329                          if ^rtq_info.tmr then
2330                               goto PATHNAME_ERROR;
2331                     end;                                    /* do while ^rtq_info.tmr */
2332                end;                                         /* else do */
2333 
2334           if ^valid_pathname ((rtq_info.filename), dtype) then do;
2335 
2336 PATHNAME_ERROR:
2337                     call ssu_$print_message (sci_ptr, scode, "Expanding pathname for file name ""^a""", rtq_info.filename);
2338                     rtq_info.return_subsys_loop_flg = "1"b;
2339                     return;                                 /* return subsystem */
2340                end;
2341 
2342           rtq_info.fw_file = "0"b;                          /* reset switch so we get message */
2343 
2344      end get_file_name;
2345 
2346 /***************************************************************************/
2347 %page;
2348 get_output_descript_and_attach: proc ();
2349 
2350 /* query users for the output attach description and an opening mode       */
2351 /* before invoke "attach_and_open_output_file" internal procedure.         */
2352 
2353 /* if file not attached already */
2354           if ^rtq_info.f_attached then do;
2355 
2356                     attach_desc_output = command_query_no_entrypoint ("Please enter an output attach description.", "Output attach description:  ");
2357 
2358                     att_desc = attach_desc_output;          /* copy attach description */
2359 
2360                     attach_desc_output = command_query_no_entrypoint ("Please enter an opening mode.", "Opening mode:  ");
2361 
2362 /* loop throught two given arrays of modes to find a matched mode */
2363                     do i = 1 to hbound (iox_modes, 1)
2364                          while (attach_desc_output ^= iox_modes (i) & attach_desc_output ^= short_iox_modes (i));
2365                     end;
2366 
2367                     if i > hbound (iox_modes, 1) then do;   /* invalid mode specification */
2368                               call ssu_$print_message (sci_ptr, 0, "Invalid opening mode specification ""^a""", attach_desc_output);
2369 
2370                               rtq_info.return_subsys_loop_flg = "1"b;
2371                               return;
2372                          end;
2373 
2374 /* set opening mode to user's specified mode */
2375                     open_mode = i;
2376 
2377 /* attach file now to make sure i/o module exists */
2378                     call attach_and_open_output_file;
2379                end;                                         /* if ^rtq_info.f_attached */
2380 
2381           return;
2382 
2383      end get_output_descript_and_attach;
2384 
2385 /***************************************************************************/
2386 %page;
2387 get_tape_status: proc;
2388 
2389 /* get octal and English description of tape error.                        */
2390 
2391           dcl     analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72) aligned, bit (18) aligned);
2392 
2393 /* begin coding */
2394           status_story = "";                                /* clear old description first */
2395           call iox_$control (rtq_info.tiocb_ptr, "saved_status", addr (t_stat), scode);
2396 
2397           call analyze_device_stat_$rsnnl (status_story, addr (tape_status_table_$tape_status_table_), (t_stat), ("0"b));
2398 
2399      end get_tape_status;
2400 
2401 /****************************************************************************/
2402 %page;
2403 process_control_order: proc (a_order, a_rpt, a_dir, a_rf, a_cnt);
2404 
2405 /* process control orders (non-data xfer tape commands)                     */
2406 
2407           dcl     a_cnt                  fixed bin (35);
2408           dcl     a_dir                  bit (1) aligned;
2409           dcl     a_order                char (*);
2410           dcl     a_rf                   bit (1) aligned;
2411           dcl     a_rpt                  bit (1) aligned;
2412           dcl     backspace_file_flg     bit (1) aligned init ("0"b);
2413           dcl     count                  fixed bin (35);
2414           dcl     i                      fixed bin (35);
2415           dcl     order                  char (16);
2416 
2417 /* begin coding */
2418           order = a_order;                                  /* copy control order */
2419           count = a_cnt;                                    /* copy count arg */
2420           backspace_file_flg = "0"b;                        /* reset backspace file flag if set */
2421 
2422           if a_rpt then do;                                 /* if space cmd */
2423                     if ^a_dir then do;                      /* backspace cmd */
2424                               if a_rf then do;              /* file cmd */
2425                                         if rtq_info.c_file - count < 1 then do; /* can't backspace that far */
2426 
2427                                                   call ioa_ ("Tape will be positioned at BOT");
2428 
2429                                                   call process_control_order ("rewind", "0"b, "0"b, "0"b, 1); /* call ourselves recursively */
2430                                                   return;
2431                                              end;
2432                                         else do;            /* backspace file, or begin file */
2433                                                   rtq_info.c_rec = 1; /* deterimine the first record in the file */
2434 
2435                                                   if order = "begin_file" then do; /* if begin file operation */
2436                                                             order = "backspace_file";
2437                                                             backspace_file_flg = "1"b; /* set backspace file flag */
2438                                                        end;
2439                                                   else do;  /* a real backspace file */
2440                                                             /* decrement file number to "count" time(s) and go back count + 1 files */
2441                                                             rtq_info.c_file = rtq_info.c_file - count;
2442 
2443                                                             if rtq_info.c_file > 1 then
2444                                                                  backspace_file_flg = "1"b;
2445 
2446                                                             count = count + 1; /* really going back n + 1 files */
2447                                                        end; /* else do */
2448                                              end;           /* else do */
2449                                    end;                     /* a_rf */
2450                               else if rtq_info.c_rec - count < 1 then do; /* record cmd */
2451                                         call ioa_ ("Tape will be positioned at beginning of file ^d", rtq_info.c_file);
2452 
2453                                         call process_control_order ("begin_file", "1"b, "0"b, "1"b, 1); /* call ourselves recursively */
2454                                         return;
2455                                    end;                     /* else if c_rec - count < 1 */
2456                               else rtq_info.c_rec = rtq_info.c_rec - count; /* bsr ok, reset position */
2457 
2458                          end;                               /* ^a_dir */
2459                     else do;                                /* a_dir  means a forward space cmd */
2460                               if a_rf then do;              /* file cmd */
2461                                         rtq_info.c_rec = 1; /* reset position counters */
2462                                         rtq_info.c_file = rtq_info.c_file + count;
2463                                    end;
2464                               else if ^rtq_info.eof_request_flg then
2465                                    rtq_info.c_rec = rtq_info.c_rec + count; /* fsr cmd */
2466                          end;                               /* else do */
2467                end;                                         /* if a_rpt  means a space cmd */
2468 
2469           if order = "rewind" then /* if order is rewind */
2470                rtq_info.c_rec, rtq_info.c_file = 1;         /* reset position */
2471 
2472           do i = 1 to count;                                /* iterate control order requested times */
2473                call iox_$control (rtq_info.tiocb_ptr, order, null, scode);
2474 
2475                if scode ^= 0 then do;
2476                          if scode = error_table_$end_of_info & rtq_info.records_in_file_flg then do;
2477                                    scode = 0;               /* must reset to zero so that the next if statement will false */
2478                                    i = i - 1;               /* want to reposition back to the original position */
2479                               end;
2480 
2481                          if ^rtq_info.eof_request_flg & scode ^= 0 then do;
2482 
2483                                    save_status_code = scode;
2484                                    call get_tape_status;    /* get English desc of tape error */
2485 
2486                                    call ssu_$print_message (sci_ptr, save_status_code,
2487                                         "^/Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while executing iteration # ^d of ^a control order",
2488                                         t_stat, (status_story ^= ""), status_story, i, a_order);
2489                                    return;
2490                               end;
2491                     end;                                    /* scode ^= 0 */
2492           end;                                              /* do i = 1 to count */
2493 
2494           if backspace_file_flg then do;                    /* if a backspace file operation */
2495                     call iox_$control (rtq_info.tiocb_ptr, "forward_file", null, scode); /* position to beginning of next file */
2496                     if scode ^= 0 then do;
2497                               save_status_code = scode;
2498                               call get_tape_status;         /* get English desc of tape error */
2499 
2500                               call ssu_$print_message (sci_ptr, save_status_code,
2501                                    "^/Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while forward spacing to beginning of file ^d",
2502                                    t_stat, (status_story ^= ""), status_story, rtq_info.c_file);
2503                               return;
2504                          end;
2505                end;                                         /* a bsf command */
2506 
2507      end process_control_order;
2508 
2509 /***************************************************************************/
2510 %page;
2511 process_logical_record_length: proc ();
2512 
2513 /* users want each physical tape record to be written into several logical  */
2514 /* records of a specified length.  So do it.                                */
2515 
2516 /* begin coding */
2517           it_cnt = divide (rtq_info.rec_len - schar, l_rec_len, 17, 0); /* determine # of logical records */
2518           spill = mod (rtq_info.rec_len - schar, l_rec_len);/* get spill over if any */
2519 
2520           do i = 1 to it_cnt;
2521                rtq_info.cbufp -> cbuf = chcv_buf (i);       /* copy logical record */
2522                temp_logical_rec_len = l_rec_len;
2523 
2524                if open_mode = Stream_output | open_mode = Stream_input_output then do;
2525                          substr (rtq_info.cbufp -> cbuf, l_rec_len + 1, 1) = NL; /* add NL to its end */
2526                          temp_logical_rec_len = temp_logical_rec_len + 1;
2527                     end;
2528 
2529                call write_file (rtq_info.cbufp, temp_logical_rec_len, s_filename); /* and write it out */
2530 
2531                if rtq_info.return_subsys_loop_flg then
2532                     return;
2533 
2534           end;
2535 
2536           if spill ^= 0 then do;                            /* if some left over */
2537                     it_cnt = it_cnt + 1;                    /* need 1 more subsrcipt for spill */
2538                     rtq_info.cbufp -> cbuf = substr (chcv_buf (it_cnt), 1, spill);
2539 
2540                     if open_mode = Stream_output | open_mode = Stream_input_output then do;
2541                               substr (rtq_info.cbufp -> cbuf, spill + 1, 1) = NL; /* copy spillover */
2542                               spill = spill + 1;            /* for the NL */
2543                          end;
2544 
2545                     call write_file (rtq_info.cbufp, spill, s_filename); /* and write it out too */
2546 
2547                     if rtq_info.return_subsys_loop_flg then
2548                          return;
2549 
2550                end;                                         /* process some record left over */
2551 
2552           return;
2553 
2554      end process_logical_record_length;
2555 
2556 /***************************************************************************/
2557 %page;
2558 read_file_get_control_args: proc ();
2559 
2560 /* process optional input control arguments for "read_file" request */
2561 
2562           do arg_dex = 1 to Nargs;
2563                call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
2564                if arg = "-gcos" | arg = "-gc" then do;      /* file in gcos standard system format */
2565                          gssf = "1"b;
2566                          call check_mode (BINARY_MODE);     /* must read data in binary mode */
2567                          n_ops = n_ops + 1;                 /* increment for inconsistancy  check */
2568                     end;
2569 
2570                else if arg = "-multics" | arg = "-mult" then do; /* file in multics standard system format */
2571                          mssf = "1"b;
2572                          call check_mode (BINARY_MODE);     /* must read data in binary mode */
2573                          n_ops = n_ops + 1;                 /* increment for inconsistancy  check */
2574                     end;
2575 
2576                else if arg = "-extend" then /* if file extend option desired */
2577                     rtq_info.extend_sw = "1"b;
2578 
2579                else if arg = "-nnl" then /* if user don't want new line on raw File */
2580                     nnl_sw = "1"b;
2581 
2582                else if arg = "-output_description" | arg = "-ods" then /* user wants to attach spec device */
2583                     rtq_info.atd_sw = "1"b;
2584 
2585                else if arg = "-cp5" then do;                /* cp5 variable length records */
2586                          cp5 = "1"b;                        /* set flag */
2587                          call check_mode (NINE_MODE);       /* must read data in nine bit mode */
2588                          n_ops = n_ops + 1;                 /* increment for inconsistancy  check */
2589                     end;
2590 
2591                else if arg = "-dec" then do;                /* DEC 40 bit word records */
2592                          lrp = rtq_info.cvbp;               /* set conversion buffer pointer */
2593                          dec_sw = "1"b;                     /* set flag */
2594                          call check_mode (BINARY_MODE);     /* must read data in binary mode */
2595                          n_ops = n_ops + 1;                 /* increment for inconsistancy  check */
2596                     end;
2597 
2598                else if arg = "-ibm_vb" then do;             /* IBM "VB" records */
2599                          ibmv = "1"b;                       /* set flag */
2600                          if arg_dex < Nargs then do;
2601                                    call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2602                                    if substr (arg, 1, 1) ^= "-" then do;
2603                                              arg_dex = arg_dex + 1;
2604                                              if arg = "binary" | arg = "bin" then
2605                                                   rtq_info.set_bin = "1"b;
2606                                              else if arg = "ebcdic" then
2607                                                   c_e_a = "1"b;
2608                                              else if arg ^= "ascii" then do;
2609 IBM_VB_ERROR:
2610                                                        call ssu_$print_message (sci_ptr, 0,
2611                                                             " Usage:  read_file (rdfile) {-ibm_vb {ascii | binary (bin) | ebcdic}}");
2612                                                        goto GET_CONTROL_ARG_ERROR;
2613                                                   end;      /* else if arg ^= "ascii" */
2614                                         end;                /* if substr (arg, 1, 1) ^= "-" */
2615                                    else c_e_a = "1"b;       /* ebcdic conversion by default */
2616                               end;                          /* arg_dex < Nargs */
2617                          else if arg_dex = Nargs then
2618                               c_e_a = "1"b;                 /* ebcdic conversion by default */
2619                          else goto IBM_VB_ERROR;
2620                          if rtq_info.set_bin then /* if we need to read in binary mode */
2621                               call check_mode (BINARY_MODE);/* go set it */
2622                          else call check_mode (NINE_MODE);  /* otherwise read in nine mode */
2623                          n_ops = n_ops + 1;                 /*  for inconsistancy  check */
2624                     end;                                    /* else if arg = "-ibm_vb" */
2625 
2626                else if arg = "-ansi_db" then do;            /* ANSI "DB" records */
2627                          ansid = "1"b;                      /* set flag */
2628                          if arg_dex < Nargs then do;
2629                                    call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2630                                    if substr (arg, 1, 1) ^= "-" then do;
2631                                              arg_dex = arg_dex + 1; /* advance argument index */
2632                                              if arg = "binary" | arg = "bin" then
2633                                                   rtq_info.set_bin = "1"b;
2634                                              else if arg = "ebcdic" then
2635                                                   c_e_a = "1"b;
2636                                              else if arg ^= "ascii" then do;
2637 ANSI_DB_ERROR:
2638                                                        call ssu_$print_message (sci_ptr, 0,
2639                                                             "Usage:  read_file (rdfile) {-ansi_db {ascii | binary (bin) | ebcdic}}");
2640                                                        goto GET_CONTROL_ARG_ERROR;
2641                                                   end;
2642                                         end;                /* if substr (arg, 1, 1) ^= "-" */
2643                               end;                          /* arg_dex < Nargs */
2644                          else if arg_dex > Nargs then
2645                               goto ANSI_DB_ERROR;
2646                          else ;
2647                          if rtq_info.set_bin then /* if we need to read in binary mode */
2648                               call check_mode (BINARY_MODE);/* go set it */
2649                          else call check_mode (NINE_MODE);  /* otherwise read in nine mode */
2650                          n_ops = n_ops + 1;                 /* increment for inconsistancy  check */
2651                     end;                                    /* ANSI "DB" record */
2652 
2653                else if arg = "-truncate" | arg = "-tc" then do; /* user wants to truncate phy records */
2654                          if arg_dex < Nargs then do;
2655                                    call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2656                                    tr_cnt = cv_dec_check_ (arg, scode);
2657                                    if scode ^= 0 then do;
2658 TC_ERROR:
2659                                              call ssu_$print_message (sci_ptr, scode,
2660                                                   "^/     Usage:  read_file (rdfile) {-truncate (-tc) N}");
2661                                              goto GET_CONTROL_ARG_ERROR;
2662                                         end;
2663                                    arg_dex = arg_dex + 1;   /* advance argument index */
2664                                    trunc_sw = "1"b;
2665                               end;                          /* if arg_dex < Nargs */
2666                          else do;
2667                                    scode = 0;
2668                                    goto TC_ERROR;
2669                               end;
2670                     end;                                    /* -truncate (-tc) */
2671 
2672                else if arg = "-logical_record_length" | arg = "-lrl" then do; /* process log records */
2673                          if arg_dex < Nargs then do;
2674                                    call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2675                                    l_rec_len = cv_dec_check_ (arg, scode);
2676                                    if scode ^= 0 then do;
2677 LRL_ERROR:
2678                                              call ssu_$print_message (sci_ptr, scode,
2679                                                   "^/     Usage:  read_file (rdfile) {-logical_record_length (-lrl) N}");
2680                                              goto GET_CONTROL_ARG_ERROR;
2681                                         end;
2682                                    arg_dex = arg_dex + 1;   /* advance argument index */
2683                                    if l_rec_len > length (rtq_info.cbufp -> cbuf) then do; /* better to tell user of limitation */
2684                                              call ssu_$print_message (sci_ptr, 0,
2685                                                   "Logical record lengths > ^d characters not supported", length (rtq_info.cbufp -> cbuf));
2686                                              goto GET_CONTROL_ARG_ERROR;
2687                                         end;
2688                                    l_rec = "1"b;
2689                                    n_ops = n_ops + 1;       /* increment for inconsistancy  check */
2690                               end;                          /* if arg_dex < Nargs */
2691                          else do;
2692                                    scode = 0;
2693                                    goto LRL_ERROR;
2694                               end;
2695                     end;                                    /* -logical_record_length (-lrl) */
2696 
2697                else if arg = "-count" | arg = "-ct" then do;/* user wants to read multiple files */
2698                          if arg_dex < Nargs then do;
2699                                    call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2700                                    iterations = cv_dec_check_ (arg, scode); /* check for rdfile iterations */
2701                                    if scode ^= 0 then do;
2702 CNT_ERROR:
2703                                              call ssu_$print_message (sci_ptr, scode,
2704                                                   "^/     Usage:  read_file (rdfile) {-count (-ct) N}");
2705                                              goto GET_CONTROL_ARG_ERROR;
2706                                         end;
2707                                    arg_dex = arg_dex + 1;   /* advance argument index */
2708                               end;                          /* if arg_dex < Nargs */
2709                          else do;                           /* missing N for -count */
2710                                    scode = 0;
2711                                    goto CNT_ERROR;
2712                               end;
2713                     end;                                    /* -count (-ct) */
2714 
2715                else if arg = "-skip" then do;               /* user wants to skip some initial chars */
2716                          if arg_dex < Nargs then do;
2717                                    call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2718                                    schar = cv_dec_check_ (arg, scode);
2719                                    if scode ^= 0 then do;
2720 SKIP_ERROR:
2721                                              call ssu_$print_message (sci_ptr, scode,
2722                                                   "^/     Usage:  read_file (rdfile) {-skip N}");
2723                                              goto GET_CONTROL_ARG_ERROR;
2724                                         end;
2725                                    arg_dex = arg_dex + 1;   /* advance argument index */
2726                               end;                          /* if arg_dex < Nargs */
2727                          else do;
2728                                    scode = 0;
2729                                    goto SKIP_ERROR;
2730                               end;
2731                     end;                                    /* -skip */
2732 
2733                else if arg = "-convert" | arg = "-conv" then do; /* user wants to do some conversion */
2734                          if arg_dex < Nargs then do;
2735                                    call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2736                                    arg_dex = arg_dex + 1;   /* advance argument index */
2737                                    if arg = "ebcdic_to_ascii" | arg = "ebcdic" then
2738                                         c_e_a = "1"b;       /* convert ebcdic */
2739                                    else if arg = "bcd_to_ascii" | arg = "bcd" then
2740                                         c_b_a = "1"b;       /* convert bcd */
2741                                    else if arg = "comp8_to_ascii" | arg = "comp8" then do; /* convert comp8 to ascii */
2742                                              c_c_a = "1"b;
2743                                              call check_mode (NINE_MODE); /* must read data in nine bit mode */
2744                                         end;                /* com8_to_ascii (comp8) */
2745                                    else do;
2746 CONV_ERROR:
2747                                              call ssu_$print_message (sci_ptr, 0,
2748                                                   "Usage:  read_file (rdfile) {-convert (-conv) ebcdic_to_ascii (ebcdic) | bcd_to_ascii (bcd) | comp8_to_ascii (comp8)}");
2749                                              goto GET_CONTROL_ARG_ERROR;
2750                                         end;
2751                               end;                          /* if arg_dex < Nargs */
2752                          else goto CONV_ERROR;
2753 
2754                          lrp = rtq_info.cvbp;               /* set conversion buffer pointer */
2755                          n_ops = n_ops + 1;                 /* increment for inconsistancy  check */
2756                     end;                                    /* -convert (-conv) */
2757 
2758                else if arg = "-output_file" | arg = "-of" then do; /* user wants output file specified */
2759                          if arg_dex < Nargs then do;
2760                                    call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
2761                                    if substr (arg, 1, 1) ^= "-" then do; /* don't allow file name to begin with - */
2762                                              arg_dex = arg_dex + 1; /* advance argument index */
2763 
2764                                              if ^valid_pathname ((arg), "") then do; /* error expanding pathname */
2765 OF_ERROR:
2766                                                        call ssu_$print_message (sci_ptr, scode,
2767                                                             "^/     Usage:  read_file (rdfile) {-output_file (-of) FILE_NAME}");
2768                                                        goto GET_CONTROL_ARG_ERROR;
2769                                                   end;
2770 
2771                                         end;
2772                               end;                          /* arg_dex < Nargs */
2773                          else do;
2774                                    scode = 0;
2775                                    goto OF_ERROR;
2776                               end;
2777                     end;                                    /* -output_file (-of) */
2778 
2779                else do;
2780                          call ssu_$print_message (sci_ptr, 0,
2781                               "Invalid input optional control argument ""^a""", arg);
2782                          goto GET_CONTROL_ARG_ERROR;
2783                     end;
2784           end;                                              /* do i = 1 to Nargs */
2785 
2786           return;
2787 
2788 GET_CONTROL_ARG_ERROR:
2789           rtq_info.return_subsys_loop_flg = "1"b;
2790           return;
2791 
2792      end read_file_get_control_args;
2793 
2794 /***************************************************************************/
2795 %page;
2796 read_in_the_entire_file: proc ();
2797 
2798 /* depending on the record format, process each record just read in until  */
2799 /* end of file encountered.  If the file is in GCOS JCL then invoke        */
2800 /* the "write_file" internal procedure to write end of job card.           */
2801 /* Similarly, invoke the "MULT_ssf" to go flush buffer for Multics file.   */
2802 /* Finally, if not extend the file then invokes the                        */
2803 /* "detach_file_if_attached" to detach the file if it was already attached.*/
2804 
2805 /* begin code */
2806           rtq_info.eof, binck = "0"b;
2807           do while (^rtq_info.eof);                         /* read entire file */
2808 
2809                call read_tape_record ("skip", rtq_info.eof, "0"b, mssf); /* read the next record */
2810 
2811                if rtq_info.return_subsys_loop_flg then
2812                     return;
2813 
2814                if ^rtq_info.eof then do;                    /* if not end of file */
2815 
2816                          if valid_label_record ("0"b) then /* if label record */
2817                               goto nxt_rcd;                 /* then don't process */
2818 
2819                          if trunc_sw then
2820                               rtq_info.rec_len = tr_cnt;    /*  wants truncate phy record */
2821 
2822                          if gssf then
2823                               call GCOS_ssf (cont, imcv, nchars, binck, first_record_flg, s_filename);
2824 
2825                          else if mssf then
2826                               call MULT_ssf (first_record_flg, last_record_flg, s_filename); /* MULTICS standard tape */
2827 
2828                          else if cp5 then
2829                               call CP5_variable_length_records;
2830 
2831                          else if dec_sw then
2832                               call DEC_tape_records;
2833 
2834                          else if ibmv then
2835                               call IBM_VB_records;
2836 
2837                          else if ansid then do;
2838                                    conversion_flg = "0"b;
2839                                    call ANSI_DB_records (conversion_flg);
2840                                    if conversion_flg then
2841                                         return;
2842                               end;
2843 
2844                          else do;                           /* not known format, check for conversion */
2845                                    if c_e_a then do;        /* convert ebcdic to ascii */
2846 
2847                                              if rtq_info.c_mode = NINE_MODE then /* if nine mode */
2848                                                   call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf);
2849                                              else do;
2850                                                        rtq_info.rec_len = divide (rtq_info.bits + 8 - 1, 8, 21, 0); /* correct record length */
2851 
2852                                                        call ebcdic8_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf);
2853                                                   end;
2854                                         end;                /* covert ebcdic to ascii */
2855 
2856                                    else if c_b_a then do;   /* bcd to ascii conversion */
2857                                              rtq_info.rec_len = divide (rtq_info.bits + 6 - 1, 6, 21, 0); /* correct record length */
2858                                              call bcd_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf);
2859                                         end;                /* convert bcd to ascii */
2860 
2861                                    else if c_c_a then do;   /* convert comp 8 to ascii */
2862                                              rtq_info.rec_len = divide (rtq_info.bits + 4 - 1, 4, 21, 0); /* correct record length */
2863                                              call comp_8_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf);
2864                                         end;                /* convert comp 8 to ascii */
2865 
2866                                    if l_rec then
2867                                         call process_logical_record_length;
2868 
2869                                    else if rtq_info.atd_sw | nnl_sw then /* let he writes to what he wants */
2870                                         call write_file (addr (conv_buf.conv_dta), rtq_info.rec_len - schar, s_filename);
2871 
2872                                    else do;                 /* write a raw file by default */
2873                                              substr (conv_buf.conv_dta, rtq_info.rec_len - schar + 1, 1) = NL;
2874                                                             /* to prevent string range condition */
2875                                              rtq_info.rec_len = (rtq_info.rec_len - schar) + 1; /* set correct record length */
2876 
2877                                              call write_file (addr (conv_buf.conv_dta), rtq_info.rec_len, s_filename);
2878                                         end;
2879                               end;                          /* unknown format */
2880                     end;                                    /* if ^rtq_info.eof */
2881 
2882                if rtq_info.return_subsys_loop_flg then
2883                     return;
2884 
2885 nxt_rcd:
2886           end;                                              /* do while ^rtq_info.eof */
2887 
2888           if gssf then do;
2889                     if rtq_info.last_job_deck_flg then do;
2890 
2891                               call write_file (addr (eoj_card), length (eoj_card), s_filename); /* if gcos jcl, write eoj card */
2892 
2893                               if rtq_info.return_subsys_loop_flg then
2894                                    return;
2895                          end;
2896                end;
2897 
2898           if mssf then do;                                  /* if Multics standard system format */
2899                     last_record_flg = "1"b;                 /* don't forget last data in buffer */
2900 
2901                     call MULT_ssf (first_record_flg, last_record_flg, s_filename); /* go flush buffer */
2902 
2903                     if rtq_info.return_subsys_loop_flg then
2904                          return;
2905                end;
2906 
2907           if ^rtq_info.extend_sw then /* if not extending this file */
2908 
2909                call detach_file_if_attached;                /* just in case we had a file attached */
2910 
2911      end read_in_the_entire_file;
2912 
2913 /***************************************************************************/
2914 %page;
2915 read_tape_record: proc (neg, end_file, quiet_sw, mssf);
2916 
2917 /* read in the next sequential tape record in the file.  If the returned  */
2918 /* scode value is zero then increment the record number by 1, set buffer  */
2919 /* full flag so we can dump the record, calculate the record length in    */
2920 /* bits, and reset the end of file flag.  If the returned scode value     */
2921 /* indicates end of file encountered then if end of file flag or end of   */
2922 /* volume flag was previously set then set end of tape flag, else set end */
2923 /* of file flag.  If not suppress output then display appropriate         */
2924 /* messages to users and adjust the record number to the first record in  */
2925 /* the file.  Increment file number by 1, adjust the record length in     */
2926 /* bits to zero, and set end_file flag indicating end of file             */
2927 /* encountered.  If the returned scode value indicates tape error then    */
2928 /* invoke "get_tape_status" to get tape error number and English          */
2929 /* description.  If the tape error record is in Multics format then       */
2930 /* re-try to read it again up to 10 times before reporting to users.      */
2931 /* Ask users whether they want to retry again or to skip that error       */
2932 /* record or to return to the rtq request loop.                           */
2933 
2934 /* automatic storage */
2935           dcl     auto_retry             fixed bin;
2936           dcl     end_file               bit (1) aligned;
2937           dcl     explanation_string     char (95);
2938           dcl     get_answer             char (5) varying;  /* max len is 5 characters */
2939           dcl     mssf                   bit (1) aligned;
2940           dcl     neg                    char (6);
2941           dcl     query_flg              bit (1) aligned;
2942           dcl     question_string        char (20);
2943           dcl     quiet_sw               bit (1) aligned;
2944 
2945 
2946 /* begin coding */
2947           if rtq_info.two_eofs then goto gleot;             /* if gcos partial header label */
2948 
2949           end_file = "0"b;                                  /* reset eof indicator */
2950           auto_retry = 0;                                   /* intiialize auto retry count */
2951 
2952 retry_rd:
2953           call iox_$read_record (rtq_info.tiocb_ptr, rtq_info.tptr, rtq_info.buf_size - NUMB_OF_CHARS_PER_WORD, rtq_info.rec_len, scode);
2954                                                             /* minus 4 because must reserve 1 word for appending a New Line character after returning to the caller */
2955           if scode ^= 0 then do;
2956 
2957                     if scode ^= error_table_$end_of_info then do;
2958                               save_status_code = scode;
2959                               call get_tape_status;         /* get English desc of tape error */
2960 
2961                               if mssf then do;              /* reading a Multics standard system format tape */
2962                                         auto_retry = auto_retry + 1;
2963                                         if auto_retry > 10 then do; /* exceeded error threshold */
2964                                                   call ssu_$print_message (sci_ptr, save_status_code,
2965                                                        "^/Tape status = ^4.3b.^/^[""^a""^;^1s^] ^/     Therefore, skipping record ^d, file ^d, ^a.",
2966                                                        t_stat, (status_story ^= ""), status_story, rtq_info.c_rec,
2967                                                        rtq_info.c_file, "due to unrecoverable read error");
2968 
2969                                                   rtq_info.c_rec = rtq_info.c_rec + 1; /* increment record number */
2970                                              end;           /* exceeded error threshold */
2971                                         else call iox_$control (rtq_info.tiocb_ptr, "backspace_record", null, scode); /* back it up */
2972 
2973                                         go to retry_rd;     /* and go read next record */
2974                                    end;                     /* reading a MULTICS Standard Label tape */
2975 
2976                               call ssu_$print_message (sci_ptr, save_status_code,
2977                                    "Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while reading record ^d, file ^d",
2978                                    t_stat, (status_story ^= ""), status_story, rtq_info.c_rec, rtq_info.c_file);
2979 
2980                               if neg ^= "stop" then do;     /* neg = "skip" */
2981                                         explanation_string = "Do you want to retry, skip to the next record, or stop?  Answer ""retry"", ""skip"", or ""stop"".";
2982                                         question_string = "Retry, skip or stop?";
2983                                    end;
2984                               else do;                      /* neg = "stop" */
2985                                         explanation_string = "Do you want to retry or stop?  Answer ""retry"" or ""stop"".";
2986                                         question_string = "Retry or stop?";
2987                                    end;
2988 
2989                               get_answer = command_query_no_entrypoint (explanation_string, question_string);
2990 
2991                               query_flg = "1"b;
2992                               do while (query_flg);
2993                                    query_flg = "0"b;        /* exit do loop */
2994                                    if get_answer = "retry" then do;
2995                                              call iox_$control (rtq_info.tiocb_ptr, "backspace_record", null, scode);
2996 
2997                                              if scode = error_table_$end_of_info then
2998                                                   goto END_OF_INFO_REACHED;
2999                                              else go to retry_rd;
3000                                         end;
3001 
3002                                    else if get_answer = "skip" then do;
3003                                              rtq_info.c_rec = rtq_info.c_rec + 1; /* increment record number */
3004                                              go to retry_rd;/* and go read it */
3005                                         end;
3006 
3007                                    else if get_answer = "stop" then do;
3008                                              rtq_info.return_subsys_loop_flg = "1"b;
3009                                              end_file = "1"b; /* indicate error */
3010                                              return;        /* return to request loop */
3011                                         end;
3012 
3013                                    else do;
3014                                              get_answer = command_query_no_entrypoint (explanation_string, question_string);
3015 
3016                                              query_flg = "1"b;
3017                                         end;
3018                               end;                          /* do while */
3019                          end;                               /* if scode ^= error_table_$end_of_info */
3020 
3021                     else do;                                /* end of file */
3022 END_OF_INFO_REACHED:
3023                               if rtq_info.one_eof | rtq_info.eov then rtq_info.two_eofs = "1"b; /* indicate physical end of tape */
3024                               else rtq_info.one_eof = "1"b; /*  no set one eof indicator */
3025 
3026 gleot:
3027                               if ^quiet_sw then do;         /* if not suppressing output */
3028                                         if rtq_info.two_eofs then do; /* if at physical end of tape, tell user */
3029                                                   call ioa_ ("End of file encountered on file # ^d.  No data read.", rtq_info.c_file);
3030 
3031                                                   call ioa_ ("Logical end of tape at physical file # ^d", rtq_info.c_file);
3032                                              end;
3033                                         else do;
3034                                                   if rtq_info.c_rec = 1 then do;
3035                                                             call ioa_ ("End of file encountered on file # ^d.  No data read.", rtq_info.c_file);
3036 
3037                                                             call ioa_ ("Positioning to start of file # ^d.", rtq_info.c_file + 1);
3038                                                        end;
3039                                                   else do;
3040                                                             call ioa_ ("End of file after ^d record^[s^] read from tape file # ^d",
3041                                                                  rtq_info.c_rec - 1, (rtq_info.c_rec > 2), rtq_info.c_file);
3042                                                             call ioa_ ("Positioning to start of file # ^d.", rtq_info.c_file + 1);
3043                                                        end;
3044                                              end;
3045 
3046                                         rtq_info.c_rec = 1; /* reset record number */
3047                                    end;
3048 
3049                               rtq_info.c_file = rtq_info.c_file + 1; /* increment file number */
3050                               rtq_info.bits = 0;            /* reset number of bits */
3051                               end_file = "1"b;              /* and turn on eof indicator */
3052                          end;                               /* end of file */
3053                end;                                         /* scode ^= 0 */
3054           else do;                                          /* scode = 0 */
3055                     rtq_info.c_rec = rtq_info.c_rec + 1;    /* no tape errors, increment record number */
3056                     rtq_info.buf_ful = "1"b;                /* set buffer ful switch so we can dump record */
3057                     rtq_info.bits = rtq_info.rec_len * 9;   /* and calculate bit len of record */
3058                     rtq_info.one_eof = "0"b;                /* reset one eof indicatior if set */
3059                end;
3060 
3061      end read_tape_record;
3062 
3063 /***************************************************************************/
3064 %page;
3065 record_information: proc (numrecs, nbits, rcd_tally);
3066 
3067 /* display a record length in bits, words, nine-bit bytes, eight-bit bytes, */
3068 /* and in six-bit characters.                                               */
3069 
3070           dcl     (bit6, bit8, bit9)     fixed bin (35) init (0);
3071           dcl     (nbits, numrecs)       fixed bin (35);
3072           dcl     rcd_tally              bit (1);
3073 
3074 /* begin coding */
3075           if ^rcd_tally then /* if called from rdrec request */
3076                if valid_label_record ("1"b) then return;    /* check for valid label record */
3077 
3078           nwds = divide (nbits, 36, 35);
3079           bit9 = divide (nbits, 9, 35);
3080           bit8 = divide (nbits, 8, 35);
3081           bit6 = divide (nbits, 6, 35);
3082 
3083           call ioa_ ("^[  ^d record^[s^]:^;^2sRecord^] ^a ^d ^a, ^d ^a, ^d ^a,^[^/    ^-^[^- ^;^6x^]^;^1s ^]   ^d ^a, ^d ^a",
3084                rcd_tally, numrecs, (numrecs > 1), "length =", nbits, "bits", nwds, "words", bit9,
3085                "nine bit bytes", rtq_info.short_output_flg, rcd_tally, bit8, "eight bit bytes", bit6, "six bit chars");
3086 
3087      end record_information;
3088 
3089 /***************************************************************************/
3090 %page;
3091 valid_label_record: proc (lg_ck) returns (bit (1) aligned);
3092 
3093 /* determines that the record is a LABEL/TRAILER record and displays its   */
3094 /* contents if it is.                                                      */
3095 
3096           dcl     ansi_hdr2_fmt          char (108) int static options (constant) init
3097                                          ("Record format ^a^[^[B^]^;^1s^]; Block length ^d; Record length ^d; Mode ^[ASCII^;EBCDIC^;BINARY^;UNKNOWN^];");
3098 
3099           dcl     (eov, lg_ck)           bit (1) aligned;
3100 
3101 /* begin coding */
3102           go to lab_type (rtq_info.l_type);                 /* check for LABEL records first */
3103 
3104 lab_type (1):                                               /* check for MULTICS label records */
3105           if rtq_info.tptr -> mstr.head.label then do;      /* Multics tape label record */
3106                     call ioa_ ("^[^/^] ^a version ^[2^;1^] label record for volume ^a", (rtq_info.c_rec = 2),
3107                          LABEL (rtq_info.l_type), (unspec (substr (rtq_info.tptr -> mult.volume_set_id, 1, 1)) ^= "777"b3), rtq_info.tptr -> mult.tape_reel_id);
3108 
3109                     if lg_ck then do;                       /* if user wants more info... */
3110                               if substr (rtq_info.tptr -> mstr.head.uid, 18, 1) then /* if uid generated by unique_bits_... */
3111                                    call date_time_ (bin (substr (rtq_info.tptr -> mstr.head.uid, 19, 52), 71), time_string);
3112                               else call date_time_ (bin (rtq_info.tptr -> mstr.head.uid, 71), time_string);
3113 
3114                               call ioa_ ("Tape created on:^-^a", time_string);
3115 
3116                               if rtq_info.tptr -> mult.installation_id ^= "" then /* and this exists then give it to him */
3117                                    call ioa_ ("Tape created at:^-^a", rtq_info.tptr -> mult.installation_id);
3118 
3119                               if unspec (substr (rtq_info.tptr -> mult.volume_set_id, 1, 1)) ^= "777"b3 then /* if version 2 label */
3120                                    if rtq_info.tptr -> mult.volume_set_id ^= "" then /* and volume set exists.. */
3121 
3122                                         call ioa_ ("Volume Set Name:^-^a", rtq_info.tptr -> mult.volume_set_id);
3123                          end;                               /* if log_ck */
3124                end;                                         /* Multics tape LABEL record */
3125 
3126           else if rtq_info.tptr -> mstr.head.eor then /* if end of reel record */
3127                call ioa_ ("^[^/^] ^a end of reel record", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type));
3128           else return ("0"b);                               /* not Multics tape label record */
3129 
3130           return ("1"b);                                    /* was label record, return true */
3131 
3132 
3133 lab_type (2):                                               /* check for version 2 Multics label records */
3134           if rtq_info.c_file = 1 & rtq_info.tptr -> mst_label.head.label then do; /* if Multics tape label record */
3135                     call ioa_ ("^[^/^] ^a version ^d label record for volume ^a", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type),
3136                          rtq_info.tptr -> mst_label.label_version, rtq_info.tptr -> mst_label.tape_reel_id);
3137 
3138                     if lg_ck then do;                       /* if user wants more info */
3139                               if substr (rtq_info.tptr -> mst_label.head.uid, 18, 1) then /* if uid generated by unique_bits_... */
3140                                    call date_time_ (bin (substr (rtq_info.tptr -> mst_label.head.uid, 19, 52), 71), time_string);
3141                               else call date_time_ (bin (rtq_info.tptr -> mst_label.head.uid, 71), time_string);
3142 
3143                               call ioa_ ("Tape created on:^-^a", time_string);
3144 
3145                               if rtq_info.tptr -> mst_label.installation_id ^= "" then /* if one exists, print it */
3146                                    call ioa_ ("Tape created at:^-^a", rtq_info.tptr -> mst_label.installation_id);
3147 
3148                               if rtq_info.tptr -> mst_label.userid ^= "" then /* if one exists, print it */
3149                                    call ioa_ ("Tape created by:^-^a", rtq_info.tptr -> mst_label.userid);
3150 
3151                               if rtq_info.tptr -> mst_label.boot_pgm_path ^= "" then /* if one exists, print it */
3152                                    call ioa_ ("Boot program path:^-^a", rtq_info.tptr -> mst_label.boot_pgm_path);
3153 
3154                               if rtq_info.tptr -> mst_label.volume_set_id ^= "" then /* if this exists, print it */
3155                                    call ioa_ ("Volume Set Name:^-^a", rtq_info.tptr -> mst_label.volume_set_id);
3156 
3157                               if rtq_info.tptr -> mst_label.copyright ^= "" then /* if protection notice exits, print it */
3158                                    call ioa_ ("Protection Notice:^-^a", rtq_info.tptr -> mst_label.copyright);
3159                          end;                               /* if lg_ck */
3160                end;                                         /* it is file 1 and it is MULTICS tape Label record */
3161 
3162           else if rtq_info.tptr -> mstr.head.eor then /* if end of reel record */
3163                call ioa_ ("^[^/^] ^a end of reel record", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type));
3164           else return ("0"b);                               /* not Multics tape label record */
3165 
3166           return ("1"b);                                    /* was label record, return true */
3167 
3168 
3169 lab_type (3):                                               /* check for GCOS Label records */
3170           if rtq_info.bits = 504 then do;                   /* if gcos tape label or eof record */
3171                     call bcd_to_ascii_ (bit_buf, rtq_info.cbufp -> cbuf); /* convert bcd to ascii */
3172 
3173                     if gcos.lab_id = g_label then do;       /* if header label */
3174                               if substr (bit_buf, 145, 216) = "0"b then do; /* partial hdr label */
3175                                         rtq_info.eov, rtq_info.two_eofs = "1"b; /*  logical end of tape */
3176                                         j = 24;             /* set character count */
3177                                    end;
3178                               else j = 60;                  /* normal hdr label */
3179 
3180                               call ioa_ ("^a ^[Partial ^]^[BTL ^]^a^[; Tape reel # ^a^;^1s^].^[^/(""^a"")^;^1s^]^[^/^]",
3181                                    LABEL (rtq_info.l_type), eov, (rtq_info.c_file = 1), "header label record", (rtq_info.c_file ^= 1),
3182                                    substr (rtq_info.cbufp -> cbuf, 19, 6), lg_ck, substr (rtq_info.cbufp -> cbuf, 1, j), eov);
3183                          end;                               /* label header */
3184 
3185                     else call ioa_ ("^/^a ""^a"" label record. ^a ^d^[; Next reel # ^a^;^1s^].^[^/(""^a"")^;^1s^]",
3186                               LABEL (rtq_info.l_type), substr (rtq_info.cbufp -> cbuf, 2, 3), "Block count of previous file",
3187                               bin (substr (bit_buf, 37, 36)), (substr (rtq_info.cbufp -> cbuf, 79, 6) ^= ""),
3188                               substr (rtq_info.cbufp -> cbuf, 79, 6), lg_ck, rtq_info.cbufp -> cbuf);
3189                     return ("1"b);
3190                end;                                         /* GCOS Label record */
3191 
3192           else return ("0"b);                               /* not label record  */
3193 
3194 
3195 lab_type (4):                                               /* check for IBM Label records */
3196           if rtq_info.rec_len = 80 then do;                 /* it looks like a label record */
3197                     call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf); /* convert ebcdic to ascii */
3198                     rtq_info.lblp = rtq_info.cvbp;          /* set label ptr */
3199                     go to ibm_asc_join;                     /* go join common code */
3200                end;
3201 
3202           else return ("0"b);                               /* not label/trailer return false */
3203 
3204 
3205 lab_type (5):                                               /* check for ANSI Label records */
3206           if rtq_info.rec_len = 80 then do;                 /* it looks like a label/trailer record */
3207                     rtq_info.lblp = rtq_info.tptr;          /* set label ptr */
3208 
3209 ibm_asc_join:                                               /* code from now on common for ibm and ansi */
3210 
3211                     if substr (lab_buf, 1, 4) = "VOL1" then /* vol1 label */
3212                          call ioa_ ("^[^/^] ^a ^a label record. Volume serial number ^a^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
3213                               LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), substr (lab_buf, 5, 6), lg_ck, lab_buf);
3214 
3215                     else if substr (lab_buf, 1, 4) = "HDR1" then /* hdr1 label */
3216                          call ioa_ ("^[^/^] ^a ^a label record. Data set ID ^a^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
3217                               LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), substr (lab_buf, 5, 17), lg_ck, lab_buf);
3218 
3219                     else if substr (lab_buf, 1, 4) = "HDR2" then do; /* hdr2 label */
3220                               call ioa_ ("^a ^a label record. Next file format:", LABEL (rtq_info.l_type), substr (lab_buf, 1, 4));
3221 
3222                               if rtq_info.l_type = ibm_label then do; /* IBM HDR2 Label */
3223                                         ibm_hdr2P = rtq_info.lblp; /* set structure ptr */
3224                                         call ioa_ ("Record format ^a^a; Block length ^d; Record length ^d;",
3225                                              ibm_hdr2.format, ibm_hdr2.block_attribute, bin (ibm_hdr2.blksize), bin (ibm_hdr2.lrecl));
3226                                    end;
3227                               else do;                      /* ANSI HDR2 Label */
3228                                         ansi_hdr2P = rtq_info.lblp; /* set structure ptr */
3229                                         ansi_mode = index ("123", ansi_hdr2.mode); /* convert recording mode */
3230 
3231                                         if ansi_mode = 0 then ansi_mode = 4; /* this is an unknown mode */
3232                                         call ioa_ (ansi_hdr2_fmt, ansi_hdr2.format, (ansi_hdr2.blocked = "0" | ansi_hdr2.blocked = "1"),
3233                                              (ansi_hdr2.blocked = "1"), bin (ansi_hdr2.blklen), bin (ansi_hdr2.reclen),
3234                                              ansi_mode);
3235 
3236                                         if ansi_mode = 3 then /* if file in binary mode */
3237                                              rtq_info.set_bin, rtq_info.set_nine = "1"b; /* set state switches */
3238                                    end;                     /* ANSI HDR2 Label */
3239 
3240                               if lg_ck then call ioa_ ("(""^a"")", lab_buf);
3241                          end;                               /* HDR2 Label */
3242 
3243                     else if substr (lab_buf, 1, 3) = "EOV" | substr (lab_buf, 1, 3) = "EOF" |
3244                          substr (lab_buf, 1, 3) = "UHL" | substr (lab_buf, 1, 3) = "UTL" then do; /* one of these labels */
3245                               call ioa_ ("^[^/^] ^a ^a label record. ^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
3246                                    LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), lg_ck, lab_buf);
3247 
3248                               if substr (lab_buf, 1, 3) = "EOV" then eov = "1"b; /* Logical End tape */
3249                          end;                               /* EOV Label or EOF Label or UHL Label or UTL Label */
3250 
3251                     else return ("0"b);                     /* none of known labels */
3252 
3253                     return ("1"b);                          /* if one of these: VOL1, HDR1, HDR2, EOV, EOF, UHL, and UTL labels */
3254                end;                                         /* if rtq_info.rec_len = 80 */
3255 
3256           else return ("0"b);                               /* not a Label or Trailer record */
3257 
3258 
3259 lab_type (6):                                               /* check for CP5 Label records */
3260           if substr (bit_buf, 1, 9) ^= "172"b3 then /* if first char not = ebcdic ":" */
3261                return ("0"b);                               /* then its not label record */
3262 
3263           call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf); /* convert ebcdic to ascii */
3264           rtq_info.lblp = rtq_info.cvbp;                    /* set label ptr */
3265 
3266           if sentinel = ":LBL" | sentinel = ":ACN" | sentinel = ":BOF" |
3267                sentinel = ":EOV" | sentinel = ":EOR" | sentinel = ":EOF" then do;
3268                     call ioa_ ("^[^/^] ^a ^a label record^[; Volume id ^a^;^1s^].^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
3269                          LABEL (rtq_info.l_type), sentinel, (sentinel = ":LBL"), substr (lab_buf, 5, 4), lg_ck, lab_buf);
3270                     return ("1"b);                          /* return true */
3271                end;
3272           else return ("0"b);                               /* otherwise, return false */
3273 
3274 
3275 lab_type (0):                                               /* unlabeled tape, egnore looking at labels */
3276           return ("0"b);                                    /* not label record */
3277 
3278      end valid_label_record;
3279 
3280 /***************************************************************************/
3281 %page;
3282 valid_pathname: proc (pathname_argument, suffix) returns (bit (1) aligned);
3283 
3284 /* expands a specified entry name to a directory pathname and appends a    */
3285 /* specified suffix to an entry name.  Returns a "1"b indicating success,  */
3286 /* otherwise, returns a "0"b.                                              */
3287 
3288           dcl     p_dir                  char (168);
3289           dcl     p_entry                char (32);
3290           dcl     pathname_argument      char (*);
3291           dcl     suffix                 char (*);
3292 
3293 /* begin coding */
3294           call expand_pathname_$add_suffix (pathname_argument, suffix, p_dir, p_entry, scode);
3295           if scode ^= 0 then
3296                return ("0"b);
3297           else do;
3298                     rtq_info.filename = p_entry;
3299                     rtq_info.filepath = pathname_ (p_dir, p_entry);
3300                     return ("1"b);
3301                end;
3302 
3303      end valid_pathname;
3304 
3305 /***************************************************************************/
3306 %page;
3307 write_file: proc (bufptr, wrtchars, s_file_name);
3308 
3309 /* writes logical records to a specified file:  If users don't specify a   */
3310 /* file then they will be asked for a file name.  If users don't specify a */
3311 /* file format then displays a warning message and query them before       */
3312 /* we write a raw file.  Builds the attach description before attaching    */
3313 /* and opening the file using vfile_ i/o module.  Reports to users if the  */
3314 /* output file has not been written yet.  Depending on the open mode,      */
3315 /* writes each logical record to the output file.  Queries users for       */
3316 /* re-trying to write again if the returned scode value is not a zero      */
3317 /* value.                                                                  */
3318 
3319           dcl     bufptr                 ptr;
3320           dcl     output_filename        char (168) aligned;
3321           dcl     s_file_name            char (32) varying;
3322           dcl     wrtchars               fixed bin (21);    /* written characters */
3323 
3324 /* begin coding */
3325           if ^rtq_info.f_attached then do;                  /* if file not attached */
3326                     if rtq_info.filename = "" then do;      /* if no filename, go ask for it */
3327                               rtq_info.tmr = "0"b;          /* initialize terminate condition */
3328                               do while (^rtq_info.tmr);     /* if no filename */
3329                                    output_filename = command_query_no_entrypoint ("Please enter an output file name.", "Output file name:  ");
3330 
3331                                    rtq_info.tmr = valid_pathname ((output_filename), "");
3332                                    if ^rtq_info.tmr then do;
3333                                              call ssu_$print_message (sci_ptr, scode,
3334                                                   "Expanding pathname while writing to the ouput file name ""^a""",
3335                                                   output_filename);
3336 
3337                                              rtq_info.return_subsys_loop_flg = "1"b;
3338                                              return;
3339                                         end;
3340                               end;                          /* do while ^rtq_info.tmr */
3341                          end;                               /* if rtq_info.filename = "" */
3342 
3343                     if ^nnl_sw & n_ops = 0 & s_file_name = "" then do; /* warn user before we write raw file */
3344 
3345                               call ioa_ ("Warning:  Tape file # ^d will be written to stream file ^a.^/A new line " ||
3346                                    "character (octal 012) will be appended to the end of each physical record.",
3347                                    rtq_info.c_file, rtq_info.filename);
3348 
3349                               YES_FLG = command_query_yes_no ("Do you want to add a new line character to each physical record?  Answer ""yes"" or ""no"".", "Append a new line character?");
3350 
3351                               if ^YES_FLG then do;          /* users said no */
3352                                         rtq_info.return_subsys_loop_flg = "1"b;
3353                                         return;
3354                                    end;
3355                          end;                               /* if ^nnl_sw & n_ops = 0 & s_file_name = ""  */
3356 
3357                     att_desc = "vfile_ " || rtq_info.filepath; /* build attach description now  */
3358 
3359 /* attach and open the output file */
3360                     call attach_and_open_output_file;
3361                end;                                         /* if ^rtq_info.f_attached */
3362 
3363           if ^rtq_info.fw_file then do;                     /* if first record of file */
3364                     rtq_info.fw_file = "1"b;                /* set switch */
3365                     if ^rtq_info.atd_sw then /* if user not using his own attach desc */
3366                          call ioa_ ("Writing file ""^a"".", rtq_info.filepath);
3367                end;
3368 
3369 RETRY_WRITE:
3370           if open_mode = Stream_output | open_mode = Stream_input_output then /* if open for "so" or "sio" */
3371                call iox_$put_chars (rtq_info.fiocb_ptr, bufptr, wrtchars, scode); /* write out logical records */
3372           else call iox_$write_record (rtq_info.fiocb_ptr, bufptr, wrtchars, scode); /* write out logical records */
3373 
3374           if scode ^= 0 then do;
3375                     call ssu_$print_message (sci_ptr, scode, "while writing to ""^a""", att_desc);
3376 
3377                     YES_FLG = command_query_yes_no ("Do you want to retry?  Answer ""yes"" or ""no"".", "Retry?");
3378 
3379                     if YES_FLG then /* users want to retry */
3380                          goto RETRY_WRITE;
3381                end;
3382 
3383      end write_file;
3384 
3385 /***************************************************************************/
3386 %page;
3387 %include rtq_structure_info;
3388 %page;
3389 %include ibm_hdr2;
3390 %include ansi_hdr2;
3391 %page;
3392 %include mstr;
3393 %include gcos_ssf_records;
3394 %page;
3395 %include iox_modes;
3396 %include area_info;
3397 
3398      end rtq_;