1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1990   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Bull Inc., 1987                *
   6         *                                                         *
   7         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   8         *                                                         *
   9         * Copyright (c) 1972 by Massachusetts Institute of        *
  10         * Technology and Honeywell Information Systems, Inc.      *
  11         *                                                         *
  12         *********************************************************** */
  13 
  14 
  15 
  16 
  17 /****^  HISTORY COMMENTS:
  18   1) change(88-06-20,Berno), approve(88-07-13,MCR7928),
  19      audit(88-06-20,Parisek), install(88-07-19,MR12.2-1061):
  20      Modified code for implementing the UNCP multiplexer (DSA gateway)
  21      interface implementation.
  22   2) change(88-09-28,Brunelle), approve(88-01-26,MCR7813),
  23      audit(88-10-12,Blair), install(88-10-17,MR12.2-1171):
  24      Upgrade to TTT_version 4 with c_chars structure changing from 3 to 15
  25      chars.
  26   3) change(90-06-26,Schroth), approve(90-07-09,MCR8183),
  27      audit(90-07-31,WAAnderson), install(90-08-16,MR12.4-1024):
  28      Changed to ensure that the caller does not block indefinitely when output
  29      is subdivided and yields no real output (whitespace or edited out), to
  30      properly set current line counter upon FF or VT, and to free allocated
  31      buffer chains on crawlout.
  32                                                    END HISTORY COMMENTS */
  33 
  34 /* format: style4,delnl,insnl,^ifthendo */
  35 tty_write:
  36      proc (twx, a_readp, a_offset, a_nelem, a_nelemt, a_state, ercode);
  37                                                             /* tty output conversion */
  38 
  39 
  40 /*        Date Last Modified and Reason
  41 
  42    Rewritten 11/3/75 by Robert S. Coren
  43    Modified 04/22/77 by J. Stern to introduce TCBs and WTCBs
  44    Modified July 78 by J. Nicholls to use channel_manager to write data out, to allow for implementation of multiplexing
  45    Modified fall of 1979 by Robert Coren to allocate automatic buffers in begin block
  46    Modified fall of 1979 by Robert Coren for output flow control
  47    Modified December 1979 by C. Hornig to fix bug in automatic stack frame allocation
  48    Modified December 1979 by Robert Coren to fix various bugs
  49    Call metering added October 1980 by Robert Coren
  50    White-space bug fixed November 1980 by Robert Coren
  51    write_set_mark entry added February 1981 by Robert Coren
  52    Modified March 1981 by Robert Coren to fix bugs with null end-of-page string
  53    Modified June 1981 by Robert Coren to add write_whole_string entry and keep global call count
  54    Modified June 1982 by Robert Coren to return MASKED state if appropriate
  55    Modified November 1982 by Robert Coren to return wtcb.error_code
  56    Modified October 1983 by E. N. Kittlitz for write_whole_string check longest_possible, not use a_offset
  57    Modified December 1983 by Robert Coren to set buffer tally before copying user data in case of crawlout
  58    Report on June 1983 - modifications for the Datanet 7100.f.d.
  59    Report on April 1984 - modifications for the 10.2 f.d.
  60    Date of the last modification - 17/04/84
  61 */
  62 
  63 /* PARAMETERS */
  64 
  65 dcl  twx fixed bin;                                         /* device index */
  66 dcl  a_readp ptr;                                           /* pointer to user's data */
  67 dcl  a_offset fixed bin (21);                               /* character to offset to add to readp */
  68 dcl  a_nelem fixed bin (21);                                /* number of characters supplied */
  69 dcl  a_string char (*);                                     /* string to output (for write_set_mark entry) */
  70 dcl  a_mark_flag bit (1);                                   /* whether to set a mark (write_whole_string entry) */
  71 dcl  a_nelemt fixed bin (21);                               /* number of characters shipped (OUTPUT) */
  72 dcl  a_state fixed bin;                                     /* current state of channel (OUTPUT) */
  73 dcl  ercode fixed bin (35);                                 /* status code (OUTPUT) */
  74 
  75 
  76 /* AUTOMATIC */
  77 
  78 dcl  state fixed bin;
  79 dcl  devx fixed bin;                                        /* local copy of device index */
  80 dcl  readp ptr;                                             /* local copy of a_readp */
  81 dcl  offset fixed bin (21);                                 /* local copy of a_offset */
  82 dcl  nelem fixed bin (21);                                  /* local copy of a_nelem */
  83 dcl  nelemt fixed bin (21);                                 /* local copy of a_nelemt */
  84 
  85 dcl  locked_entry bit (1);
  86 dcl  forcesw bit (1);
  87 dcl  mark_entry bit (1);
  88 dcl  whole_string bit (1);
  89 
  90 dcl  ttytp ptr;                                             /* pointer to tty_tables segment */
  91 dcl  tctp ptr;                                              /* pointer to TCT table */
  92 dcl  mvtp ptr;                                              /* pointer to translation table */
  93 dcl  special_ptr ptr;                                       /* pointer to special chars table */
  94 dcl  delay_ptr ptr;                                         /* pointer to delay table */
  95 dcl  max_space fixed bin;                                   /* maximum number of words this guy can have */
  96 dcl  max_chars fixed bin;                                   /* maximun number of character of output */
  97 dcl  max_chars_in_buf fixed bin;                            /* number of characters in maximum-size buffer */
  98 dcl  input_ptr ptr;                                         /* pointer to user-supplied data */
  99 dcl  final_outp ptr;                                        /* pointer to where output is to be taken from */
 100 dcl  output_length fixed bin (21);                          /* length of actual output in chars */
 101 
 102 dcl  source_ptr ptr;
 103 dcl  source_len fixed bin;
 104 dcl  target_ptr ptr;
 105 dcl  target_len fixed bin;
 106 
 107 dcl  cap_source_ptr ptr;
 108 dcl  cap_target_ptr ptr;
 109 dcl  cap_tab_ptr ptr;
 110 dcl  scanned_len fixed bin;
 111 
 112 dcl  time_spent fixed bin (71);
 113 dcl  start_time fixed bin (71);                             /* clock time at entry */
 114 dcl  chars_moved bit (1);
 115 dcl  white_sw bit (1);
 116 dcl  line_count fixed bin;                                  /* number of lines on page so far */
 117 dcl  col fixed bin;                                         /* current column position */
 118 dcl  wcol fixed bin;                                        /* column position after addition of white space */
 119 dcl  oldcol fixed bin;
 120 dcl  old_tally fixed bin;
 121 dcl  seqp ptr;                                              /* pointer to output sequence */
 122 dcl  i fixed bin;
 123 dcl  xor bit (18);                                          /* used in switching buffer pointers */
 124 dcl  shift bit (2);
 125 dcl  new_char_count fixed bin;
 126 dcl  old_head fixed bin (18);                               /* old value of wtcb.write_first */
 127 dcl  old_tail fixed bin (18);                               /* old value of wtcb.write_last */
 128 dcl  old_end_frame bit (1);                                 /* old value of wtcb.end_frame */
 129 dcl  break_length fixed bin;                                /* no. of characters before end-of-page */
 130 dcl  break_flag bit (1) aligned;                            /* indicates presence of end_of_page */
 131 dcl  null_for_eop bit (1);                                  /* indicates sending NUL character to force end-of-page */
 132 dcl  n_delays fixed bin;
 133 dcl  back_chars fixed bin;                                  /* no. of characters required for backward carriage motion */
 134 dcl  forward_chars fixed bin;                               /* no. of characters required for forward carriage motion */
 135 dcl  horiz float bin;
 136 dcl  vert fixed bin;
 137 dcl  ll fixed bin;                                          /* number of output characters on current line */
 138 dcl  escape_index fixed bin;                                /* index of output escape sequence */
 139 
 140 dcl  headp ptr;
 141 dcl  send bit (1);
 142 dcl  new_head fixed bin;
 143 dcl  n_pages fixed bin;
 144 dcl  lastp ptr;
 145 
 146 dcl  bufp ptr;
 147 dcl  prevp ptr;
 148 dcl  buf_size fixed bin;
 149 dcl  orig_buf_size fixed bin;
 150 dcl  reached_needed bit (1);
 151 dcl  new_buffer_count fixed bin;
 152 dcl  first_buffer bit (1);
 153 dcl  old_lastp ptr;
 154 dcl  words_needed fixed bin;
 155 dcl  new_bufp ptr;
 156 dcl  new_buf fixed bin;
 157 dcl  chars_in_buf fixed bin;
 158 dcl  lchar fixed bin;
 159 dcl  old_char_count fixed bin;
 160 dcl  nchars fixed bin;
 161 dcl  cur_space fixed bin;
 162 dcl  cur_chain_len fixed bin;
 163 dcl  end_chain bit (1);
 164 dcl  uncp_flag bit (1);                                     /* designate UNCP mpx */
 165 
 166 dcl  1 util aligned,                                        /* structure passed to tty_util_ subroutines */
 167        2 stringp ptr,
 168        2 stringl fixed bin,
 169        2 ctally fixed bin,
 170        2 tablep ptr,                                        /* pointer to translation table */
 171        2 indicator fixed bin,                               /* returned by tty_util_$find_char */
 172        2 pad (3) fixed bin;                                 /* workspace used by tty_util_ */
 173 
 174 dcl  1 illegal_char_args aligned,
 175        2 ic_stringp ptr,
 176        2 ic_stringl fixed bin,
 177        2 ic_tally fixed bin,
 178        2 pad fixed bin,
 179        2 found_flag bit (1) aligned,
 180        2 pad2 (4) fixed bin;
 181 
 182 dcl  auto_buf_len fixed bin;                                /* internal buffer length */
 183 dcl  allocated_buffers bit(1);                              /* on if buffers have been obtained */
 184 
 185 /* INTERNAL STATIC */
 186 
 187 dcl  NOT_INTERESTING fixed bin int static options (constant) init (0);
 188 dcl  NEW_LINE fixed bin int static options (constant) init (1);
 189 dcl  CARRIAGE_RETURN fixed bin int static options (constant) init (2);
 190 dcl  TAB_MULTIPLE_SPACE fixed bin int static options (constant) init (3);
 191 dcl  BACK_SPACE fixed bin int static options (constant) init (4);
 192 dcl  VERTICAL_TAB fixed bin int static options (constant) init (5);
 193 dcl  FORM_FEED fixed bin int static options (constant) init (6);
 194 dcl  OCTAL_ESCAPE fixed bin int static options (constant) init (7);
 195 dcl  RED_SHIFT fixed bin int static options (constant) init (8);
 196 dcl  BLACK_SHIFT fixed bin int static options (constant) init (9);
 197 dcl  INSERT_NO_COUNT fixed bin int static options (constant) init (10);
 198 dcl  INSERT_NO_COUNT_2 fixed bin int static options (constant) init (11);
 199 dcl  SKIP fixed bin int static options (constant) init (12);
 200 dcl  SPECIAL_ESCAPE fixed bin int static options (constant) init (16);
 201 
 202 dcl  HUNG_UP fixed bin int static options (constant) init (1);
 203 dcl  LISTENING fixed bin int static options (constant) init (2);
 204 dcl  DIALED_UP fixed bin int static options (constant) init (5);
 205 dcl  MASKED_STATE fixed bin int static options (constant) init (-1);
 206 
 207 dcl  max_chain_len fixed bin int static init (16) options (constant);
 208 dcl  reduction_factor float bin int static init (0.8) options (constant);
 209                                                             /* for allowing for growth of user's string */
 210 dcl  ascii_escape_octal bit (9) int static options (constant) init ("033"b3);
 211 dcl  ascii_escape_char char (1) based (addr (ascii_escape_octal));
 212 dcl  escape_char char (1) int static init ("\") options (constant);
 213 dcl  backspace char (1) int static init ("^H") options (constant);
 214                                                             /* backspace */
 215 dcl  space char (1) int static init (" ") options (constant);
 216 dcl  tab char (1) int static init ("    ") options (constant);
 217                                                             /* horizontal tab */
 218 dcl  carriage_return char (1) int static init ("^M") /* carriage return */ options (constant);
 219 dcl  nl char (1) int static options (constant) init ("
 220 ");                                                         /* line feed */
 221 
 222 dcl  num_array (0:7) char (1) int static options (constant) init ("0", "1", "2", "3", "4", "5", "6", "7");
 223                                                             /* for octal escapes */
 224 dcl  eop_sentinel_octal fixed bin (9) unsigned int static init (011111111b) options (constant);
 225                                                             /* i.e., 377(8) */
 226 dcl  eop_sentinel char (1);
 227 dcl  cont_char char (1) int static init ("c") options (constant);
 228 dcl  shifter (16) bit (1) int static options (constant) init ("0"b, (2) (1)"1"b, (13) (1)"0"b);
 229 dcl  delay_char fixed bin int static options (constant) init (0);
 230 dcl  upper_shift fixed bin int static options (constant) init (28);
 231                                                             /* i.e., 34(8) */
 232 dcl  lower_shift fixed bin int static options (constant) init (31);
 233                                                             /* i.e., 37(8) */
 234 
 235 dcl  lower_to_caps_edited (128) bit (9) int static options (constant)
 236           init ("000"b3, "001"b3, "002"b3, "003"b3, "004"b3, "005"b3, "006"b3, "007"b3, "010"b3, "011"b3, "012"b3,
 237           "013"b3, "014"b3, "015"b3, "016"b3, "017"b3, "020"b3, "021"b3, "022"b3, "023"b3, "024"b3, "025"b3, "026"b3,
 238           "027"b3, "030"b3, "031"b3, "032"b3, "033"b3, "034"b3, "035"b3, "036"b3, "037"b3, "040"b3, "041"b3, "042"b3,
 239           "043"b3, "044"b3, "045"b3, "046"b3, "047"b3, "050"b3, "051"b3, "052"b3, "053"b3, "054"b3, "055"b3, "056"b3,
 240           "057"b3, "060"b3, "061"b3, "062"b3, "063"b3, "064"b3, "065"b3, "066"b3, "067"b3, "070"b3, "071"b3, "072"b3,
 241           "073"b3, "074"b3, "075"b3, "076"b3, "077"b3, "100"b3, "101"b3, "102"b3, "103"b3, "104"b3, "105"b3, "106"b3,
 242           "107"b3, "110"b3, "111"b3, "112"b3, "113"b3, "114"b3, "115"b3, "116"b3, "117"b3, "120"b3, "121"b3, "122"b3,
 243           "123"b3, "124"b3, "125"b3, "126"b3, "127"b3, "130"b3, "131"b3, "132"b3, "133"b3, "134"b3, "135"b3, "136"b3,
 244           "137"b3, "140"b3, "101"b3, "102"b3, "103"b3, "104"b3, "105"b3, "106"b3, "107"b3, "110"b3, "111"b3, "112"b3,
 245           "113"b3, "114"b3, "115"b3, "116"b3, "117"b3, "120"b3, "121"b3, "122"b3, "123"b3, "124"b3, "125"b3, "126"b3,
 246           "127"b3, "130"b3, "131"b3, "132"b3, "173"b3, "174"b3, "175"b3, "176"b3, "177"b3);
 247 
 248 dcl  lower_to_caps_nonedited (128) bit (9) int static options (constant)
 249           init ("000"b3, "001"b3, "002"b3, "003"b3, "004"b3, "005"b3, "006"b3, "007"b3, "010"b3, "011"b3, "012"b3,
 250           "013"b3, "014"b3, "015"b3, "016"b3, "017"b3, "020"b3, "021"b3, "022"b3, "023"b3, "024"b3, "025"b3, "026"b3,
 251           "027"b3, "030"b3, "031"b3, "032"b3, "033"b3, "034"b3, "035"b3, "036"b3, "037"b3, "040"b3, "041"b3, "042"b3,
 252           "043"b3, "044"b3, "045"b3, "046"b3, "047"b3, "050"b3, "051"b3, "052"b3, "053"b3, "054"b3, "055"b3, "056"b3,
 253           "057"b3, "060"b3, "061"b3, "062"b3, "063"b3, "064"b3, "065"b3, "066"b3, "067"b3, "070"b3, "071"b3, "072"b3,
 254           "073"b3, "074"b3, "075"b3, "076"b3, "077"b3, "100"b3, "501"b3, "502"b3, "503"b3, "504"b3, "505"b3, "506"b3,
 255           "507"b3, "510"b3, "511"b3, "512"b3, "513"b3, "514"b3, "515"b3, "516"b3, "517"b3, "520"b3, "521"b3, "522"b3,
 256           "523"b3, "524"b3, "525"b3, "526"b3, "527"b3, "530"b3, "531"b3, "532"b3, "133"b3, "134"b3, "135"b3, "136"b3,
 257           "137"b3, "140"b3, "101"b3, "102"b3, "103"b3, "104"b3, "105"b3, "106"b3, "107"b3, "110"b3, "111"b3, "112"b3,
 258           "113"b3, "114"b3, "115"b3, "116"b3, "117"b3, "120"b3, "121"b3, "122"b3, "123"b3, "124"b3, "125"b3, "126"b3,
 259           "127"b3, "130"b3, "131"b3, "132"b3, "173"b3, "174"b3, "175"b3, "176"b3, "177"b3);
 260 
 261 /* The following declaration is hopefully temporary until prefix characters are encoded in conversion tables */
 262 
 263 dcl  prefix char (1) int static init (">") options (constant);
 264                                                             /* = 076 = 2741 prefix character */
 265 
 266 declare LONGEST_POSSIBLE_STRING fixed bin init (8128) int static options (constant);
 267 
 268 /* ENTRIES */
 269 
 270 dcl  pxss$ring_0_wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
 271 dcl  tty_lock$lock_channel entry (fixed bin, fixed bin (35)),
 272      tty_lock$unlock_channel entry (fixed bin);
 273 
 274 dcl  tty_index$initialize_tcb entry (ptr, ptr);
 275 dcl  tty_util_$mvt entry (ptr);
 276 dcl  tty_util_$scm entry (ptr);
 277 dcl  tty_util_$find_char entry (ptr);
 278 dcl  tty_util_$illegal_char entry (ptr);
 279 
 280 
 281 /* BASED */
 282 
 283 dcl  1 mvt_args aligned based (addr (util)),                /* overlay of tty_util_ structure used for mvt entry */
 284        2 stringptr ptr,
 285        2 stringlen fixed bin,
 286        2 pad fixed bin,
 287        2 tablep ptr,
 288        2 targetp ptr;
 289 
 290 dcl  1 scm_args aligned based (addr (util)),                /* overlay of util structure used for scm entry */
 291        2 stringptr ptr,
 292        2 stringlen fixed bin,
 293        2 scm_tally fixed bin,
 294        2 search_mask bit (2) aligned,
 295        2 found_flag bit (1) aligned;
 296 
 297 dcl  based_onechar char (1) based;
 298 dcl  based_chars (0:1) char (1) based unal;                 /* used for bumping string pointers */
 299 
 300 dcl  output_chars char (output_length) based;
 301 dcl  tally_chars char (ctally) based;
 302 dcl  chars_to_copy char (nchars) based;
 303 
 304 dcl  1 seq based aligned like c_chars;                                /* template of special chars sequence */
 305 
 306 /* EXTERNAL STATIC */
 307 
 308 dcl  tty_tables$ ext static;
 309 dcl  error_table_$improper_data_format fixed bin (35) ext static;
 310 dcl  error_table_$invalid_device fixed bin (35) ext static;
 311 dcl  error_table_$io_no_permission fixed bin (35) ext static;
 312 dcl  error_table_$line_status_pending fixed bin (35) ext static;
 313 dcl  error_table_$noalloc fixed bin (35) ext static;
 314 dcl  error_table_$bad_arg fixed bin (35) ext static;
 315 dcl  error_table_$bigarg fixed bin (35) ext static;
 316 dcl  pds$processid bit (36) ext static;
 317 
 318 
 319 dcl  (addr, bin, bool, byte, clock, divide, fixed, float, hbound, index, length, max,
 320      min, mod, null, ptr, rank, rel, reverse, string, substr, unspec) builtin;
 321 
 322 dcl  cleanup condition;
 323 ^L
 324 %include tty_convert;
 325 ^L
 326 %include tty_buf;
 327 ^L
 328 %include tty_buffer_block;
 329 %include wtcb;
 330 ^L
 331 %include tcb;
 332 ^L
 333 %include lct;
 334 ^L
 335 %include tty_space_man_dcls;
 336 ^L
 337 %include channel_manager_dcls;
 338 %include multiplexer_types;
 339 %include net_event_message;
 340 ^L
 341           locked_entry = "0"b;
 342           forcesw = "0"b;                                   /* normal call, check buffer limit */
 343           go to join;
 344 
 345 /* privileged entry to bypass buffer limit check - thru hphcs_ - used by answering service */
 346 
 347 tty_write_force:
 348      entry (twx, a_readp, a_offset, a_nelem, a_nelemt, a_state, ercode);
 349 
 350           locked_entry = "0"b;
 351           go to force_join;
 352 
 353 
 354 /* entry used to write whole output string or nothing, and optionally set a mark */
 355 
 356 tty_write_whole_string:
 357      entry (twx, a_string, a_mark_flag, a_nelemt, a_state, ercode);
 358 
 359           locked_entry, forcesw = "0"b;
 360           mark_entry = a_mark_flag;
 361           whole_string = "1"b;
 362           go to set_nelem;
 363 
 364 
 365 /* entry used when sending prompts and questions to distinguish between type-ahead and response */
 366 
 367 tty_write_set_mark:
 368      entry (twx, a_string, a_nelemt, a_state, ercode);
 369 
 370           whole_string, locked_entry, forcesw = "0"b;
 371           mark_entry = "1"b;
 372 set_nelem:
 373           nelem = length (a_string);
 374           offset = 0;
 375           readp = addr (a_string);
 376           go to mark_join;
 377 
 378 
 379 
 380 /* special internally-known entry which is called with channel already locked */
 381 
 382 locked:
 383      entry (twx, a_readp, a_offset, a_nelem, a_nelemt, a_state, ercode);
 384 
 385           locked_entry = "1"b;                              /* mark it as this entry so we don't lock/unlock */
 386 
 387 force_join:
 388           forcesw = "1"b;
 389 
 390 join:
 391           nelem = a_nelem;
 392           readp = a_readp;
 393           whole_string, mark_entry = "0"b;
 394           offset = a_offset;
 395 
 396 mark_join:
 397           start_time = clock ();
 398           nelemt = 0;
 399           a_nelemt = 0;
 400           a_state = 0;
 401           ercode = 0;
 402           ttybp = addr (tty_buf$);                          /* get ptrs to tty_buf, tty_data */
 403 
 404           devx = twx;                                       /* copy device index */
 405           lctp = tty_buf.lct_ptr;                           /* init pointer to lct */
 406           if devx < 1 | devx > lct.max_no_lctes
 407           then do;
 408                ercode = error_table_$invalid_device;
 409                return;
 410           end;
 411 
 412           uncp_flag = is_parent_mpx (UNCP_MPX);
 413 
 414           if ^locked_entry
 415           then do;
 416                call tty_lock$lock_channel (devx, ercode);   /* lock the channel lock */
 417                if ercode ^= 0
 418                then return;
 419           end;
 420 
 421           allocated_buffers = "0"b;
 422           on cleanup
 423           begin;
 424                if allocated_buffers
 425                then do;
 426                     allocated_buffers = "0"b;               /* don't try again */
 427                     call free_buffers;
 428                end;
 429                if ^locked_entry
 430                then call tty_lock$unlock_channel (devx);
 431           end;                                              /* cleanup block */
 432 
 433           lctep = addr (lct.lcte_array (devx));             /* get entry of interest */
 434           if lcte.channel_type ^= TTY_MPX                   /* not our type */
 435           then do;
 436 no_permission:
 437                ercode = error_table_$io_no_permission;
 438                go to unlock;
 439           end;
 440 
 441           wtcbp = lcte.data_base_ptr;                       /* get pointers to control blocks */
 442           tcbp = wtcb.tcb_ptr;                              /* get tcb pointer */
 443           if ^wtcb.tcb_initialized
 444           then call tty_index$initialize_tcb (wtcbp, tcbp);
 445 
 446           if pds$processid ^= wtcb.hproc
 447           then if (pds$processid ^= wtcb.uproc) | ^tcb.uproc_attached
 448                then go to no_permission;
 449 
 450           if wtcb.flags.dialed
 451           then state = DIALED_UP;
 452           else if wtcb.flags.listen
 453           then state = LISTENING;
 454           else if wtcb.flags.masked
 455           then state = MASKED_STATE;
 456           else state = HUNG_UP;
 457 
 458           if state ^= DIALED_UP
 459           then do;
 460                if pds$processid = wtcb.hproc
 461                then a_state = state;
 462                go to no_permission;
 463           end;
 464 
 465           a_state = state;
 466 
 467           if wtcb.flags.line_status_present
 468           then do;
 469                ercode = error_table_$line_status_pending;
 470                go to unlock;
 471           end;
 472 
 473           if wtcb.error_code ^= 0
 474           then do;
 475                ercode = wtcb.error_code;
 476                wtcb.error_code = 0;
 477                go to unlock;
 478           end;
 479 
 480           if nelem < 0
 481           then do;
 482                ercode = error_table_$bad_arg;
 483                go to unlock;
 484           end;
 485                                                             /* Added for the Datanet 7100. */
 486           if uncp_flag then do;
 487                if readp = addr (wtcb.prompt)
 488                     then do;
 489                     wtcb.send_turn = "1"b;
 490                     if nelem = 0
 491                          then do;
 492                          if wtcb.write_last ^= 0
 493                               then do;
 494                               blockp = ptr (ttybp, wtcb.write_last);
 495                               buffer.turn = "1"b;
 496                               wtcb.send_turn = "0"b;
 497                          end;
 498                     end;
 499                end;
 500           end;
 501 
 502           ercode = 0;
 503           if nelem = 0
 504           then go to all_done;
 505 
 506           eop_sentinel = byte (eop_sentinel_octal);
 507 
 508           if ^tcb.modes.rawom                               /* if we're interested in conversion */
 509           then do;
 510                ttytp = addr (tty_tables$);
 511                if tcb.output_tctrp = ""b
 512                then tctp = null;
 513                else tctp = ptr (ttytp, tcb.output_tctrp);
 514                if tcb.output_mvtrp = ""b
 515                then mvtp = null;
 516                else mvtp = ptr (ttytp, tcb.output_mvtrp);
 517                if tcb.specialrp = ""b
 518                then special_ptr = null;
 519                else special_ptr = ptr (ttytp, tcb.specialrp);
 520                if tcb.delayrp = ""b
 521                then delay_ptr = null;
 522                else delay_ptr = ptr (ttytp, tcb.delayrp);
 523           end;
 524 
 525 /*^L*/
 526 /* calculate number of buffers line is allowed to have */
 527 
 528           if forcesw
 529           then max_space = tty_buf.bleft - 32;              /* force entry can have as many as it needs */
 530           else do;
 531                cur_space = 0;
 532                cur_chain_len = 0;
 533                if wtcb.write_first ^= 0
 534                then do;
 535                     blockp = ptr (ttybp, wtcb.write_first);
 536                     end_chain = "0"b;
 537                     do while (^end_chain);
 538                          cur_space = cur_space + 16 * (buffer.size_code + 1);
 539                          cur_chain_len = cur_chain_len + 1;
 540                          if buffer.next = 0
 541                          then end_chain = "1"b;
 542                          else blockp = ptr (ttybp, buffer.next);
 543                     end;
 544                end;
 545                max_space =
 546                     min (divide (tty_buf.bleft, output_bpart, 17, 0) - cur_space,
 547                     (max_chain_len - cur_chain_len) * (wtcb.max_buf_size - 1));
 548           end;
 549 
 550           max_chars_in_buf = 4 * (wtcb.max_buf_size - 1) - wtcb.buffer_pad;
 551 
 552           if max_space <= 0
 553           then
 554 NO_SPACE_WRITE_NOTHING:
 555           do;
 556                nelemt = 0;
 557                go to nothing_written;
 558           end;                                              /* otherwise only certain fraction can be allocated */
 559 
 560           max_chars = min (4 * max_space, LONGEST_POSSIBLE_STRING);   /* don't overflow tty_buf or the stack */
 561 
 562 /* Determine good sizes for internal automatic buffers for the duration of this call */
 563 /* max_chars takes account of all policy limitations */
 564 
 565           auto_buf_len = min (max_chars, 512 + 2 * nelem);  /* leave lots of leeway */
 566           max_chars = auto_buf_len;
 567           if whole_string & nelem > max_chars               /* can't possibly take all of this */
 568           then do;
 569                if nelem <= LONGEST_POSSIBLE_STRING
 570                then go to NO_SPACE_WRITE_NOTHING;
 571                ercode = error_table_$bigarg;
 572                go to unlock;
 573           end;
 574 ^L
 575           begin;                                            /* giant begin block */
 576 
 577 dcl  buffer_1 char (auto_buf_len) aligned;                  /* first internal workspace buffer */
 578 dcl  buffer_2 char (auto_buf_len) aligned;                  /* second internal workspace buffer */
 579 
 580                input_ptr = readp;
 581                input_ptr = addr (input_ptr -> based_chars (offset));
 582 
 583                nelemt = -1;                                 /* to indicate first time around */
 584 
 585 restart:                                                    /* come here if we have to start over */
 586                if tcb.modes.rawom                           /* raw output, simple */
 587                then do;
 588                     final_outp = input_ptr;                 /* copy straight from user's data */
 589                     if nelemt < 0                           /* i.e. not restart */
 590                     then nelemt = min (nelem, max_chars);
 591                     output_length = nelemt;
 592                end;
 593 
 594                else do;                                     /* else we must massage the input */
 595                     if nelemt < 0                           /* if not already set */
 596                     then nelemt = min (nelem, fixed (reduction_factor * max_chars));
 597 
 598                     line_count = wtcb.actline;
 599                     col = wtcb.actcol;
 600                     wcol = wtcb.white_col;
 601 
 602                     final_outp, source_ptr = input_ptr;     /* to begin with */
 603                     source_len = nelemt;
 604                     target_ptr = addr (buffer_1);
 605                     target_len = 0;
 606 
 607                     if tcb.modes.upper_case
 608                     then call convert_to_upper_case;        /* translate lower-case to caps? */
 609 ^L
 610 /* ** FORMATTING ** */
 611 
 612                     if tctp ^= null                         /* must have output conversion table */
 613                          & special_ptr ^= null              /* and special chars table too */
 614                     then do;
 615                          target_len = 0;                    /* initially */
 616                          chars_moved = "0"b;
 617                          white_sw = (wcol ^= col);          /* depends on whether there's white space left from last call */
 618 
 619                          final_outp = target_ptr;           /* where we expect stuff to end up */
 620 
 621                          if tcb.linemax > 0
 622                          then do;
 623                               if line_count >= tcb.linemax  /* did input cause EOP condition ? */
 624                               then do;                      /* yes, write eop sequence now */
 625                                    seqp = addr (special_ptr -> special_chars.end_of_page);
 626                                    if seqp -> seq.count > 0 /* must have something to write */
 627                                    then do;
 628                                         call insert_sequence ("0"b);
 629                                         call insert_char (eop_sentinel);
 630                                         line_count = 0;
 631                                    end;
 632                               end;
 633                          end;
 634 
 635                          util.tablep = tctp;                /* formatting table */
 636                          util.stringp = source_ptr;
 637                          util.stringl = source_len;
 638 
 639                          do while (util.stringl > 0);       /* main formatting loop */
 640 
 641                               oldcol = col;
 642                               call tty_util_$find_char (addr (util));
 643                                                             /* find next interesting character */
 644 
 645                               call move_formated_chars;
 646 
 647                               if ^white_sw
 648                               then wcol = col;              /* so next white-space calculation will be right */
 649 
 650                          end;                               /* end of formatting loop */
 651 
 652                          if white_sw                        /* take care of trailing white space */
 653                          then if nelemt = nelem             /* if output really ends in white space */
 654                               then call insert_white;
 655                               else if target_len = 0        /* only white? */
 656                                    then call insert_white;  /* expand it */
 657 
 658                     end;
 659 
 660                     else target_len = source_len;           /* no conversion performed */
 661 
 662                     if mvtp ^= null
 663                     then call translation;                  /* translation required */
 664 
 665                     output_length = target_len;
 666                end;                                         /* end of all conversion phases */
 667 ^L
 668 /* ****ALLOCATE BUFFERS AND PASS OUTPUT ON*** */
 669 
 670                new_char_count, new_buffer_count = 0;
 671 
 672                if output_length > 0                         /* assuming there's anything left after conversion */
 673                then do;
 674                     first_buffer = "1"b;
 675                     old_end_frame = wtcb.end_frame;
 676 
 677                     if wtcb.write_last = 0
 678                     then do;
 679                          send = "1"b;                       /* there's nothing ahead of it, so we'll send it on */
 680                          old_head, old_tail = 0;
 681                     end;
 682 
 683                     else do;                                /* save information about old chain */
 684                          lastp, old_lastp = ptr (ttybp, wtcb.write_last);
 685                          send = "0"b;                       /* we'll just hang on to this */
 686                          old_head = wtcb.write_first;
 687                          old_tail = wtcb.write_last;
 688                     end;
 689 
 690                     n_pages = 0;
 691                     headp = null;
 692                     new_head = 0;
 693                     allocated_buffers = "1"b;               /* crawlout can now safely free them */
 694 
 695                     do while (output_length > 0);           /* copy for as long as necessary */
 696                          n_pages = n_pages + 1;
 697 
 698                          if tcb.modes.rawom                 /* if raw mode don't check for end of page */
 699                          then go to no_break;
 700 
 701                          break_length = index (final_outp -> output_chars, eop_sentinel) - 1;
 702                                                             /* look for page break */
 703                          if break_length < 0
 704                          then do;
 705 no_break:
 706                               break_flag = "0"b;            /* no end-of-page markers */
 707                               break_length = output_length;
 708                          end;
 709 
 710                          else do;
 711                               break_flag = "1"b;
 712                               if break_length = 0
 713                               then do;                      /* eop sentinel was first thing */
 714                                    final_outp -> based_chars (0) = byte (delay_char);
 715                                                             /* send out a NUL because we have to send something to alert lower level */
 716                                    break_length = 1;
 717                                    null_for_eop = "1"b;
 718                               end;
 719                               else null_for_eop = "0"b;
 720                          end;
 721 
 722                          if tcb.block_acknowledge & tcb.oflow & tcb.max_output_block > 0
 723                                                             /* new buffer at every end-of-block */
 724                          then break_length = min (break_length, tcb.max_output_block);
 725 
 726                          output_length = output_length - break_length;
 727 
 728                          do while (break_length > 0);
 729 
 730 /* do we have a buffer with room in it? */
 731 
 732                               if wtcb.write_last = 0
 733                               then go to get_new_buf;
 734                               if lastp -> buffer.tally < max_chars_in_buf & ^lastp -> buffer.flags.end_of_page
 735                                    & ^(tcb.block_acknowledge & tcb.oflow & tcb.max_output_block > 0)
 736                               then do;
 737                                    lchar = lastp -> buffer.tally;
 738 
 739 /* make new buffer as big as appropriate */
 740 
 741                                    buf_size, orig_buf_size = 16 * (lastp -> buffer.size_code + 1);
 742                                    reached_needed = "0"b;   /* assume not yet reached appropriate size */
 743                                    do while (^reached_needed);
 744                                         chars_in_buf = 4 * (buf_size - 1) - wtcb.buffer_pad;
 745                                         if lchar + break_length <= chars_in_buf
 746                                                             /* room in this buffer for rest of output */
 747                                              | chars_in_buf = max_chars_in_buf
 748                                                             /* or we've already reached maximum allowable size */
 749                                         then reached_needed = "1"b;
 750                                         else buf_size = buf_size + 16;
 751                                                             /* try next size */
 752                                    end;
 753 
 754                                    if buf_size ^= orig_buf_size
 755                                                             /* if we need a new size */
 756                                    then do;                 /* get new buffer, and copy contents of old one */
 757                                         call tty_space_man$get_buffer (devx, buf_size, OUTPUT, new_bufp);
 758                                         if new_bufp ^= null /* only do this if we could get it, of course */
 759                                         then do;
 760                                              nchars = lastp -> buffer.tally;
 761                                              source_ptr = addr (lastp -> buffer.chars (0));
 762                                              target_ptr = addr (new_bufp -> buffer.chars (0));
 763                                              target_ptr -> chars_to_copy = source_ptr -> chars_to_copy;
 764                                              new_bufp -> buffer.tally = lastp -> buffer.tally;
 765                                              wtcb.write_last = bin (rel (new_bufp), 18);
 766                                                             /* this will now be end of chain */
 767 
 768                                                             /* Add for the Datanet 7100. */
 769                                              if uncp_flag then new_bufp -> buffer.turn = lastp -> buffer.turn;
 770                                                             /* copy turn flag into new buffer */
 771 
 772 /* thread new buffer onto end of chain in place of old one */
 773 
 774                                              prevp = ptr (ttybp, wtcb.write_first);
 775                                                             /* start at head */
 776                                              if prevp = lastp
 777                                                             /* is it tail also? */
 778                                              then wtcb.write_first = wtcb.write_last;
 779                                                             /* that's simple */
 780                                              else do;       /* else we'll scan the chain */
 781                                                   do prevp = prevp repeat ptr (ttybp, prevp -> buffer.next)
 782                                                        while (prevp -> buffer.next ^= bin (rel (lastp), 18)
 783                                                        & prevp -> buffer.next ^= 0);
 784                                                   end;
 785                                                   prevp -> buffer.next = wtcb.write_last;
 786                                                             /* found the next-to-last one */
 787                                              end;
 788 
 789                                              call tty_space_man$free_buffer (devx, OUTPUT, lastp);
 790                                                             /* give the old one back */
 791                                              lastp = new_bufp;
 792 
 793                                              if first_buffer
 794                                              then do;
 795                                                   old_lastp = lastp;
 796                                                   old_tail = wtcb.write_last;
 797                                                   if wtcb.write_first = wtcb.write_last
 798                                                   then old_head = wtcb.write_first;
 799                                              end;
 800                                         end;
 801 
 802                                         else chars_in_buf = 4 * (orig_buf_size - 1) - wtcb.buffer_pad;
 803                                                             /* couldn't get bigger buffer, use original size */
 804                                    end;
 805 
 806                                    bufp = addr (lastp -> buffer.chars (lchar));
 807                                    old_char_count = lastp -> buffer.tally;
 808                                    nchars = min (break_length, chars_in_buf - lchar);
 809                               end;
 810 
 811                               else do;                      /* no, we'll have to get one */
 812 get_new_buf:
 813                                    words_needed =
 814                                         max (16,
 815                                         min (wtcb.max_buf_size,
 816                                         16 * divide (break_length + wtcb.buffer_pad + 67, 64, 17, 0)));
 817                                    call tty_space_man$get_buffer (devx, words_needed, OUTPUT, new_bufp);
 818                                    if new_bufp = null       /* couldn't get the space */
 819                                    then go to free_and_try_again;
 820                                    new_buf = bin (rel (new_bufp), 18);
 821                                    chars_in_buf = 4 * (words_needed - 1) - wtcb.buffer_pad;
 822 
 823                                    if first_buffer
 824                                    then do;
 825                                         new_head = new_buf;
 826                                         first_buffer = "0"b;
 827                                    end;
 828 
 829                                    new_buffer_count = new_buffer_count + 1;
 830                                    lchar = 0;
 831                                    if wtcb.write_last ^= 0  /* chain already abuilding */
 832                                    then lastp -> buffer.next = new_buf;
 833                                    else wtcb.write_first = new_buf;
 834 
 835                                    wtcb.write_last = new_buf;
 836                                                             /* in any case */
 837                                    lastp = new_bufp;
 838                                    string (lastp -> buffer.flags) = "0"b;
 839 
 840                                    old_char_count = 0;
 841                                    bufp = addr (lastp -> buffer.chars (0));
 842                                    nchars = min (break_length, chars_in_buf);
 843                               end;
 844 
 845                               lastp -> buffer.tally = old_char_count + nchars;
 846                               lastp -> buffer.flags.break = "0"b;
 847                                                             /* not at end of user data */
 848                               bufp -> chars_to_copy = final_outp -> chars_to_copy;
 849                                                             /* put characters in buffer */
 850                               final_outp = addr (final_outp -> based_chars (nchars));
 851                               new_char_count = new_char_count + nchars;
 852                               break_length = break_length - nchars;
 853 
 854                                                             /* Add for the Datanet 7100. */
 855                               if uncp_flag then do;
 856                                    if break_length = 0
 857                                         then do;
 858                                         lastp -> buffer.turn = wtcb.send_turn;
 859                                         wtcb.send_turn = "0"b;
 860                                    end;
 861                               end;
 862                          end;
 863 
 864 
 865                          if break_flag                      /* did we stop because of end-of-page? */
 866                          then do;
 867                               lastp -> buffer.flags.end_of_page = "1"b;
 868                               if ^null_for_eop              /* if we haven't laready skipped over sentinel */
 869                               then do;
 870                                    final_outp = addr (final_outp -> based_chars (1));
 871                                                             /* skip over sentinel */
 872                                    output_length = output_length - 1;
 873                               end;
 874                          end;
 875 
 876                          if tcb.block_acknowledge & tcb.oflow & tcb.max_output_block > 0
 877                          then do;                           /* insert end_of_block char */
 878                               if lastp -> buffer.tally < chars_in_buf
 879                                                             /* it'll fit in last buffer */
 880                               then do;
 881                                    lastp -> buffer.chars (lastp -> buffer.tally) =
 882                                         substr (tcb.output_suspend_etb_seq.chars, 1, 1);
 883                                    lastp -> buffer.tally = lastp -> buffer.tally + 1;
 884                               end;
 885 
 886                               else do;                      /* unfortunately, we have to allocate a whole buffer for this char */
 887                                    call tty_space_man$get_buffer (devx, 16, OUTPUT, new_bufp);
 888                                    if new_bufp = null
 889                                    then go to free_and_try_again;
 890                                    string (new_bufp -> buffer.flags) = "0"b;
 891                                    new_bufp -> buffer.tally = 1;
 892                                    new_bufp -> buffer.chars (0) = substr (tcb.output_suspend_etb_seq.chars, 1, 1);
 893                                    wtcb.write_last, lastp -> buffer.next = bin (rel (new_bufp), 18);
 894                                    lastp = new_bufp;
 895                               end;
 896                          end;
 897                     end;                                    /* end of buffer-allocation loop */
 898 
 899                     if nelem = nelemt
 900                     then do;
 901                          lastp -> buffer.flags.break = "1"b;/* end of user data */
 902                          lastp -> buffer.flags.mark = mark_entry;
 903                     end;
 904 
 905                     if send & wtcb.send_output              /* if this is first new output, we'll pass it on */
 906                     then do;
 907                          if n_pages > 1
 908                          then do;                           /* peel off first page if there's more than one */
 909                               blockp = ptr (ttybp, wtcb.write_first);
 910 
 911                               do while (^buffer.end_of_page & buffer.next ^= 0);
 912                                                             /* find last buffer of page */
 913                                    blockp = ptr (ttybp, buffer.next);
 914                               end;
 915 
 916                               lastp = blockp;               /* this is it */
 917                          end;
 918 
 919                          else lastp = ptr (ttybp, wtcb.write_last);
 920                                                             /* if only 1 page, last buffer is last buffer of page */
 921                          if mark_entry
 922                          then wtcb.mark_set = lastp -> buffer.mark;
 923                                                             /* we're sending the mark now */
 924                          new_head = lastp -> buffer.next;   /* this will be the head of the remaining chain (if any) */
 925                          headp = ptr (ttybp, wtcb.write_first);
 926                          wtcb.write_first = lastp -> buffer.next;
 927                                                             /* update wtcb pointers now (we'll restore them if necessary) */
 928                          if wtcb.write_first = 0
 929                          then wtcb.write_last = 0;          /* ensure consistency always */
 930                          lastp -> buffer.next = 0;          /* break the chain at page end */
 931                          wtcb.end_frame = lastp -> buffer.end_of_page;
 932 
 933                          call channel_manager$write (devx, headp, ercode);
 934                          if ercode = error_table_$noalloc
 935                          then do;
 936                               nelemt = 0;                   /* this means they couldn't take it at all */
 937                               call free_buffers;
 938                               go to nothing_written;
 939                          end;
 940                          else do;
 941                               if ercode ^= 0
 942                               then do;
 943                                    call free_buffers;       /* get rid of anything we've got left (it's unwritable) */
 944                                    if wtcb.write_first ^= 0 /* and I mean ANYTHING */
 945                                    then do;
 946                                         call tty_space_man$free_chain (devx, OUTPUT, ptr (ttybp, wtcb.write_first));
 947                                         wtcb.write_first, wtcb.write_last = 0;
 948                                         wtcb.mark_set = "0"b;
 949                                                             /* all bets are off */
 950                                    end;
 951                               end;
 952 
 953                               else if headp ^= null
 954                               then do;                      /* didn't take it all */
 955                                    wtcb.write_first = bin (rel (headp));
 956                                    blockp = headp;
 957                                    do while (buffer.next ^= 0);
 958                                                             /* find end of returned chain */
 959                                         blockp = ptr (ttybp, buffer.next);
 960                                    end;
 961 
 962                                    buffer.next = new_head;  /* hook it back on */
 963                                    if wtcb.write_last = 0   /* sent all we had */
 964                                    then wtcb.write_last = bin (rel (blockp));
 965                                                             /* this is now end of the chain */
 966 
 967                                    if mark_entry
 968                                    then wtcb.mark_set = "0"b;
 969                                                             /* override any previously-set mark */
 970                               end;
 971                               wtcb.send_output = "0"b;      /* no more till he asks for it */
 972                          end;
 973                     end;
 974                end;
 975 ^L
 976                if ^tcb.modes.rawom
 977                then do;                                     /* only if messed around with it */
 978                     wtcb.actcol = col;
 979                     wtcb.actline = line_count;
 980                     wtcb.white_col = wcol;
 981                end;
 982 
 983                if nelemt < nelem
 984                then do;                                     /* we couldn't get them all out this time */
 985                     i = (nelem - nelemt);                   /* approximate num of chars left to output */
 986                     if tty_buf.minbuf = 0 | tty_buf.minbuf > i
 987                     then tty_buf.minbuf = i;                /* if new minimum, set it */
 988 
 989                     tty_buf.totbuf = tty_buf.totbuf + i;    /* set blocked-for-write meters  */
 990                     tty_buf.nblocked = tty_buf.nblocked + 1;
 991 
 992                     /*** If we did not consume all of our caller's output but
 993                     generated no output, ensure that the process sees a wakeup
 994                     so that the rest of the output will be handled. */
 995 
 996                     if wtcb.send_output                     /* nothing in progress */
 997                     then do;
 998                          unspec (net_event_message) = "0"b;
 999                          net_event_message.version = NET_EVENT_MESSAGE_VERSION_1;
1000                          net_event_message.network_type = MCS_NETWORK_TYPE;
1001                          net_event_message.handle = devx;
1002                          net_event_message.type = MCS_WRITE_MSG;
1003                          call pxss$ring_0_wakeup (wtcb.uproc, wtcb.event, net_event_message_arg, (0));
1004                          wtcb.wflag = "0"b;
1005                     end;
1006                     else wtcb.flags.wflag = "1"b;           /* so wakeup will happen when write completes */
1007                end;
1008 
1009                tcb.cumulative_meters.write_chars = tcb.cumulative_meters.write_chars + nelemt;
1010                tcb.cumulative_meters.write_calls = tcb.cumulative_meters.write_calls + 1;
1011                tty_buf.write_calls = tty_buf.write_calls + 1;
1012                tty_buf.noutchars = tty_buf.noutchars + nelemt;
1013                                                             /* keep count of output chars per type */
1014                tty_buf.nrawwrite = tty_buf.nrawwrite + new_char_count;
1015                go to all_done;
1016 
1017 free_and_try_again:                                         /* here if we or next level couldn't allocate buffers */
1018                call free_buffers;
1019                tty_buf.output_buffer_overflow = tty_buf.output_buffer_overflow + 1;
1020 try_again:                                                  /* here if we overflowed internal buffer space */
1021                if whole_string                              /* mustn't subdivide caller's string */
1022                then do;
1023                     nelemt = 0;
1024                     go to nothing_written;
1025                end;
1026 
1027                tty_buf.output_restart = tty_buf.output_restart + 1;
1028 
1029                nelemt = divide (nelemt, 2, 18, 0);          /* cut in half to try again */
1030                if nelemt > 0                                /* does that leave us anything to process? */
1031                then go to restart;
1032                else go to nothing_written;
1033 
1034 
1035 
1036 /* *** ERROR BRANCH FOR FAULTY TABLE VALUES *** */
1037 
1038 table_error:
1039                ercode = error_table_$improper_data_format;
1040                go to unlock;
1041 ^L
1042 /* ***********INTERNAL PROCEDURES********* */
1043 
1044 copy_chars:
1045      proc;
1046 
1047 /* This procedure copies ctally characters form source_ptr to target_ptr */
1048 
1049           target_len = target_len + ctally;
1050           if target_len > max_chars                         /* check for overflow */
1051           then go to try_again;
1052 
1053           target_ptr -> tally_chars = source_ptr -> tally_chars;
1054 
1055           source_ptr = addr (source_ptr -> based_chars (ctally));
1056                                                             /* bump pointers */
1057           target_ptr = addr (target_ptr -> based_chars (ctally));
1058           return;
1059 
1060      end /* copy_chars */;
1061 ^L
1062 insert_char:
1063      proc (one_char);
1064 
1065 /* This procedure places a single character in the output string */
1066 
1067 dcl  one_char char (1);
1068 
1069           target_len = target_len + 1;
1070           if target_len > max_chars                         /* mustn't overflow buffer space */
1071           then go to try_again;
1072 
1073           target_ptr -> based_onechar = one_char;
1074           target_ptr = addr (target_ptr -> based_chars (1));
1075           return;
1076 
1077      end /* insert_char */;
1078 ^L
1079 insert_delays:
1080      proc (ndelays);
1081 
1082 /* This procedure inserts a specified number of delay characters into the output */
1083 
1084 dcl  ndelays fixed bin;
1085 dcl  i fixed bin;
1086 
1087           if ndelays <= 0
1088           then return;                                      /* nothing to do */
1089 
1090           target_len = target_len + ndelays;
1091           if target_len > max_chars                         /* red warning */
1092           then go to try_again;                             /* tough */
1093 
1094           do i = 0 to ndelays - 1;                          /* remember based_chars starts at 0 */
1095                target_ptr -> based_chars (i) = byte (delay_char);
1096           end;
1097 
1098           target_ptr = addr (target_ptr -> based_chars (ndelays));
1099                                                             /* bump pointer */
1100           return;
1101 
1102      end /* insert_delays */;
1103 ^L
1104 insert_sequence:
1105      proc (a_col_sw);
1106 
1107 /* This procedure inserts the character sequence pointed to by seqp */
1108 /* col_sw tells whether or not to check for overflowing line-length */
1109 
1110 dcl  a_col_sw bit (1) aligned;
1111 dcl  col_sw bit (1) aligned;
1112 dcl  i fixed bin;
1113 dcl  auto_len fixed bin;
1114 
1115           col_sw = a_col_sw;
1116           c_chars_ptr = seqp;                               /* make compiler happy */
1117           auto_len = seqp -> seq.count;                     /* copy sequence length into automatic */
1118           if auto_len = 0
1119           then return;                                      /* no sequence */
1120 
1121           if auto_len < 0 | auto_len > hbound (c_chars.chars, 1)/* probably not a real sequence */
1122           then go to table_error;
1123 
1124           target_len = target_len + auto_len;
1125           if target_len > max_chars
1126           then go to try_again;
1127 
1128           if seqp -> seq.chars (1) = ascii_escape_char
1129           then col_sw = "0"b;                               /* if escape sequence, best not to mess with the columns */
1130           do i = 1 to auto_len;
1131                if col_sw                                    /* do we care about column position? */
1132                then do;                                     /* yes */
1133                     if seqp -> seq.chars (i) = backspace    /* back up with delays in this case */
1134                     then do;
1135                          col = max (0, col - 1);
1136                          if delay_ptr ^= null
1137                          then call insert_delays (delay_ptr -> delay.backspace);
1138                     end;
1139 
1140                     else if rank (seqp -> seq.chars (i)) < 32
1141                     then ;                                  /* if so, then probably doesn't move carriage */
1142                                                             /* adding 0 is just as good as + 1 when we don't know what
1143                                                                the chars really do to the terminal */
1144 
1145                     else do;
1146                          if ((tcb.colmax > 0) & (col >= tcb.colmax))
1147                          then call insert_nl ("1"b);
1148                          col = col + 1;
1149                     end;
1150                end;
1151 
1152                target_ptr -> based_onechar = seqp -> seq.chars (i);
1153                target_ptr = addr (target_ptr -> based_chars (1));
1154                                                             /* bump pointer */
1155           end;
1156 
1157           return;
1158 
1159      end /* insert_sequence */;
1160 ^L
1161 insert_white:
1162      proc;
1163 
1164 /* this procedure puts white space into the output string */
1165 
1166           if wcol ^= col                                    /* make sure we're not already where we belong */
1167           then do;
1168                if tcb.colmax > 0
1169                then do while (wcol > tcb.colmax);           /* put in any necessary new-lines */
1170                     call insert_nl ("1"b);
1171                     oldcol = 2;
1172                     wcol = wcol - tcb.colmax + 2;
1173                end;
1174 
1175                if wcol < col                                /* we're going to have to back up */
1176                then if wcol = 0                             /* that one's easy */
1177                     then call insert_cr;                    /* just put in carriage return */
1178 
1179                     else if special_ptr -> special_chars.cr_seq.count > 0
1180                     then do;                                /* figure out which way to back up */
1181                          back_chars = col - wcol;           /* that's how many backspaces it would take */
1182                          if back_chars <= 6                 /* in this case don't bother calculating other */
1183                          then forward_chars = back_chars;   /* to make sure test will fail */
1184                          else if tcb.modes.tabm
1185                          then forward_chars = divide (wcol, 10, 17, 0) + mod (wcol, 10) + 1;
1186                                                             /* tabs + spaces + cr */
1187                          else forward_chars = wcol + 1;     /* spaces + cr */
1188 
1189                          if back_chars - forward_chars > 6 | special_ptr -> special_chars.bs_seq.count = 0
1190                                                             /* no backspace available */
1191                          then call insert_cr;               /* thereby setting col to 0, we'll do forward later */
1192                          else call insert_bs (back_chars);  /* put in necessary number of backspaces */
1193                     end;
1194 
1195                     else call insert_bs (col - wcol);
1196 
1197                if wcol > col                                /* we have to go forward */
1198                then do;
1199                     if tcb.modes.tabm                       /* might we use tabs? */
1200                     then do;
1201                          do while (wcol - col > 10);        /* tabs are relevant */
1202                               call insert_tab;              /* will update col */
1203                          end;
1204 
1205                          if mod (wcol, 10) <= mod (col, 10) /* room for another tab */
1206                          then call insert_tab;
1207                     end;
1208 
1209                     do col = col by 1 while (col < wcol);
1210                          call insert_char (space);          /* put in spaces as required */
1211                     end;
1212                end;
1213           end;
1214 
1215           oldcol = wcol;
1216           white_sw = "0"b;                                  /* we've done it now */
1217           return;
1218 
1219      end /* insert_white */;
1220 ^L
1221 insert_nl:
1222      proc (esc_sw);
1223 
1224 /* This procedure inserts new-line sequences in the output string */
1225 /* esc_sw indicates whether a "\c" sequence should be added */
1226 
1227 dcl  esc_sw bit (1) aligned;
1228 dcl  delay_before bit (1) aligned;
1229 dcl  eop_sw bit (1) aligned;
1230 dcl  eop_seqp ptr;
1231 dcl  seqp ptr;
1232 dcl  based_target_chars char (target_len) based;
1233 
1234           eop_sw = "0"b;
1235           eop_seqp = null;
1236 
1237           if tcb.linemax > 0
1238           then do;
1239                line_count = line_count + 1;
1240                eop_sw = (line_count >= tcb.linemax);
1241                if eop_sw
1242                then do;
1243                     eop_seqp = addr (special_ptr -> special_chars.end_of_page);
1244                     if eop_seqp -> seq.count = 0            /* null end-of-page sequence */
1245                     then eop_seqp = null;
1246                     line_count = 0;
1247                end;
1248           end;
1249 
1250           if eop_sw & (eop_seqp = null)                     /* omit end-of-page marker and put sentinel before newline */
1251           then do;
1252                if target_len = 0                            /* don't let sentinel be first thing in output */
1253                then call insert_char (byte (delay_char));   /* so insert a NUL */
1254                call insert_char (eop_sentinel);
1255           end;
1256 
1257           else do;
1258                seqp = addr (special_ptr -> special_chars.nl_seq);
1259                                                             /* this is the sequence we will use */
1260 
1261                if delay_ptr ^= null                         /* delays needed */
1262                then do;
1263                     horiz = delay_ptr -> delay.horz_nl;
1264                     vert = delay_ptr -> delay.vert_nl;
1265 
1266                     if vert < 0                             /* special */
1267                     then do;                                /* means minimum line length */
1268                          ll = index (reverse (final_outp -> based_target_chars), nl) - 1;
1269                                                             /* find latest nl */
1270                          if ll < 0
1271                          then ll = target_len;
1272                          n_delays = max (0, -vert - ll);
1273 
1274                          delay_before = "1"b;               /* put delays before sequence */
1275                     end;
1276 
1277                     else do;                                /* normal delays */
1278                          delay_before = "0"b;               /* delays after nl */
1279                          n_delays = vert + fixed (float (col) * horiz, 17, 0);
1280                     end;
1281                end;
1282 
1283                else n_delays = 0;
1284 
1285                if delay_before                              /* do it now */
1286                then if n_delays > 0                         /* if at all */
1287                     then call insert_delays (n_delays);
1288 
1289                call insert_sequence_internal;               /* put in the sequence */
1290 
1291                if ^delay_before
1292                then if n_delays > 0
1293                     then call insert_delays (n_delays);
1294 
1295                if eop_sw
1296                then do;
1297                     seqp = eop_seqp;
1298                     call insert_sequence_internal;          /* put in end-of-page warning */
1299                     call insert_char (eop_sentinel);        /* put in sentinel for copying phase */
1300                end;
1301           end;
1302 
1303           if esc_sw                                         /* was this nl because of line overflow? */
1304           then do;
1305                call insert_char (escape_char);
1306                call insert_char (cont_char);
1307                col = 2;
1308           end;
1309 
1310           else col = 0;
1311 
1312           return;
1313 ^L
1314 insert_sequence_internal:
1315           proc;
1316 
1317 /* this is an internal procedure in insert_nl because if insert_nl calls */
1318 /* insert_sequence both procedures become non-quick
1319    because insert_sequence has the potential to call insert_nl, thus they
1320    would be recursive and by definition recursion is reason for being non-quick
1321 */
1322 
1323 dcl  i fixed bin;
1324 dcl  auto_len fixed bin;
1325 
1326                c_chars_ptr = seqp;                          /* make compiler happy */
1327                auto_len = seqp -> seq.count;                /* copy sequence length into automatic */
1328                if auto_len = 0
1329                then return;                                 /* no sequence */
1330 
1331                if auto_len < 0 | auto_len > hbound (c_chars.chars, 1) /* probably not a real sequence */
1332                then go to table_error;
1333 
1334                target_len = target_len + auto_len;
1335                if target_len > max_chars
1336                then go to try_again;
1337 
1338                do i = 1 to auto_len;
1339                     target_ptr -> based_chars (i - 1) = seqp -> seq.chars (i);
1340                end;
1341 
1342                target_ptr = addr (target_ptr -> based_chars (auto_len));
1343                                                             /* bump pointer */
1344                return;
1345 
1346           end /* insert_sequence_internal */;
1347 
1348      end /* insert_nl */;
1349 ^L
1350 insert_cr:
1351      proc;
1352 
1353 /* This procedure inserts a carriage return */
1354 
1355           if col = 0
1356           then return;                                      /* no need */
1357 
1358           seqp = addr (special_ptr -> special_chars.cr_seq);
1359           if seqp -> seq.count = 0
1360           then call insert_bs (col);                        /* if cr not implemented, use backspaces */
1361 
1362           else do;
1363                call insert_sequence ("0"b);
1364                if delay_ptr ^= null
1365                then if delay_ptr -> delay.horz_nl ^= 0
1366                     then call insert_delays (
1367                               max (delay_ptr -> delay.horz_nl * col + max (0, delay_ptr -> delay.vert_nl), 1));
1368 
1369                col = 0;
1370           end;
1371 
1372           return;
1373 
1374      end /* insert_cr */;
1375 ^L
1376 insert_bs:
1377      proc (how_many);
1378 
1379 /* This procedure inserts a specified number of backspaces in the output string */
1380 
1381 dcl  how_many fixed bin;
1382 dcl  count fixed bin;
1383 dcl  i fixed bin;
1384 dcl  bs_char char (1);
1385 dcl  new_col fixed bin;
1386 
1387           count = min (how_many, col);
1388           if count <= 0
1389           then return;
1390 
1391           seqp = addr (special_ptr -> special_chars.bs_seq);
1392           if seqp -> seq.count = 0                          /* no backspace for this terminal */
1393           then do;
1394                new_col = col - count;
1395                seqp = addr (special_ptr -> special_chars.cr_seq);
1396                                                             /* do carriage return, then forward space */
1397                if seqp -> seq.count = 0
1398                then return;                                 /* nothing to do here */
1399                call insert_sequence ("0"b);
1400                if delay_ptr ^= null
1401                then if delay_ptr -> delay.horz_nl ^= 0
1402                     then if delay_ptr -> delay.vert_nl >= 0
1403                          then call insert_delays (max (fixed (delay_ptr -> delay.horz_nl * float (col), 17, 0), 1));
1404 
1405                col = 0;
1406                if new_col = 0
1407                then return;                                 /* all done */
1408 
1409                if tcb.modes.tabm                            /* use tabs if appropriate */
1410                then do;
1411                     do while (new_col - col >= 10);
1412                          call insert_tab;
1413                     end;
1414 
1415                     if mod (new_col, 10) < mod (col, 10)    /* room for another */
1416                     then call insert_tab;
1417                end;
1418 
1419                do col = col by 1 while (col < new_col);
1420                     call insert_char (space);               /* fill it up with spaces */
1421                end;
1422 
1423                return;
1424           end;
1425 
1426           if seqp -> seq.count > 1                          /* not simply backspace */
1427           then do i = 1 to count;
1428                call insert_sequence ("0"b);                 /* we will have to handle the column position our self */
1429                col = max (0, col - 1);                      /* and we will do it here for a back space */
1430           end;
1431 
1432           else do;                                          /* backspace itself, deal with delays */
1433                if delay_ptr = null
1434                then n_delays = 0;
1435                else n_delays = delay_ptr -> delay.backspace;
1436 
1437                bs_char = seqp -> seq.chars (1);
1438 
1439                if n_delays > 0                              /* normal delay timing */
1440                then do i = 1 to count;
1441                     call insert_delays (n_delays);
1442                     call insert_char (bs_char);
1443                end;
1444 
1445                else do;
1446                     if n_delays < 0                         /* this means timing for overstrike */
1447                     then if -n_delays > count               /* so multiple backspaces can count instead of delays */
1448                          then call insert_delays (-n_delays - count);
1449 
1450                     target_len = target_len + count;
1451                     if target_len > max_chars               /* we will blow the buffer */
1452                     then go to try_again;
1453 
1454                     do i = 1 to count;
1455                          target_ptr -> based_chars (i - 1) = bs_char;
1456                     end;
1457 
1458                     target_ptr = addr (target_ptr -> based_chars (count));
1459                end;
1460 
1461                col = col - count;                           /* we backed up */
1462           end;
1463 
1464           return;
1465 
1466      end /* insert_bs */;
1467 ^L
1468 insert_tab:
1469      proc;
1470 
1471 /* this procedure inserts a horizontal tab */
1472 
1473 dcl  i fixed bin;
1474 dcl  count fixed bin;
1475 
1476           count = 10 - mod (col, 10);
1477 
1478           if count = 1                                      /* no point putting in tab for one space */
1479           then call insert_char (space);
1480 
1481           else do;
1482                if tcb.modes.tabm & special_ptr -> special_chars.tab_seq.count > 0
1483                                                             /* tabs are real */
1484                then do;
1485                     call insert_char (tab);
1486                     if delay_ptr ^= null
1487                     then do;
1488                          n_delays =
1489                               delay_ptr -> delay.const_tab + fixed (delay_ptr -> delay.var_tab * float (count), 17, 0);
1490                          if n_delays > 0
1491                          then call insert_delays (n_delays);
1492                     end;
1493                end;
1494 
1495                else do;                                     /* must simulate with spaces */
1496                     target_len = target_len + count;
1497                     if target_len > max_chars
1498                     then go to try_again;                   /* we can't let this happen */
1499 
1500                     do i = 1 to count;
1501                          target_ptr -> based_chars (i - 1) = space;
1502                     end;
1503 
1504                     target_ptr = addr (target_ptr -> based_chars (count));
1505                end;
1506           end;
1507 
1508           col = col + count;
1509           return;
1510 
1511      end /* insert_tab */;
1512 ^L
1513 translation:
1514      proc;
1515 
1516 /* This procedure does a character translation of the output buffer using a move and translate operation */
1517 
1518           source_ptr, util.stringp = final_outp;            /* we'll start picking up where final stuff was left */
1519 
1520           if final_outp = addr (buffer_1)                   /* use the buffer not already occupied */
1521           then target_ptr = addr (buffer_2);
1522           else target_ptr = addr (buffer_1);
1523 
1524           util.stringl = target_len;
1525           util.tablep = mvtp;
1526           mvt_args.targetp = target_ptr;
1527           call tty_util_$mvt (addr (util));                 /* do the translation itself */
1528 
1529           final_outp = target_ptr;                          /* now */
1530 
1531           if shifter (wtcb.line_type)                       /* do we have to put in case shifts? */
1532           then do;
1533                source_ptr, util.stringp = target_ptr;       /* we'll have to move again, probably */
1534                xor = bool (rel (addr (buffer_1)), rel (addr (buffer_2)), "0110"b);
1535                                                             /* use to switch buffers */
1536                target_ptr, final_outp = ptr (target_ptr, bool (xor, rel (target_ptr), "0110"b));
1537 
1538                shift = "01"b;                               /* new write chain starts in lower also */
1539 
1540                scm_args.search_mask = bool (shift, "11"b, "0110"b);
1541                                                             /* look for opposite shift */
1542                call tty_util_$scm (addr (util));
1543 
1544                if ^scm_args.found_flag                      /* no shift changes at all */
1545                then final_outp = source_ptr;                /* we won't move anything */
1546                else do;
1547                     target_len = 0;
1548                     if ctally > 0                           /* move characters to left of found shift */
1549                     then call copy_chars;
1550 
1551                     do while (scm_args.found_flag);
1552                          if ctally = 0
1553                          then call insert_shift;
1554                          else do;
1555                               i = -1;                       /* necessary to fool compiler */
1556                               if target_ptr -> based_chars (i) ^= prefix
1557                               then call insert_shift;
1558 
1559                               else do;                      /* previous char was prefix, mustn't shift */
1560                                    call insert_char (source_ptr -> based_chars (0));
1561                                                             /* put unshifted char in */
1562                                    stringp, source_ptr = addr (source_ptr -> based_chars (1));
1563                                                             /* skip over it */
1564                                    stringl = stringl - 1;
1565                               end;
1566                          end;
1567 
1568                          call tty_util_$scm (addr (util));
1569                          if ctally > 0
1570                          then call copy_chars;              /* move any we scanned over */
1571                     end;
1572 
1573                     if shift = "10"b                        /* if we ended up in upper */
1574                     then call insert_char (byte (lower_shift));
1575                                                             /* change to lower */
1576                     tcb.actshift = "01"b;
1577                end;
1578           end;
1579 
1580           return;
1581 
1582      end translation;                                       /* end of translation phase */
1583 ^L
1584 insert_shift:
1585      proc;
1586 
1587 /*  This procedure inserts the proper shift character into the stream for an IBM 2741 like shift device */
1588 
1589           if shift = "01"b                                  /* we were in lower case */
1590           then call insert_char (byte (upper_shift));       /* put in upper shift */
1591           else call insert_char (byte (lower_shift));       /* or lower, as the case may be */
1592 
1593           scm_args.search_mask = shift;                     /* switch to look for other shift */
1594           shift = bool (shift, "11"b, "0110"b);
1595 
1596           return;
1597 
1598      end insert_shift;
1599 ^L
1600 convert_to_upper_case:
1601      proc;
1602 
1603 /*
1604    This procedure takes a string from buffer 1 and sets up the necessary variables
1605    and the translates the stream into uper case characters in buffer 2 using the
1606    move and translate operation.  The characters may either be edited
1607    or not. (i.e. true upper case has an escape before it or not)
1608 */
1609 
1610 
1611           target_ptr = addr (buffer_2);
1612           chars_moved = "0"b;
1613 
1614           if tcb.modes.edited
1615           then cap_tab_ptr = addr (lower_to_caps_edited);
1616           else cap_tab_ptr = addr (lower_to_caps_nonedited);
1617 
1618 /* we'll have to be careful to step over characters greater than 177 */
1619 
1620           cap_source_ptr, ic_stringp = source_ptr;
1621           cap_target_ptr = addr (buffer_1);
1622           ic_stringl = source_len;
1623           illegal_char_args.found_flag = "1"b;              /* so "while" will work at least once */
1624           scanned_len = 0;
1625 
1626           do while (illegal_char_args.found_flag & ic_stringl > 0);
1627                call tty_util_$illegal_char (addr (illegal_char_args));
1628                                                             /* look for funny character */
1629 
1630 /* now just scan the string up to the character found (if any) */
1631 
1632                if illegal_char_args.ic_tally > 0            /* if there's a string to scan */
1633                then do;
1634                     util.stringp = cap_source_ptr;
1635                     util.stringl = ic_tally;
1636                     util.tablep = cap_tab_ptr;
1637 
1638                     mvt_args.targetp = cap_target_ptr;
1639                     call tty_util_$mvt (addr (util));
1640 
1641                     if ^tcb.modes.edited
1642                     then do;                                /* in ^edited mode, must insert escapes */
1643                          source_ptr, util.stringp = cap_target_ptr;
1644                          scm_args.search_mask = "10"b;      /* look for chars with high-order bit on */
1645                          scm_args.found_flag = "1"b;        /* so "while" will work right */
1646 
1647                          do while (scm_args.found_flag);
1648                               call tty_util_$scm (addr (util));
1649                               if scm_args.found_flag        /* found a capital */
1650                               then do;
1651                                    if ^chars_moved          /* first time we've had to move any */
1652                                    then do;
1653                                         ctally = ctally + scanned_len;
1654                                                             /* take the ones we skipped before */
1655                                         source_ptr = addr (buffer_1);
1656                                                             /* have to pick up all chars so far */
1657                                    end;
1658 
1659                                    if ctally > 0
1660                                    then call copy_chars;    /* copy all chars left of it */
1661                                    call insert_char (escape_char);
1662 
1663                                    source_len = source_len + 1;
1664                                                             /* we've added a character to be scanned */
1665                                    chars_moved = "1"b;
1666                                    unspec (util.stringp -> based_onechar) =
1667                                         unspec (util.stringp -> based_onechar) & "011111111"b;
1668                                                             /* turn off high-order bit */
1669                               end;
1670 
1671                               else if chars_moved           /* we didn't find one, did we move any chars? */
1672                               then call copy_chars;         /* move the rest */
1673 
1674                          end;
1675                     end;                                    /* through looking for caps */
1676                end;
1677 
1678                if illegal_char_args.found_flag
1679                then do;                                     /* if we've had to stop for high-order bits at all */
1680 
1681                     if chars_moved                          /* we've had to copy for escapes */
1682                     then call insert_char (cap_source_ptr -> based_chars (ic_tally));
1683                                                             /* copy untouched funny char */
1684 
1685                     else cap_target_ptr -> based_chars (ic_tally) = cap_source_ptr -> based_chars (ic_tally);
1686 
1687                     scanned_len = scanned_len + ic_tally + 1;
1688 
1689 /* adjust pointers to start looking after it */
1690 
1691                     ic_stringp, cap_source_ptr = addr (cap_source_ptr -> based_chars (ic_tally + 1));
1692                     cap_target_ptr = addr (cap_target_ptr -> based_chars (ic_tally + 1));
1693                     ic_stringl = ic_stringl - 1;
1694                end;
1695           end;
1696 
1697           if chars_moved                                    /* have to adjust some pointers */
1698           then do;
1699                source_ptr = addr (buffer_2);                /* chars are in buffer_2 now */
1700                target_ptr = addr (buffer_1);
1701           end;
1702           else source_ptr = addr (buffer_1);                /* make sure this gets set */
1703 
1704           return;
1705 
1706      end convert_to_upper_case;
1707 ^L
1708 move_formated_chars:
1709      proc;
1710 
1711 /*
1712    This procedure is called to move chars to a different
1713    buffer when some reformating is necessary due to the encountering of some
1714    special characters in the present buffer
1715 */
1716 
1717 
1718           chars_moved = "1"b;                               /* we'll have to do some moving */
1719 
1720           if ctally > 0                                     /* we have some uninteresting ones to pick up */
1721           then do;
1722                if white_sw
1723                then call insert_white;                      /* pick up any outstanding white space */
1724                col = col + ctally;
1725                if tcb.dont_count_next                       /* first char doesn't count */
1726                then do;
1727                     col = col - 1;
1728                     tcb.dont_count_next = "0"b;
1729                end;
1730                if ((tcb.colmax > 0) & (col > tcb.colmax))
1731                then call wrap_lines;
1732                else do;                                     /* wrap_lines would this for us */
1733                     call copy_chars;
1734                     wcol = col;
1735                end;
1736           end;
1737 
1738           else if tcb.dont_count_next                       /* we're supposed to swallow first char whole */
1739           then do;
1740                ctally = 1;                                  /* get it */
1741                call copy_chars;
1742 
1743                if indicator = 3 | indicator = 7             /* we're still pointing at it */
1744                then do;
1745                     stringp = addr (stringp -> based_chars (1));
1746                                                             /* bump pointer */
1747                     stringl = stringl - 1;                  /* decrement length */
1748                end;
1749 
1750                indicator = NOT_INTERESTING;                 /* don't do anything else about this char */
1751           end;
1752 ^L
1753 /* now examine indicator */
1754 
1755           if indicator = NOT_INTERESTING                    /* no interesting characters */
1756           then if white_sw
1757                then call insert_white;                      /* add white space if necessary */
1758                else ;                                       /* otherwise go around again */
1759 
1760           else if indicator = NEW_LINE                      /* new-line */
1761           then do;
1762                white_sw = "0"b;                             /* throw away any outstanding white space */
1763                call insert_nl ("0"b);                       /* put the nl in */
1764           end;
1765 
1766           else if indicator = CARRIAGE_RETURN               /* carriage return */
1767           then do;
1768                white_sw = "1"b;                             /* we'll process this later as white space */
1769                wcol = 0;                                    /* taking us to column zero */
1770           end;
1771 
1772           else if indicator = TAB_MULTIPLE_SPACE            /* tab or multiple blanks */
1773           then call scan_white ("0"b);
1774 
1775           else if indicator = BACK_SPACE                    /* backspace */
1776           then do;
1777                wcol = max (0, wcol - 1);                    /* back up the "white" column */
1778                call scan_white ("1"b);
1779 
1780           end;
1781 ^L
1782           else if indicator = VERTICAL_TAB | indicator = FORM_FEED
1783                                                             /* vertical tab or form-feed */
1784           then if tcb.modes.vertsp                          /* if we're processing such */
1785                then do;
1786                     if indicator = VERTICAL_TAB             /* vertical tab */
1787                     then do;
1788                          if tcb.linemax > 0                 /* if we're counting lines */
1789                          then do;
1790                               line_count = line_count + 10 - mod (line_count, 10);
1791                                                             /* next vt stop */
1792                               if line_count >= tcb.linemax  /* over to new page */
1793                               then do;
1794                                    seqp = addr (special_ptr -> special_chars.end_of_page);
1795                                    call insert_sequence ("0"b);
1796                                                             /* mark end-of-page if necessary */
1797                                    call insert_char (eop_sentinel);
1798                                    line_count = 0;
1799                               end;
1800                          end;
1801                          seqp = addr (special_ptr -> special_chars.vt_seq);
1802                     end;
1803 
1804                     else do;                                /* else it is a form feed */
1805                          if tcb.linemax > 0
1806                          then do;                           /* if we care about page length */
1807                               seqp = addr (special_ptr -> special_chars.end_of_page);
1808                               call insert_sequence ("0"b);
1809                               call insert_char (eop_sentinel);
1810                          end;
1811                          line_count = 0;
1812                          seqp = addr (special_ptr -> special_chars.ff_seq);
1813                     end;
1814 
1815                     call insert_sequence ("0"b);
1816                     if delay_ptr ^= null
1817                     then call insert_delays (delay_ptr -> delay.vt_ff);
1818 
1819                     col = 0;                                /* implied new-line always */
1820                     white_sw = "0"b;
1821                end;
1822 
1823                else if ^tcb.modes.edited                    /* we'll have to escape it */
1824                then do;
1825                     i = -1;                                 /* so compiler won't complain */
1826                     stringp = addr (stringp -> based_chars (i));
1827                                                             /* back up by one */
1828                     stringl = stringl + 1;
1829                     call octal_escape;
1830                end;
1831                else ;
1832 
1833           else if indicator = OCTAL_ESCAPE                  /* octal escape */
1834           then call octal_escape;
1835 ^L
1836           else if indicator = RED_SHIFT | indicator = BLACK_SHIFT
1837                                                             /* ribbon shift */
1838           then if tcb.modes.redm                            /* if this is interesting */
1839                then do;
1840                     if white_sw
1841                     then call insert_white;                 /* if video terminal this is noticable */
1842                     if indicator = RED_SHIFT
1843                     then seqp = addr (special_ptr -> special_chars.red_ribbon_shift);
1844                     else seqp = addr (special_ptr -> special_chars.black_ribbon_shift);
1845 
1846                     call insert_sequence ("0"b);
1847                end;
1848                else ;
1849 
1850           else if indicator = INSERT_NO_COUNT               /* insert without counting column position */
1851           then do;
1852                if white_sw
1853                then call insert_white;
1854                ctally = 1;
1855                call copy_chars;
1856           end;
1857 
1858           else if indicator = INSERT_NO_COUNT_2             /* neither this char nor next one affects column position */
1859           then do;
1860                if white_sw
1861                then call insert_white;
1862                ctally = min (stringl + 1, 2);               /* copy this one and next (if present) */
1863                call copy_chars;
1864 
1865                if ctally = 2                                /* get them both */
1866                then do;
1867                     stringp = addr (stringp -> based_chars (1));
1868                                                             /* bump past escaped char */
1869                     stringl = stringl - 1;
1870                end;
1871 
1872                else tcb.dont_count_next = "1"b;             /* wasn't a next one, catch it next time */
1873           end;
1874 
1875           else if indicator = SKIP                          /* ignore this one entirely */
1876           then ;
1877 
1878           else if indicator > SPECIAL_ESCAPE
1879           then do;                                          /* special escape sequence */
1880                escape_index = indicator - 16;
1881                if escape_index > special_ptr -> special_chars.escape_length
1882                                                             /* not a good index */
1883                then go to table_error;
1884 
1885                if white_sw
1886                then call insert_white;
1887                if tcb.modes.edited
1888                then seqp = addr (special_ptr -> special_chars.edited_escapes (escape_index));
1889                else seqp = addr (special_ptr -> special_chars.not_edited_escapes (escape_index));
1890 
1891                call insert_sequence ("1"b);
1892           end;
1893 
1894           else go to table_error;                           /* invalid indicator */
1895 
1896           if stringl > 0                                    /* if we're going around again */
1897           then source_ptr = stringp;                        /* update source pointer */
1898 
1899           return;
1900 
1901      end move_formated_chars;
1902 ^L
1903 wrap_lines:
1904      proc;
1905 
1906 /*
1907    This procedure is called when the output line exceeds the maximum number
1908    of columns we think the device has
1909 */
1910 
1911           if tcb.colmax < 1
1912           then return;                                      /* we should not have come here */
1913           do while (col > tcb.colmax);                      /* did we go over end of line? */
1914                old_tally = ctally;
1915                ctally = max (0, tcb.colmax - oldcol);       /* move first chunk */
1916                if ctally > 0
1917                then call copy_chars;
1918                call insert_nl ("1"b);                       /* insert new-line and continuation marker */
1919 
1920                ctally = old_tally - ctally;
1921                oldcol = 2;
1922                col = col + ctally;
1923           end;
1924 
1925           if ctally > 0                                     /* any more chars to copy? */
1926           then call copy_chars;                             /* do it */
1927           wcol = col;                                       /* further white space will start here */
1928 
1929           return;
1930 
1931      end wrap_lines;
1932 
1933 
1934 scan_white:
1935      proc (advanced);
1936 
1937 /*
1938    This procedure is called when it is necessary to deside what to do with characters
1939    that only move the carriage's column position.  It then updates the appropriate
1940    pointers or white space counters
1941 */
1942 
1943 dcl  advanced bit (1) parameter;                            /* indicates whether pointer has been advanced over first white character */
1944 dcl  done bit (1);
1945 dcl  first_time bit (1);
1946 
1947           done = "0"b;
1948           first_time = "1"b;
1949           white_sw = "1"b;
1950           do while (util.stringl > 0 & ^done);
1951                if stringp -> based_onechar = backspace
1952                then wcol = max (0, wcol - 1);
1953 
1954                else if stringp -> based_onechar = space
1955                then wcol = wcol + 1;
1956 
1957                else if stringp -> based_onechar = tab
1958                then wcol = wcol + 10 - mod (wcol, 10);      /* to next tab stop */
1959 
1960                else if stringp -> based_onechar = carriage_return
1961                then wcol = 0;
1962 
1963                else done = "1"b;
1964 
1965                if ^done | (first_time & ^advanced)          /* in case first character wasn't really whitespace */
1966                then do;                                     /* we want to advance pointer anyway */
1967                     stringp = addr (stringp -> based_chars (1));
1968                                                             /* bump stringp by one char */
1969                     stringl = stringl - 1;
1970                     first_time = "0"b;
1971                end;
1972           end;
1973           return;
1974 
1975      end scan_white;
1976 ^L
1977 octal_escape:
1978      proc;
1979 
1980 /*
1981    This procedure is called when a character is encountered that is meaningless
1982    to the device, so it is printed in the form of escapeXXX (i.e. \014)
1983 */
1984           if ^tcb.modes.edited
1985           then do;
1986                if white_sw
1987                then call insert_white;                      /* insert any outstanding white space */
1988                if ((tcb.colmax > 0) & (col >= tcb.colmax))  /* in case we went off end of line */
1989                then call insert_nl ("1"b);
1990 
1991                call insert_char (escape_char);              /* put escape in */
1992                col = col + 1;
1993 
1994                do i = 1 to 9 by 3;
1995                     if ((tcb.colmax > 0) & (col >= tcb.colmax))
1996                                                             /* if we go off end of line */
1997                     then call insert_nl ("1"b);             /* put in nl and continuation marker */
1998 
1999                     call insert_char (num_array (fixed (substr (unspec (stringp -> based_onechar), i, 3), 3)));
2000                     col = col + 1;
2001                end;
2002           end;
2003 
2004           stringp = addr (stringp -> based_chars (1));      /* bump over escaped character */
2005           stringl = stringl - 1;
2006      end octal_escape;
2007 ^L
2008           end /* giant begin block */;
2009 
2010 all_done:
2011           a_nelemt = nelemt;                                /* return number of chars processed */
2012 
2013                                                             /* Add for the Datanet 7100. */
2014           if uncp_flag then do;
2015                if wtcb.send_turn
2016                     then do;
2017                     if ^wtcb.flags.wru                      /* if not reading answerback  */
2018                          then if wtcb.receive_mode_device   /* must we tell multiplexer to turn line around? */
2019                          then do;
2020                               call channel_manager$control (devx, "enter_receive", null, ercode);
2021                                                             /* yes, do it */
2022                               wtcb.send_turn = "0"b;
2023                          end;
2024                          else ;
2025                          else wtcb.flags.wru = "0"b;        /* won't be reading answerback again */
2026                end;
2027           end;
2028 
2029 unlock:
2030           time_spent = clock () - start_time;
2031           tcb.cumulative_meters.write_time = tcb.cumulative_meters.write_time + time_spent;
2032           tty_buf.write_time = tty_buf.write_time + time_spent;
2033           if ^locked_entry
2034           then call tty_lock$unlock_channel (devx);         /* unlock channel lock if necessary */
2035 
2036           return;
2037 
2038 nothing_written:
2039           if wtcb.send_output
2040           then call tty_space_man$needs_space (devx);       /* make sure space happens anyway */
2041           else wtcb.wflag = "1"b;
2042           ercode = 0;
2043           go to all_done;                                   /* exit */
2044 ^L
2045 free_buffers:
2046      proc;
2047 
2048 /* procedure to free any buffers we allocated but can't use */
2049 
2050           if headp ^= null                                  /* we'd peeled off a page */
2051           then do;                                          /* Add for the Datanet 7100. */
2052                if uncp_flag then wtcb.send_turn = lastp -> buffer.turn;
2053                call tty_space_man$free_chain (devx, OUTPUT, headp);
2054           end;
2055           if new_head ^= 0
2056           then call tty_space_man$free_chain (devx, OUTPUT, ptr (ttybp, new_head));
2057 
2058           wtcb.end_frame = old_end_frame;
2059           wtcb.write_first = old_head;                      /* back to how we were when we came in */
2060           wtcb.write_last = old_tail;
2061           if wtcb.write_last ^= 0
2062           then ptr (ttybp, wtcb.write_last) -> buffer.next = 0;
2063 
2064           return;
2065      end /* free_buffers */;
2066 
2067 
2068 is_parent_mpx:                                              /* Check for match of channel's parent mpx type and input mpx type */
2069      proc (parent_mpx_type) returns (bit (1));
2070 
2071 dcl parent_mpx_type fixed bin;
2072 dcl temp_lctep ptr;
2073 
2074           lctep = addr (lct.lcte_array (devx));
2075           if lcte.major_channel_devx ^= 0 then do;
2076                temp_lctep = addr (lct.lcte_array (lcte.major_channel_devx));
2077                if temp_lctep->lcte.channel_type = parent_mpx_type then return ("1"b);
2078           end;
2079           else if lcte.channel_type = parent_mpx_type then return ("1"b);
2080           return ("0"b);
2081      end is_parent_mpx;
2082 
2083      end /* tty_write */;