1 /* ***********************************************************
   2    *                                                         *
   3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   4    *                                                         *
   5    * Copyright (c) 1972 by Massachusetts Institute of        *
   6    * Technology and Honeywell Information Systems, Inc.      *
   7    *                                                         *
   8    *********************************************************** */
   9 
  10 
  11 
  12 /* The non-standard tape DIM.  coded by MAP, 8/70.  Liberally cribbed from NIM */
  13 /* Modified by Dick Snyder 2/71 to allow a mode request of "rw"  or blank (read/write) */
  14 /* Also changed to allow order request "err_count" for on-line T&D's and to add  */
  15 /* stream data block as specified in MCB 638                   */
  16 /* Modified by Mike Grady to add fixed_record_length order call 11/03/72 */
  17 /* Modified on 09/19/77 by R.J.C. Kissel to call tape_nstd_ to get the max buffer size. */
  18 /* Modified on 02/15/78 by M. R. Jordan to remove the call to tape_nstd_ and add the ,block= and ,blk= strings. */
  19 /* Modified on 04/28/78 by Michael R. Jordan to _^Hn_^Ho_^Ht unload tapes. */
  20 /* Modified on 08/09/78 by Bob May to add TEMPORARY GCOS facility for large buffers .
  21    This interface will disappear when the GCOS simulator moves to tape_ioi_. */
  22 /* Modified 4/79 by R.J.C. Kissel to add 6250 bpi and data security erase capability. */
  23 /* Modified on 05/10/79 by C. D. Tavares to add name canonicalization support */
  24 /* Modified sometime in 1981 by M. R. Jordan to fix some bugs */
  25 
  26 /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
  27 nstd_dim:
  28      proc;
  29           return;                                           /* Shouldn't be called here */
  30 
  31 dcl      (name1, type, name2, rw, order)
  32                                 char (*);
  33 dcl      st                     bit (72);
  34 dcl      (sdb_ptr, wksp, ap)    ptr;
  35 dcl      (
  36          error_table_$no_backspace,
  37          error_table_$undefined_order_request,
  38          error_table_$bad_mode,
  39          error_table_$buffer_big,
  40          error_table_$bad_arg,
  41          error_table_$ionmat
  42          )                      ext fixed bin (35);
  43 dcl      code                   fixed bin (35);
  44 dcl      setbit                 bit (18),
  45          rdycmd                 fixed bin (6),
  46          fix_sw                 bit (1),
  47          attach_sw              bit (1),
  48          j                      fixed bin;
  49 dcl      (off, nelem, nelemt, ring, count, i)
  50                                 fixed bin (17);
  51 dcl      density                fixed bin;
  52 dcl      temp_name              char (32);
  53 dcl      1 wait_list,
  54            2 n                  fixed bin (17),
  55            2 chn                fixed bin (71);
  56 dcl      1 message,
  57            2 channel            fixed bin (71),
  58            2 mess               fixed bin (71),
  59            2 sender             bit (36),
  60            2 origin,
  61              3 dersig           bit (18) unaligned,
  62              3 ring             bit (18) unaligned,
  63            2 channel_index      fixed bin (17);
  64 dcl      dum                    (tseg.buffer_size (1)) fixed bin (35) based;
  65 dcl      sst                    bit (18) aligned based;
  66 dcl      ord                    char (32);
  67 
  68 dcl      (addr, addrel, bit, length, null, ptr, rel, rtrim, search, substr, unspec)
  69                                 builtin;
  70 dcl      (bin, bool, divide, index, max, string, lbound, hbound)
  71                                 builtin;
  72 
  73 dcl      hcs_$make_seg          entry (char (*), char (*), char (*), fixed bin, ptr, fixed bin (35));
  74 
  75 dcl      (
  76          tdcm_$tdcm_attach,
  77          tdcm_$tdcm_detach,
  78          tdcm_$tdcm_set_signal,
  79          tdcm_$tdcm_reset_signal,
  80          tdcm_$tdcm_iocall
  81          )                      entry (ptr, fixed bin (35)),
  82          tdcm_$tdcm_set_buf_size
  83                                 entry (ptr, fixed bin, fixed bin (35)),
  84          tdcm_$tdcm_message     entry (ptr, char (*), fixed bin, fixed bin (35));
  85 dcl      cv_dec_check_          entry (char (*), fixed bin (35)) returns (fixed bin (35));
  86 
  87 dcl      ipc_$create_ev_chn     ext entry (fixed bin (71), fixed bin (35));
  88 dcl      hcs_$delentry_seg      entry (ptr, fixed bin (35));
  89 dcl      (
  90          ioa_,
  91          ioa_$rsnnl
  92          )                      entry options (variable);
  93 dcl      ipc_$block             entry (ptr, ptr, fixed bin (35));
  94 dcl      instance               fixed bin (35) int static init (1);
  95                                                             /* used to generate sdb seg name */
  96 dcl      segnm                  char (32);                  /* name of stream data block */
  97 dcl      sav_stat               bit (36);
  98 dcl      newerr                 fixed bin based (ap);
  99 
 100 dcl      cleanup                condition;                  /* cleanup handler for interrupted attachment */
 101 
 102 dcl      1 hsbc                 aligned,                    /* tape status word format */
 103            2 padx               bit (2) unaligned,
 104            2 maj                bit (4) unaligned,
 105            2 min                bit (6) unaligned,
 106            2 pady               bit (24);
 107 
 108 dcl      1 stream_data_block    aligned based (sdb_ptr),
 109            2 outer_module_name  char (32) aligned,
 110            2 device_name_list   ptr,
 111            2 tseg_ptr           ptr,
 112            2 retry_cnt          fixed bin,                  /* no. of times to retry i/o */
 113            2 some_bits          aligned,
 114              3 no_data_sw       bit (1) unaligned,          /* 1 = start next blocked i/o */
 115              3 fix_rec          bit (1) unaligned,          /* 1 = fixed record i/o (buffered i/o) */
 116              3 eot_bit          bit (1) unaligned,          /* 1 = end of tape was reached */
 117              3 eof_bit          bit (1) unaligned,          /* 1 = end of file was reached */
 118              3 rewind           bit (1) unaligned,          /* 1 = last tape order was rewind */
 119              3 unload           bit (1) unaligned,          /* 1 = last tape order was unload */
 120              3 fix_init         bit (1) unaligned,          /* initial io for fixed length rec. */
 121              3 spare_bits       bit (29) unaligned,
 122            2 max_rec_len        fixed bin,                  /* maximum record length in words */
 123            2 fix_rec_size       fixed bin,                  /* length of records for fixed record length option */
 124            2 buf_mask           bit (18),                   /* used to get index to block of buffers */
 125            2 buf_count          fixed bin,                  /* no. of buffers in data transfer */
 126            2 data_count         fixed bin,                  /* no. of buffers read/written  */
 127            2 bufchk             fixed bin,                  /* index of current buffer in block  (0 to 2*buffer_count-1) */
 128            2 device_name,
 129              3 next_device_ptr  ptr,
 130              3 name_size        fixed bin (17),
 131              3 name             char (256) aligned,
 132            2 tsegarea           fixed bin (71);
 133 
 134 
 135 dcl      1 ord_tab              (18) aligned internal static,
 136                                                             /* lookup table for simple order types */
 137            2 oname              char (32) aligned
 138                                 init (/* orders */ "back", "eof", "reset_status", "forward_record", "forward_file",
 139                                                             /* NOTE: order of these orders */
 140                                 "backspace_file", "erase", "high", "low", "protect", "unload", "rewind",
 141                                                             /* must be maintained */
 142                                 "d200", "d556", "d800", "d1600", "d6250", "data_security_erase"),
 143                                                             /* since there is code which is */
 144                                                             /* dependent on it */
 145            2 cmd                bit (6) aligned
 146                                 init (/* actual orders */ "46"b3, "55"b3, "40"b3, "44"b3, "45"b3, "47"b3, "54"b3, "60"b3,
 147                                 "61"b3, "62"b3, "72"b3, "70"b3, "64"b3, "61"b3, "60"b3, "65"b3, "41"b3, "73"b3);
 148 
 149 
 150 %include tseg;
 151 
 152 /*^L*/
 153 
 154 set_block_size:
 155      entry (a_user_block_size, a_code);
 156 
 157 /* Temporary entry to allow users of the GCOS simulators to tell nstd_ to use large buffers.
 158    Bob May, 08/07/78 */
 159 
 160 dcl      a_user_block_size      fixed bin,                  /* size in words */
 161          a_code                 fixed bin (35);
 162 
 163 dcl      user_block_size        fixed bin int static;       /* override size */
 164 
 165 dcl      user_block_size_sw     bit (1) int static init ("0"b);
 166                                                             /* to keep track of buffer needs */
 167 
 168           if a_user_block_size ^= 0 then do;
 169                user_block_size = a_user_block_size;
 170                user_block_size_sw = "1"b;
 171           end;
 172           else user_block_size_sw = "0"b;                   /* reset function */
 173 
 174           a_code = 0;                                       /* assume its ok for now. we checked it before */
 175           return;
 176 
 177 /* End of set_block_size Entry */
 178 
 179 
 180 
 181 /*        A   T   T   A   C   H      E   N   T   R   Y      P   O   I   N   T    */
 182 
 183 
 184 
 185 
 186 
 187 nstd_attach:
 188      entry (name1, type, name2, rw, st, sdb_ptr);
 189 
 190           attach_sw = "0"b;
 191           if sdb_ptr ^= null then do;                       /* check for multiple attachments */
 192 
 193                substr (st, 1, 36) = unspec (error_table_$ionmat);
 194                return;                                      /* if multiple attachment return error code */
 195           end;
 196 
 197           on cleanup call clear_attach;                     /* cleanup in case user quits while attaching */
 198 
 199 /*        Create name for segment to hold stream data block. Name consists of */
 200 /*        "nstd_sdbN_" where N is a number which increments by one for */
 201 /*        each attach call.                                            */
 202 
 203 
 204           call ioa_$rsnnl ("nstd_sdb^d_", segnm, code, instance);
 205           instance = instance + 1;                          /* bump instance */
 206 
 207           call hcs_$make_seg ("", segnm, "", 01011b, sdb_ptr, code);
 208                                                             /* Make an sdb */
 209           if sdb_ptr = null then do;                        /* failure? */
 210 BAD_OUT:
 211                substr (st, 1, 36) = unspec (code);
 212                substr (st, 52, 1) = "1"b;                   /* Send back a detach bit */
 213                return;
 214           end;
 215 
 216           outer_module_name = "nstd_";                      /* fill in stream data block */
 217           device_name_list = addr (device_name);
 218           next_device_ptr = null;                           /* only one device */
 219           name_size = 32;
 220           name = name2;                                     /* put in tape name */
 221           tseg_ptr = addr (tsegarea);                       /* set up tseg for DCM use */
 222           tsegp = tseg_ptr;                                 /* copy tseg pointer for better code */
 223           tseg.version_num = tseg_version_2;
 224 
 225           stream_data_block.retry_cnt = 10;                 /* set default error retry count */
 226           fix_init = "0"b;                                  /* initialization for fixed rec. length */
 227 
 228 /* initialize tseg */
 229 
 230           call ipc_$create_ev_chn (tseg.ev_chan, code);     /* create event channel for the */
 231           if code ^= 0 then
 232                go to BAD_ATTACH;                            /* signalling of special interrupts */
 233 
 234           tseg.sync = 1;                                    /* i/o will be synchronous */
 235           tseg.get_size = 1;                                /* we want DCM to tell us record sizes */
 236           tseg.buffer_offset = 0;                           /* start at front of buffer */
 237           tseg.bufferptr (1) = bin (rel (addr (tseg.buffer (1))), 17);
 238                                                             /* set up first buffer ptr */
 239           do i = 1 to 12;
 240                tseg.mode (i) = 0;                           /* default mode is binary * */
 241           end;
 242 
 243 /* Hook up the dcm */
 244 
 245           if (rw ^= "r" & rw ^= "w" & rw ^= "rw" & rw ^= "") then do;
 246                code = error_table_$bad_mode;                /* set error code */
 247                go to BAD_ATTACH;
 248           end;
 249 
 250 
 251           if rw = "r" then
 252                ring, tseg.write_sw = 0;                     /* mode read */
 253           else ring, tseg.write_sw = 1;                     /* mode write */
 254 
 255           if index (name2, ",7track") ^= 0 then             /* set indicator to 7 or 9 track drive type */
 256                tseg.tracks = 1;
 257           else tseg.tracks = 0;
 258 
 259           call tdcm_$tdcm_attach (tsegp, code);             /* ask DCM to grab a drive */
 260           if code ^= 0 then
 261                go to BAD_ATTACH;                            /* DCM gripped */
 262           attach_sw = "1"b;
 263 
 264           max_rec_len = 2800;
 265           i = index (name2, ",block=") + 7;
 266           if i <= 7 then do;
 267                i = index (name2, ",blk=") + 5;
 268                if i <= 5 then
 269                     i = index (name2, ",bk=") + 4;
 270           end;
 271           if i > 4 then do;
 272                if i > length (name2) then do;
 273                     code = error_table_$bad_arg;
 274                     goto BAD_ATTACH;
 275                end;
 276                j = search (substr (name2, i), ", ") - 1;
 277                if j < 0 then
 278                     j = length (name2) - i + 1;
 279                max_rec_len = cv_dec_check_ (substr (name2, i, j), code);
 280                if code ^= 0 then do;
 281                     code = error_table_$bad_arg;
 282                     goto BAD_ATTACH;
 283                end;
 284           end;
 285 
 286 /* do the special block function only when block=nnnn not specified for individual attach */
 287 
 288           else if user_block_size_sw then
 289                max_rec_len = max (user_block_size, max_rec_len);
 290                                                             /* don't go too small */
 291 
 292           call tdcm_$tdcm_set_buf_size (tsegp, max_rec_len, code);
 293           if code ^= 0 then
 294                goto BAD_ATTACH;
 295 
 296           density = 800;
 297           tseg.density = "00100"b;
 298 
 299           i = index (name2, ",density=") + 9;
 300           if i <= 9 then
 301                i = index (name2, ",den=") + 5;
 302           if i > 5 then do;
 303                if i > length (name2) then do;
 304                     code = error_table_$bad_arg;
 305                     goto BAD_ATTACH;
 306                end;
 307                j = search (substr (name2, i), ", ") - 1;
 308                if j < 0 then
 309                     j = length (name2) - i + 1;
 310                density = cv_dec_check_ (substr (name2, i, j), code);
 311                if code ^= 0 then do;
 312                     code = error_table_$bad_arg;
 313                     goto BAD_ATTACH;
 314                end;
 315           end;
 316 
 317           if density = 1600 then do;
 318                rdycmd = bin ("65"b3);
 319                tseg.density = "00010"b;
 320           end;
 321 
 322           else if density = 800 then do;
 323                rdycmd = bin ("60"b3);
 324                tseg.density = "00100"b;
 325           end;
 326 
 327           else if density = 556 then do;
 328                rdycmd = bin ("61"b3);
 329                tseg.density = "01000"b;
 330           end;
 331 
 332           else if density = 200 then do;
 333                rdycmd = bin ("64"b3);
 334                tseg.density = "10000"b;
 335           end;
 336 
 337           else if density = 6250 then do;
 338                rdycmd = bin ("41"b3);
 339                tseg.density = "00001"b;
 340           end;
 341 
 342           else do;
 343                code = error_table_$bad_arg;
 344                goto BAD_ATTACH;
 345           end;
 346 
 347           call tdcm_$tdcm_set_signal (tsegp, code);         /* enable special interrupt so we */
 348                                                             /* know when operator mounts tape */
 349           if code ^= 0 then
 350                go to BAD_ATTACH;                            /* error */
 351 
 352           call ioa_ ("Tape ^a will be mounted with ^[a^;no^] write ring.", name, (ring = 1));
 353 
 354           temp_name = name;
 355           call tdcm_$tdcm_message (tsegp, temp_name, ring, code);
 356                                                             /* Send mount message */
 357           if code ^= 0 then
 358                go to BAD_ATTACH;                            /* error */
 359                                                             /* and send info to user */
 360 
 361           name = temp_name;
 362           name_size = length (rtrim (name));
 363 
 364 /* Do readiness checking/waiting */
 365 
 366 
 367           call wait;                                        /* wait for operator */
 368           if code ^= 0 then
 369                go to BAD_ATTACH;                            /* trouble?? */
 370           call ioa_ ("Tape ^a mounted on drive ^a with ^[a^;no^] write ring.", name, tseg.drive_name, (ring = 1));
 371           return;                                           /* and go home */
 372 
 373 
 374 BAD_ATTACH:
 375           substr (st, 52, 1) = "1"b;                        /* detach bit */
 376           substr (st, 1, 36) = unspec (code);
 377           call clear_attach;                                /* release drive and stream data block */
 378           return;
 379 
 380 DCM_ERR:
 381           substr (st, 1, 36) = unspec (code);               /* standard code was returned */
 382           return;                                           /* So there */
 383 
 384 
 385 
 386 
 387 
 388 /*        R   E   A   D      E   N   T   R   Y      P   O   I   N   T            */
 389 
 390 
 391 
 392 
 393 
 394 nstd_read:
 395      entry (sdb_ptr, wksp, off, nelem, nelemt, st);
 396 
 397           nelemt = 0;                                       /* Clear it, right away, in case of errors or EOF */
 398           call check_rewind;
 399           count = stream_data_block.retry_cnt;              /* Initialize for possible retries */
 400 
 401           if fix_rec then do;
 402 
 403                if fix_init then do;
 404                     no_data_sw = "1"b;                      /* no data yet */
 405                     tseg.buffer_offset = 0;                 /* put data in first set of buffs */
 406                     tseg.buffer_count = buf_count;          /* no. of buffers to read */
 407                     tseg.write_sw = 0;                      /* set io to read */
 408                     call tdcm_$tdcm_iocall (tsegp, code);   /* start read */
 409                     fix_init = "0"b;
 410                end;
 411 
 412                if tseg.write_sw = 0 then
 413                     go to fix_read;                         /* continue reading */
 414                call reset_fix_rec;                          /* finish write  */
 415           end;
 416 
 417           tseg.write_sw = 0;                                /* set to read */
 418           if nelem > max_rec_len then
 419                go to BAD_BUF;
 420 
 421 RLOOP:
 422           tseg.buffer_size (1) = nelem;                     /* We'll read no more than we can, and maybe less */
 423           tseg.buffer_count = 1;
 424           tseg.command_count = 0;                           /* This is what makes the dcm know it's a read/write request */
 425           tseg.buffer_offset = 0;                           /* use the 1st buffer */
 426 
 427           call tdcm_$tdcm_iocall (tsegp, code);             /* Go get 'em */
 428           if code ^= 0 then
 429                go to DCM_ERR;
 430 
 431           if tseg.completion_status = 1 then do;            /* Good read */
 432 
 433                call move (1);                               /* move data to user's buffer */
 434 
 435 GOOD_OUT:                                                   /* Common successful return point */
 436                substr (st, 1, 36) = "0"b;
 437                nelemt = tseg.buffer_size (1);
 438                return;
 439           end;
 440 
 441 /* Here on bad completion status--retry if not done with count */
 442 
 443 RECOV:
 444           if substr (tseg.hardware_status, 3, 4) = "0100"b then
 445                go to BAD_ORD;                               /* If it's EOF send it back */
 446           if substr (tseg.hardware_status, 3, 4) = "0011"b  /* data alert */
 447           then if (substr (tseg.hardware_status, 7, 6) & "100010"b) = "000010"b then
 448                     go to BAD_ORD;                          /* don't try any more--will still get blank tape */
 449 
 450 RECOV1:
 451           if count > 0 then do;                             /* More re-tries left */
 452 
 453                count = count - 1;                           /* decrement error retry cnt */
 454                tseg.command_count = 1;                      /* we'll issue one */
 455                tseg.command_queue (1) = 100110b;            /* backspace order */
 456                call tdcm_$tdcm_iocall (tsegp, code);        /* let DCM do it */
 457                if code ^= 0 then
 458                     go to DCM_ERR;                          /* error */
 459                if tseg.completion_status ^= 1 then do;      /* error on bksp */
 460                     substr (st, 1, 36) = unspec (error_table_$no_backspace);
 461                                                             /* couldn't bksp due */
 462                     return;                                 /* to being on bot */
 463                end;
 464                if tseg.write_sw = 1 then
 465                     go to WLOOP;                            /* retry write */
 466                go to RLOOP;                                 /* retry read */
 467 
 468           end;
 469 
 470           else do;                                          /* can't recover.  */
 471 
 472                nelemt = tseg.buffer_size (1);               /* amount of buffer actually sent */
 473                if tseg.write_sw = 0 then
 474                     call move (1);                          /* put data read in user's buffer */
 475 
 476           end;
 477 
 478 /* Here when re-tries or order codes fail */
 479 
 480 BAD_ORD:
 481           substr (st, 1, 1) = "1"b;                         /* set high order bit of */
 482                                                             /* status to indicate that actual */
 483                                                             /* tape major and minor status is being returned */
 484                                                             /* and not a standard error code */
 485           if stream_data_block.unload then
 486                stream_data_block.rewind = "0"b;             /* don't wait for special */
 487                                                             /* interrupt after rewind if tape unloaded */
 488           substr (st, 25, 12) = tseg.hardware_status;       /* return major/minor status */
 489           return;
 490 
 491 
 492 fix_read:                                                   /* proc to do quick reads for fixed recs */
 493           fix_sw = "0"b;                                    /* indicate read */
 494 
 495 fix_com:
 496           if nelem ^= fix_rec_size then
 497                go to BAD_BUF;                               /* must ask for 1 buff at a time */
 498 
 499           if no_data_sw then do;                            /* any data left ? */
 500 
 501                if eof_bit then do;                          /* did we get eof last time ? */
 502                     substr (st, 1, 1) = "1"b;               /* yes reflect status */
 503                     substr (st, 25, 12) = substr (sav_stat, 1, 12);
 504                                                             /* put in saved eof code (9 or 7) */
 505                     eof_bit = "0"b;
 506                     fix_init = "1"b;                        /* restart read */
 507                     return;                                 /* done it */
 508                end;
 509 
 510                if eot_bit then do;                          /* have we already said eot ? */
 511                     substr (st, 1, 1) = "1"b;               /* yes, but do it again */
 512                     substr (st, 25, 12) = "000011100000"b;  /* eot status */
 513                     return;                                 /* maybe we can convince him */
 514                end;
 515 
 516                bufchk = tseg.buffer_offset;                 /* return data starting with this buff */
 517                setbit = bit (bin (tseg.buffer_offset, 18), 18);
 518                                                             /* switch buffers with x-or */
 519 restart:
 520                setbit = bool (setbit, buf_mask, "0110"b);   /* do sw */
 521                tseg.buffer_offset = bin (setbit, 17);       /* get number */
 522                tseg.sync = 0;                               /* make sure */
 523                tseg.buffer_count = buf_count;               /* read n buffers of data */
 524                call tdcm_$tdcm_iocall (tsegp, code);        /* start io */
 525                if code ^= 0 then
 526                     go to DCM_ERR;
 527                if tseg.completion_status ^< 2 then do;      /* bad error */
 528 
 529                     string (hsbc) = tseg.hardware_status;   /* copy status */
 530                     if hsbc.maj = "0100"b then do;
 531                          data_count = tseg.error_buffer - 1;/* indicate amt we got */
 532                          sav_stat = tseg.hardware_status;   /* save for 9 or 7 code */
 533                          if data_count = 0 then
 534                               go to BAD_ORD;                /* no more data  send error */
 535                          eof_bit = "1"b;                    /* tape mark */
 536                          no_data_sw = "0"b;
 537                          go to fix_out;                     /* finish proccessing data */
 538                     end;
 539 
 540                     if hsbc.maj ^= "0011"b then
 541                          go to BAD_ORD;                     /* only recoverable is data alert */
 542 
 543                     if hsbc.min & "100000"b then do;        /* eot marker sensed (write only) */
 544                          setbit = bool (setbit, buf_mask, "0110"b);
 545                                                             /* switch buffers */
 546                          tseg.buffer_offset = bin (setbit, 17) + tseg.error_buffer;
 547                                                             /* start with one after eot mark */
 548                          tseg.buffer_count = buf_count - tseg.error_buffer;
 549                                                             /* and do only ones remaining */
 550                          call tdcm_$tdcm_iocall (tsegp, code);
 551                          setbit = bool (setbit, buf_mask, "0110"b);
 552                          tseg.buffer_offset = bin (setbit, 17);
 553                                                             /* set to do next bunch */
 554                          tseg.buffer_count = buf_count;     /* set to reissue past io(last one completed) */
 555                          call tdcm_$tdcm_iocall (tsegp, code);
 556                                                             /* go to DCM */
 557                          substr (st, 1, 1) = "1"b;          /* reflect eot to user */
 558                          substr (st, 25, 12) = "000011100000"b;
 559                                                             /* eot status */
 560                          eot_bit = "1"b;                    /* remember this fact */
 561                          return;                            /* go to user */
 562                     end;
 563 
 564                     do j = 1 to count;                      /* retry io */
 565                          setbit = bool (setbit, buf_mask, "0110"b);
 566                                                             /* back to buffers which failed */
 567                          tseg.buffer_offset = bin (setbit, 17);
 568                                                             /* set tseg */
 569                          do i = 1 to tseg.error_buffer;     /* backspaces n times */
 570                               tseg.command_queue (i) = 100110b;
 571                                                             /* backspace rec op */
 572                          end;
 573                          tseg.command_count = tseg.error_buffer;
 574                                                             /* go to it */
 575                          tseg.buffer_count = 0;             /* clear it since last attempt didnt go */
 576                          tseg.sync = 1;                     /* we will wait for these io's */
 577                          call tdcm_$tdcm_iocall (tsegp, code);
 578                                                             /* do backup */
 579                          if code ^= 0 then
 580                               go to DCM_ERR;
 581                          if tseg.completion_status ^< 2 then do;
 582                                                             /* bad error */
 583                               substr (st, 1, 36) = unspec (error_table_$no_backspace);
 584                               return;
 585                          end;
 586                          tseg.buffer_count = buf_count;     /* retry io again */
 587                          call tdcm_$tdcm_iocall (tsegp, code);
 588                                                             /* go -- this is sync so it will wait */
 589                          if tseg.completion_status < 2 then
 590                               go to restart;                /* go this time restart the io we wanted */
 591                     end;
 592                     go to BAD_ORD;                          /* retry failed us */
 593                end;
 594 
 595                no_data_sw = "0"b;                           /* we data now */
 596                data_count = buf_count;                      /* this much */
 597           end;
 598 
 599 
 600 fix_out:                                                    /* come here to finish sending data */
 601           call move (bufchk + 1);                           /* move data to buffer */
 602           bufchk = bufchk + 1;                              /* this one next time */
 603           data_count = data_count - 1;                      /* reduce number of buffers full */
 604           if data_count = 0 then
 605                no_data_sw = "1"b;                           /* set sw saying none left */
 606           nelemt = nelem;                                   /* set count */
 607           substr (st, 1, 36) = "0"b;                        /* no error */
 608           return;
 609 
 610 
 611 
 612 /*        W   R   I   T   E      E   N   T   R   Y      P   O   I   N   T        */
 613 
 614 
 615 
 616 
 617 nstd_write:
 618      entry (sdb_ptr, wksp, off, nelem, nelemt, st);
 619 
 620           nelemt = 0;                                       /* Clear it */
 621           call check_rewind;
 622           count = stream_data_block.retry_cnt;              /* no. of possible retries */
 623 
 624           if fix_rec then do;
 625                if fix_init then do;
 626                     tseg.sync = 0;
 627                     no_data_sw = "0"b;                      /* mark buffers empty now */
 628                     data_count = buf_count;                 /* n to fill before write */
 629                     tseg.buffer_offset = buf_count;         /* set so first switch will go */
 630                     bufchk = 0;                             /* start filling buffers at offset 0 */
 631                     tseg.write_sw = 1;
 632                     fix_init = "0"b;
 633                end;
 634 
 635                if tseg.write_sw = 1 then
 636                     go to fix_r_write;                      /* check for write access */
 637                call reset_fix_rec;                          /* clean up after read */
 638           end;
 639 
 640 
 641           tseg.write_sw = 1;                                /* set io to write */
 642           if nelem > max_rec_len then do;                   /* buffer too large for DCM? */
 643 
 644 BAD_BUF:
 645                substr (st, 1, 36) = unspec (error_table_$buffer_big);
 646                                                             /* put error in status */
 647                return;
 648           end;
 649 
 650 WLOOP:
 651           tseg.buffer_size (1) = nelem;                     /* copy no elements */
 652           tseg.command_count = 0;                           /* not doing a special command */
 653           tseg.buffer_count = 1;                            /* one buffer */
 654           tseg.buffer_offset = 0;                           /* use the 1st buffer */
 655 
 656           call move (1);                                    /* move data into tseg buffer for write */
 657           call tdcm_$tdcm_iocall (tsegp, code);             /* issue write */
 658           if code ^= 0 then
 659                go to DCM_ERR;                               /* error */
 660           if tseg.completion_status = 1 then
 661                go to GOOD_OUT;                              /* success */
 662           if substr (tseg.hardware_status, 3, 5) = "00111"b then do;
 663                                                             /* If it's EOT send it back */
 664                nelemt = tseg.buffer_size (1);               /* But give him the nelemt */
 665                go to BAD_ORD;
 666           end;
 667           go to RECOV1;                                     /* go try to recover from write error */
 668 
 669 
 670 
 671 
 672 fix_r_write:
 673           fix_sw = "1"b;                                    /* indicate write */
 674           go to fix_com;                                    /* go to common routine for this */
 675 
 676 
 677 /*        O   R   D   E   R      E   N   T   R   Y      P   O   I   N   T        */
 678 
 679 
 680 
 681 
 682 nstd_order:
 683      entry (sdb_ptr, order, ap, st);
 684 
 685           call check_rewind;
 686 
 687           ord = order;                                      /* Copy arg for better code */
 688 
 689           if fix_rec then
 690                call reset_fix_rec;                          /* clear out buffers */
 691 
 692           do i = lbound (ord_tab, 1) to hbound (ord_tab, 1);/* look in table for common orders */
 693 
 694                if ord = ord_tab (i).oname then do;
 695 
 696                     tseg.command_queue (1) = bin (ord_tab (i).cmd);
 697                                                             /* hit..pick up command */
 698                     if i = 11 then
 699                          stream_data_block.unload = "1"b;   /* remember that unload done */
 700                     if i = 12 then
 701                          stream_data_block.rewind = "1"b;   /* remember that rewind done */
 702                     go to COM;                              /* go issue command */
 703                end;
 704 
 705           end;
 706 
 707 
 708           if ord = "fixed_record_length" then do;           /* fix_rec order call */
 709 
 710                fix_rec = "1"b;                              /* set bit */
 711                fix_rec_size = newerr;                       /* just happens to be based var with ptr to arg */
 712                buf_count = divide (max_rec_len, fix_rec_size, 17, 0);
 713                                                             /* get num buffers */
 714                if buf_count < 1 then
 715                     go to BAD_BUF;                          /* too big? */
 716                if buf_count > 6 then
 717                     buf_count = 6;                          /* 6 is most we can use */
 718                tseg.get_size = 0;                           /* no sizes, we know them */
 719                buf_mask = bit (bin (buf_count, 18), 18);    /* for x-or of buffer offset */
 720                eof_bit, eot_bit = "0"b;                     /* reset bits */
 721                tseg.sync = 0;                               /* set sync mode for io */
 722                do i = 1 to 2 * buf_count;                   /* init buffer sizes and ptrs */
 723                     tseg.buffer_size (i) = fix_rec_size;    /* known size */
 724                     tseg.bufferptr (i) = bin (rel (addrel (addr (tseg.buffer (1)), (i - 1) * fix_rec_size)), 17);
 725                                                             /* rel buf addrs */
 726                end;
 727                fix_init = "1"b;                             /* start io on 1st read */
 728                go to ORD_OUT;                               /* return */
 729           end;
 730 
 731 
 732           if ord = "bcd" then do;                           /*  "bcd" hardware mode */
 733                do i = 1 to 12;
 734                     tseg.mode (i) = 1;
 735                end;
 736                go to ORD_OUT;
 737           end;
 738           if ord = "binary" then do;                        /* "binary" hardware mode */
 739                do i = 1 to 12;
 740                     tseg.mode (i) = 0;
 741                end;
 742                go to ORD_OUT;
 743           end;
 744           if ord = "nine" then do;                          /* "nine" hardware mode */
 745                do i = 1 to 12;
 746                     tseg.mode (i) = 2;
 747                end;
 748                go to ORD_OUT;
 749           end;
 750           if ord = "saved_status" then do;
 751 STAT:
 752                ap -> sst = tseg.hardware_status;            /* copied from tseg; this will get special iom stuff too */
 753                go to ORD_OUT;
 754           end;
 755           if ord = "request_status" then do;
 756                tseg.command_count = 1;
 757                tseg.command_queue (1) = 000000b;
 758                call tdcm_$tdcm_iocall (tsegp, code);        /* call DCM */
 759                if code ^= 0 then
 760                     go to DCM_ERR;
 761                if tseg.completion_status ^= 1 then
 762                     go to BAD_ORD;
 763                go to STAT;
 764           end;
 765           if ord = "err_count" then do;
 766                if ap = null then do;                        /* new error supplied? */
 767                     stream_data_block.retry_cnt = 10;       /* no..use default */
 768                     go to ORD_OUT;
 769                end;
 770                if newerr > 100 | newerr < 0 then
 771                     go to UOR;                              /* yes..is it legal ? */
 772                stream_data_block.retry_cnt = newerr;        /* yes..use it */
 773                go to ORD_OUT;
 774           end;
 775 
 776 UOR:
 777           substr (st, 1, 36) = unspec (error_table_$undefined_order_request);
 778                                                             /* bum order */
 779           return;
 780 
 781 COM:
 782           if stream_data_block.rewind then do;              /* rewind to be done?? */
 783 
 784                call tdcm_$tdcm_set_signal (tsegp, code);    /* yes..tell DCM we want to know when it's done */
 785                if code ^= 0 then
 786                     go to DCM_ERR;                          /* DCM squawked */
 787           end;
 788 
 789           tseg.command_count = 1;
 790           call tdcm_$tdcm_iocall (tsegp, code);             /* issue order */
 791           if tseg.completion_status ^= 1 then
 792                go to BAD_ORD;
 793 
 794           if stream_data_block.rewind then                  /* was a rewind just issued? */
 795                if substr (tseg.hardware_status, 3, 4) = "0"b
 796                     & /* yes..was the tape */ substr (tseg.hardware_status, 11, 1) then do;
 797                                                             /* positioned on load point? */
 798 
 799                     stream_data_block.rewind = "0"b;        /* yes..turn off rewind sw */
 800                     call tdcm_$tdcm_reset_signal (tsegp, code);
 801                                                             /* there won't be a special interrupt */
 802                     if code ^= 0 then
 803                          go to DCM_ERR;                     /* goof */
 804                end;
 805 
 806 ORD_OUT:
 807           substr (st, 1, 36) = "0"b;                        /* return good status */
 808           return;
 809 
 810 nstd_getsize:
 811      entry (sdb_ptr, size, st);
 812 
 813 dcl      size                   fixed bin;
 814 
 815           size = 36;                                        /* nstd_ deals only in words */
 816 
 817           return;
 818 
 819 /*        D   E   T   A   C   H      E   N   T   R   Y      P   O   I   N   T              */
 820 
 821 
 822 
 823 
 824 nstd_detach:
 825      entry (sdb_ptr, type, name2, st);
 826 
 827           call check_rewind;
 828           if fix_rec then do;
 829                call reset_fix_rec;
 830           end;
 831           if stream_data_block.unload then
 832                go to DET;                                   /* don't unload if user already did */
 833           tseg.buffer_count = 0;
 834           tseg.command_queue (1) = 111000b;                 /* rewind tape */
 835           tseg.command_count = 1;
 836           call tdcm_$tdcm_iocall (tsegp, code);             /* have DCM do it */
 837           if code ^= 0 then
 838                go to DCM_ERR;                               /* error */
 839           if tseg.completion_status ^= 1 then
 840                go to BAD_ORD;                               /* failure on order */
 841 
 842 DET:
 843           call tdcm_$tdcm_detach (tsegp, code);             /* detach tape drive */
 844           if code ^= 0 then
 845                go to DCM_ERR;                               /* error */
 846 
 847           call hcs_$delentry_seg (sdb_ptr, code);           /* then try to get rid of sdb */
 848           if code ^= 0 then do;                             /* error */
 849                substr (st, 1, 36) = unspec (code);          /* return error code to caller */
 850                go to DET_BIT;                               /* but indicate that detach worked */
 851           end;
 852 
 853           substr (st, 1, 36) = "0"b;
 854 DET_BIT:
 855           substr (st, 52, 1) = "1"b;                        /* your detach bit */
 856           return;
 857 
 858 
 859 /*^L*/
 860 nstd_cmode:
 861      entry (sdb_ptr, rw, oldrw, st);
 862 
 863 dcl      oldrw                  char (*);
 864 
 865           tsegp = tseg_ptr;
 866 
 867           if tseg.write_sw = 1 then
 868                oldrw = "w";
 869           else oldrw = "r";
 870 
 871           if (rw ^= "w") & (rw ^= "r") & (rw ^= "rw") & (rw ^= "") then do;
 872                substr (st, 1, 36) = unspec (error_table_$bad_mode);
 873                return;
 874           end;
 875 
 876           if fix_rec then
 877                call reset_fix_rec;                          /* clear buffs */
 878 
 879           if rw = "r" then
 880                tseg.write_sw = 0;
 881           else tseg.write_sw = 1;
 882 
 883           substr (st, 1, 36) = "0"b;
 884           return;
 885 
 886 /*^L*/
 887 
 888 /* internal proc to clear out write ahead buffs */
 889 
 890 reset_fix_rec:
 891      proc;
 892           tseg.sync = 1;                                    /* set sync for orders */
 893           fix_rec = "0"b;
 894 
 895           if fix_init then do;                              /* no io yet - no clean up */
 896                fix_init = "0"b;
 897                return;
 898           end;
 899 
 900           if tseg.write_sw = 1 then do;                     /* write remaining buffers */
 901 
 902                setbit = bit (bin (tseg.buffer_offset, 18), 18);
 903                setbit = bool (setbit, buf_mask, "0110"b);
 904                tseg.buffer_offset = bin (setbit, 17);
 905                tseg.buffer_count = bufchk;
 906                tseg.command_count = 0;
 907                call tdcm_$tdcm_iocall (tsegp, code);
 908                if code ^= 0 then
 909                     go to DCM_ERR;
 910                if tseg.completion_status ^< 2 then
 911                     go to BAD_ORD;
 912                if ord = "eof" then do;                      /* RESET to fixed_length_record */
 913                     fix_rec = "0"b;
 914                     fix_init = "1"b;
 915                end;
 916                return;
 917           end;
 918 
 919           if eof_bit then do;                               /* no io pending */
 920                data_count = data_count + 1;                 /* backspace over file */
 921                eof_bit = "0"b;
 922                go to BACKSPACE;                             /* no io pending */
 923           end;
 924 
 925           tseg.buffer_count = 0;                            /* no data transfer */
 926           tseg.command_count = 0;                           /* no commands */
 927           call tdcm_$tdcm_iocall (tsegp, code);             /* complete last read */
 928           if code ^= 0 then
 929                go to DCM_ERR;
 930 
 931           if tseg.completion_status = 0 then
 932                go to BACKSPACE;                             /* no io pending */
 933           if tseg.completion_status = 1 then do;
 934                data_count = data_count + buf_count;
 935                go to BACKSPACE;
 936           end;
 937           data_count = data_count + tseg.error_buffer;
 938 
 939 BACKSPACE:                                                  /* backspace records read but not asked for */
 940           tseg.buffer_count = 0;
 941           do i = 1 to data_count;
 942                tseg.command_count = 1;
 943                tseg.command_queue (1) = 100110b;
 944                call tdcm_$tdcm_iocall (tsegp, code);        /* backspace one record */
 945                if code ^= 0 then
 946                     go to DCM_ERR;
 947           end;
 948 
 949           return;
 950 
 951      end;                                                   /*^L                                                        */
 952 
 953 
 954 
 955 /*        Internal procedure to wait for a special interrupt from the tape controller.     */
 956 /*        Used to wait for interrupt when tape drive made ready and after a rewind.        */
 957 
 958 
 959 wait:
 960      proc;
 961 
 962 
 963 READY_CHK:
 964           wait_list.n = 1;                                  /* will wait for one event channel */
 965           wait_list.chn = tseg.ev_chan;                     /* which is the one associated with this tseg */
 966           call ipc_$block (addr (wait_list), addr (message), code);
 967                                                             /* go blocked waiting */
 968           if code ^= 0 then do;                             /* error */
 969                substr (st, 1, 36) = unspec (code);
 970                return;
 971           end;
 972 
 973 /*        We could have gotten another drive's wakeup so....                     */
 974 
 975 
 976           tseg.command_count = 1;                           /* ready to do one order */
 977           tseg.buffer_count = 0;
 978           tseg.command_queue (1) = rdycmd;                  /* which is a reset status */
 979           call tdcm_$tdcm_iocall (tsegp, code);             /* issue order */
 980           if code ^= 0 then
 981                return;                                      /* goof..exit */
 982           if tseg.completion_status ^= 1 then
 983                go to READY_CHK;                             /* not us..wait some more */
 984 
 985           stream_data_block.rewind = "0"b;                  /* turn off rewind sw */
 986           call tdcm_$tdcm_reset_signal (tsegp, code);       /* disable special interrupt */
 987           return;
 988 
 989      end;
 990 
 991 /*  Move copies data from a tseg buffer into the user's buffer after a read or copies
 992    *  data from the user's buffer ito a tseg buffer before a write.
 993 */
 994 
 995 move:
 996      proc (no);
 997 
 998 dcl      no                     fixed bin;                  /* index to tseg buffer */
 999 dcl      ptseg                  ptr;                        /* ptr to current tseg buffer */
1000 dcl      puser                  ptr;                        /* ptr to current user buffer */
1001 
1002           ptseg = ptr (tsegp, tseg.bufferptr (no));         /* tseg buffer */
1003           puser = addrel (wksp, off);                       /* user buffer */
1004 
1005           if tseg.write_sw = 1 then
1006                ptseg -> dum = puser -> dum;                 /* copy into tseg buffer for a write */
1007           else puser -> dum = ptseg -> dum;                 /* copy into user's buffer for a read */
1008 
1009           return;
1010      end move;
1011 
1012 /*  Called if attachment was not completed.  It releases the stream data block and the tape drive */
1013 
1014 clear_attach:
1015      proc;
1016 
1017           if attach_sw then
1018                call tdcm_$tdcm_detach (tsegp, code);        /* detach tape drive */
1019           if sdb_ptr ^= null then
1020                call hcs_$delentry_seg (sdb_ptr, code);      /* delete stream data block */
1021 
1022           return;
1023 
1024      end clear_attach;
1025 
1026 
1027 
1028 /*  check_rewind goes blocked if the tape is still rewinding.  */
1029 
1030 check_rewind:
1031      proc;
1032 
1033           tsegp = tseg_ptr;                                 /* copy for better access */
1034           if stream_data_block.rewind then do;              /* wait if rewind just done */
1035                rdycmd = 100000b;                            /* Use reset status command here. */
1036                call wait;
1037                if code ^= 0 then
1038                     go to DCM_ERR;                          /* error?? */
1039           end;
1040 
1041           return;
1042 
1043      end check_rewind;
1044 
1045      end;