1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Bull Inc., 1987                *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   6         *                                                         *
   7         *********************************************************** */
   8 
   9 
  10 
  11 /****^  HISTORY COMMENTS:
  12   1) change(81-06-01,Margulies), approve(), audit(), install():
  13      There is a temporary crock in place here, for handling
  14      error_table_$bigarg returned from hcs_$tty_write_whole_string. See the
  15      call to it for details IT MUST BE REMOVED when hardcore is fixed.
  16   2) change(82-05-01,York), approve(), audit(), install():
  17      There is another temporary crock in the insert_text procedure, relating
  18      to the two different types of insert-char sequences supported by various
  19      terminals.  See the comment in place for more Info.
  20 
  21      Change the pad character from DEL to NUL (or high to low for you PL/I
  22      builtin fans).  This fixes padding problems with the Heath/Zenith-19,
  23      but probably breaks some other terminal...
  24   3) change(82-05-01,York), approve(), audit(), install():
  25      Initialize cost_of_cha_cha in the position_cursor optimzation routine,
  26      avoiding weird usuless motion.
  27   4) change(82-07-16,York), approve(), audit(), install():
  28      Position the cursor correctly and send the correct output to the terminal
  29      when simulating insert-chars on terminals lacking the capability.
  30   5) change(82-07-16,York), approve(), audit(), install():
  31      Insert a crock in insert_text to keep the screen image updated when
  32      doing insert-chars operations on the Teleray 1061 and related terminals.
  33   6) change(82-07-16,York), approve(), audit(), install():
  34      Fix the delete_chars routine so that it does not try to do an actual
  35      delete_chars terminal operation on terminals that don't have it.
  36   7) change(82-07-30,York), approve(), audit(), install():
  37      Buffer all output to the terminal generated by one call to tc_request
  38      and send it in one call to hcs_
  39   8) change(82-08-12,York), approve(), audit(), install():
  40      Extend this buffering to work across calls to tc_request, and only send
  41      to ring 0 when the buffer fills or an input request is received.
  42   9) change(82-08-30,York), approve(), audit(), install():
  43      Dump the output buffer before raw output is sent to ring 0 and before
  44      input is re-echoed, and to send raw output via tty_write_whole_string.
  45  10) change(82-09-10,York), approve(), audit(), install():
  46      Add the send_buffered_output entrypoint as an external interface to
  47      write_global_buffer.  This is used by the send_buffered_output control
  48      order.
  49  11) change(82-09-20,York), approve(), audit(), install():
  50      Remove the send_buffered_output entrypoint, since a call to
  51      window_$sync does the right thing. Also changed to pass
  52      tc_input$check_echnego the request_ptr as an argument.
  53  12) change(83-01-01,York), approve(), audit(), install():
  54      Not position the cursor on calls that don't modify the screen
  55      (e.g. unechoed reads).
  56  13) change(83-09-07,Rochlis), approve(), audit(), install():
  57      Remove  the special casing of error_table_$bigarg in the
  58      hcs_$tty_write_whole_string call. Now we will get a wakeup and bigarg
  59      means  we really have problems.
  60  14) change(83-10-09,Rochlis), approve(), audit(), install():
  61      Support partial screen width windows.
  62  15) change(85-09-14,Rochlis), approve(86-05-15,MCR7276),
  63      audit(86-05-28,Gilcrease), install(86-06-04,MR12.0-1070):
  64      Fix unitialized variable bug in position cursor.  Goodbye to the insert
  65      mode bug, thanks to Allen Grider.
  66  16) change(86-05-21,LJAdams), approve(86-05-27,MCR7428),
  67      audit(86-05-28,Gilcrease), install(86-06-04,MR12.0-1070):
  68      The "encode" procedure has an alignment problem.  value is declared as
  69      fixed bin which equates to 36 bits;  bits is declared as (6) bit (3)
  70      unaligned which equates to 18 bits.  When an unspec (value) = unspec
  71      (bits) is done a stringsize condition occurs and only the upper half of
  72      the word was being stored.  Solution change the declaration of bits to:
  73      dcl bits (-5:6) bit (3) unaligned.
  74  17) change(86-11-11,LJAdams), approve(86-11-11,MCR7485),
  75      audit(86-12-16,Margolin), install(87-01-06,MR12.0-1255):
  76      Modified to support MOWSE.
  77  18) change(86-11-26,LJAdams), approve(86-11-26,MCR7584),
  78      audit(86-12-16,Margolin), install(87-01-06,MR12.0-1255):
  79      Initial DSA coding has been maintained in a non-executable form.
  80                                                    END HISTORY COMMENTS */
  81 
  82 /* Terminal Control
  83    Request Processing level
  84 
  85    This program is the interpreter of terminal operations.
  86    For input side (save read status) we position the cursor, and pass
  87    the batton to tc_input. All else is done here, including the grokking
  88    of the ttt video tables. */
  89 
  90 /* format: style2,linecom,^indnoniterdo,indcomtxt,^inditerdo,dclind5,idind25 */
  91 
  92 tc_request:
  93      procedure (TC_data_ptr, Request_ptr, Last_column, Code);
  94           go to do_output;
  95 
  96           declare (
  97                   (TC_data_ptr, Request_ptr)
  98                                            pointer,
  99                   Last_column              fixed bin,
 100                   Code                     fixed bin (35)
 101                   )                        parameter;
 102 
 103 
 104           declare hcs_$tty_write_whole_string
 105                                            entry (fixed bin, character (*), bit (1) aligned, fixed bin (21), fixed bin,
 106                                            fixed bin (35));
 107           declare hcs_$tty_write           entry (fixed bin, pointer, fixed bin (21), fixed bin (21), fixed bin (21),
 108                                            fixed bin, fixed bin (35));
 109           declare ws_tty_$write_whole_string
 110                                            entry (ptr, char (*), bit (1), fixed bin (21), fixed bin, fixed bin (35));
 111           declare ws_tty_$write            entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin,
 112                                            fixed bin (35));
 113           declare dsa_tty_$write_whole_string
 114                                            entry (fixed bin (35), character (*), bit (1) aligned, fixed bin (21),
 115                                            fixed bin, fixed bin (35));
 116           declare dsa_tty_$write           entry (fixed bin (35), pointer, fixed bin (21), fixed bin (21), fixed bin (21),
 117                                            fixed bin, fixed bin (35));
 118 
 119           declare tc_screen$operation      entry (pointer, fixed bin, fixed bin, fixed bin, fixed bin);
 120           declare tc_screen$get_in_line    entry (pointer, fixed bin, fixed bin, character (*));
 121           declare tc_screen$text           entry (pointer, fixed bin, fixed bin, bit (1) aligned, character (*));
 122           declare tc_screen$is_region_clear
 123                                            entry (pointer, fixed binary, fixed binary, fixed binary, fixed binary)
 124                                            returns (bit (1) aligned);
 125 
 126           declare tc_input                 entry (pointer, pointer, fixed bin (35));
 127           declare tc_disconnect$check      entry (pointer, fixed bin (35));
 128           declare tc_input$check_echnego   entry (pointer, pointer);
 129           declare tc_error                 entry (fixed binary (35), character (*));
 130           declare tc_block                 entry (pointer, pointer, bit (36) aligned);
 131 
 132           declare (
 133                   video_et_$capability_lacking,
 134                   video_et_$tc_illegal_request,
 135                   video_et_$tc_cannot_position,
 136                   video_et_$tc_missing_operation,
 137                   video_et_$tc_tty_error
 138                   )                        fixed bin (35) ext static;
 139 
 140           declare OMEGA                    fixed bin init (100000) internal static options (constant);
 141                                                             /* compiler limitation of 256 chars, should be bigger. */
 142           declare MANY_SPACES              char (256) static options (constant) init ("");
 143 
 144           declare last_column              fixed bin;
 145           declare (request_row, request_col)
 146                                            fixed bin;
 147           declare request_row_count        fixed bin;
 148           declare request_column_count     fixed bin;
 149           declare request_string_ptr       pointer;
 150           declare request_string_length    fixed bin (21);
 151           declare request_count            fixed bin;
 152           declare tty_state                fixed bin;
 153           declare save_row                 character (200); /* pretty big terminal */
 154           declare code                     fixed bin (35);
 155 
 156           declare (addr, bin, byte, divide, hbound, lbound, length, min, rank, rtrim, substr, unspec, verify)
 157                                            builtin;
 158 
 159           declare 1 new_state              aligned based,
 160                     2 pay_attention        aligned,         /* use these to see those below */
 161                       3 insert             bit (1) unaligned,
 162                                                             /* flags.insert_mode is useful */
 163                       3 cursor             bit (1) unaligned,
 164                                                             /* flags.cursor_valid */
 165                       3 position           bit (1) unaligned,
 166                                                             /* cursor_position */
 167                     2 flags                aligned,
 168                       3 insert_mode        bit (1) unaligned,
 169                       3 cursor_valid       bit (1) unaligned,
 170                     2 cursor_position      aligned,
 171                       3 row                fixed bin,
 172                       3 col                fixed bin;
 173 ^L
 174 init:
 175      entry (TC_data_ptr);
 176 
 177           tc_data_ptr = TC_data_ptr;
 178           state.pending.count = 0;
 179           state.cursor_valid = "0"b;
 180           state.current_mark = 0;
 181           state.last_mark_back = 0;
 182           tc_data.global_buffer_index = 0;                  /* the buffer length should be based on line speed or something */
 183                                                             /* this won't be so important after tty_write_whole_string is
 184                                                                changed to send a wakeup when space is available. */
 185           tc_data.global_buffer_limit = 256;
 186           return;
 187 
 188 shut:
 189      entry (TC_data_ptr, Code);
 190 
 191 /* Since we are usually in tc_request on behalf of some window, we need
 192    a fabricated window operation structure for tc_block to play with. */
 193 
 194 /*
 195    The following code commented out since it breaks reconnection.
 196    Fix it to not cause the terminal_control_disconnection_ signal if
 197    we are shutting.  Removed for 10.1 installation deadline.
 198 
 199    dcl  1 dummy_request_header          aligned like request_header;
 200 
 201    Code = 0;
 202    tc_data_ptr = TC_data_ptr;
 203    request_ptr = addr (dummy_request_header);
 204 
 205    dummy_request_header.sentinel = REQUEST_SENTINEL;
 206    dummy_request_header.request_id = 0;
 207    dummy_request_header.window_id = ""b;
 208    dummy_request_header.operation = 5;
 209 
 210    call write_global_buffer ();
 211 */
 212           return;
 213 
 214 /* ASSERT: this entrypoint is called MASKED!! */
 215 
 216 do_output:
 217           tc_data_ptr = TC_data_ptr;
 218           request_ptr = Request_ptr;
 219           last_column = Last_column;
 220           ttyvtblp = tc_data.ttt_video_ptr;
 221 
 222           request_header.async_interruption, request_header.this_window = "0"b;
 223 
 224 /* The following test is performed to avoid unnecessary external
 225    calls to tc_input for each output operation.  Modularity has been
 226    sacrificed in the name of efficiency. */
 227 
 228           if state.echnego_outstanding | (state.pending.count > 0)
 229           then call tc_input$check_echnego (tc_data_ptr, request_ptr);
 230 
 231           if tc_data.pending.count > 0
 232           then begin;                                       /* Note window hits */
 233                     declare wx                       fixed bin;
 234                     do wx = 1 to tc_data.pending.count;
 235                          if request_header.window_id = tc_data.state.pending.blocked_windows (wx)
 236                          then state_async_same_window (wx) = "1"b;
 237                     end;
 238                end;
 239 
 240           tc_data.change_pclock = tc_data.change_pclock + 1;
 241 
 242           if request_header.operation < lbound (REQUEST, 1) | request_header.operation > hbound (REQUEST, 1)
 243           then do;
 244 REQUEST (5):
 245                call tc_error (video_et_$tc_illegal_request, "");
 246                go to request_done;
 247           end;
 248 
 249 /* Come Here if something happened while we blocked and
 250    we have to try again */
 251 
 252 
 253 recompute_operation_here:                                   /* Make automatic copies of coords for faster procedure calls.
 254                                                                This means that any routine that wants to set the coord values
 255                                                                had better be called with request_header.row and .col, not
 256                                                                the copies. */
 257           request_row = request_header.row;
 258           request_col = request_header.col;
 259 
 260           go to REQUEST (request_header.operation);
 261 
 262 /* We should check for insert-mode on certain echoed-input calls,
 263    but that will be a limitation for now */
 264 REQUEST (9):                                                /* GET CHARS */
 265           call position_cursor (request_row, request_col);
 266 
 267 /* Don't position the cursor for calls that will not echo.  This makes
 268    "raw" input work way back up at the iox_ level. */
 269 REQUEST (16):                                               /* READ_ONE */
 270 REQUEST (10):                                               /* GET CHARS NO ECHO */
 271 REQUEST (13):                                               /* READ STATUS */
 272           call write_global_buffer;                         /* Must do this before input */
 273           call tc_input (tc_data_ptr, request_ptr, code);   /* do input req */
 274           go to request_done;
 275 
 276 
 277 REQUEST (11):                                               /* WRITE SYNC READ */
 278           request_string_ptr = request_read.prompt_ptr;
 279           request_string_length = request_read.prompt_length;
 280 
 281           call overwrite_text (request_row, request_col, request_string_ptr, request_string_length);
 282 
 283           call write_global_buffer;                         /* must dump output before input */
 284           call tc_input (tc_data_ptr, request_ptr, code);
 285 
 286           go to request_done;
 287 REQUEST (1):                                                /* POSITION CURSOR */
 288           call position_cursor (request_row, request_col);
 289           go to request_done;
 290 
 291 
 292 REQUEST (2):                                                /* CLEAR REGION */
 293           request_row_count = request_clear_region.rows;
 294           request_column_count = request_clear_region.columns;
 295 
 296           call clear_region (request_row, request_col, request_row_count, request_column_count);
 297           go to request_done;
 298 
 299 REQUEST (4):                                                /* CLEAR SCREEN NO OPT */
 300           call clear_screen;
 301           go to request_done;
 302 
 303 REQUEST (3):                                                /* INSERT_TEXT */
 304           request_string_ptr = request_text.text_ptr;
 305           request_string_length = request_text.text_length;
 306 
 307           call insert_text (request_row, request_col, request_string_ptr, request_string_length, last_column);
 308           go to request_done;
 309 
 310 REQUEST (14):                                               /* OVERWRITE_TEXT */
 311           request_string_ptr = request_text.text_ptr;
 312           request_string_length = request_text.text_length;
 313 
 314           call overwrite_text (request_row, request_col, request_string_ptr, request_string_length);
 315           go to request_done;
 316 
 317 REQUEST (15):                                               /* RAW TEXT */
 318           call write_raw_text (request_row, request_col, request_text_string);
 319           go to request_done;
 320 
 321 REQUEST (6):                                                /* DELETE CHARS */
 322           call delete_chars (request_row, request_col, request_delete_chars.count, last_column);
 323           go to request_done;
 324 
 325 REQUEST (7):                                                /* SCROLL REGION */
 326           request_row = request_scroll_region.start_line;
 327           request_row_count = request_scroll_region.n_lines;
 328           request_count = request_scroll_region.distance;
 329 
 330           call scroll_region (request_scroll_region.start_line, request_scroll_region.n_lines,
 331                request_scroll_region.distance);
 332           go to request_done;
 333 
 334 REQUEST (8):                                                /* BELL */
 335           call bell (request_row, request_col);
 336           go to request_done;
 337 
 338 REQUEST (12):                                               /* GET POSITION */
 339           request_header.row = state.row;
 340           request_header.col = state.col;                   /* output */
 341           go to request_done;
 342 ^L
 343 
 344 /* Here begins the hard work */
 345 
 346 position_cursor:
 347      procedure (a_row, a_col);
 348 
 349           declare (a_row, a_col)           fixed bin;
 350 
 351           declare (row, col)               fixed bin;
 352           declare (least_cost, cost_of_abs, cost_of_home, cost_of_cha_cha, cost_of_home_cha_cha)
 353                                            fixed bin;
 354           declare 1 ns                     aligned like new_state;
 355 
 356 /* Put the cursor THERE, in absolute screen coords */
 357 
 358           row = a_row;
 359           col = a_col;
 360 
 361           unspec (ns) = ""b;
 362 
 363           if state.cursor_valid
 364           then if state.cursor_position.row = row
 365                then if state.cursor_position.col = col
 366                     then return;
 367 
 368 /* Perhaps we are heading for home? */
 369 /* DUMP ASSUMPTION: HOME is cheaper than anything else. Boy do we need
 370    an expense metric. Perhaps weights in the ttt? */
 371 
 372           ns.pay_attention.position, ns.pay_attention.cursor = "1"b;
 373           ns.row = row;
 374           ns.col = col;
 375           ns.cursor_valid = "1"b;
 376 
 377           if (row = 1) & (col = 1) & available (HOME)
 378           then do;                                          /* Lassie come ... */
 379                call do_operation (HOME, 1, 1, 1, ns);
 380                return;
 381           end;
 382 
 383 /* What follows is a fair, and no better, chooser of method to do
 384    an arbitrary position. The faster the terminal, the less important
 385    it is to get the least characters. Instead, CPU time should be
 386    held down. This approach is middling for both costs */
 387 
 388 
 389 /* ASSUME: we can at least do cha-cha (up down right left) or abs pos */
 390 
 391 
 392           cost_of_abs = cost (ABS_POS);                     /* n characters */
 393           cost_of_home = cost (HOME);                       /* OMEGA if not available  */
 394 
 395           cost_of_cha_cha = OMEGA;                          /* don't want to do this if we can avoid it */
 396 
 397           cost_of_home_cha_cha = cost_of_home + cost_repeat (CURSOR_DOWN, row - 1) + cost_repeat (CURSOR_RIGHT, col - 1);
 398 
 399           if state.cursor_valid
 400           then do;                                          /* we can only compute a real cha-cha cost if the cursor is valid */
 401                cost_of_cha_cha = 0;
 402                if row > state.row
 403                then cost_of_cha_cha = cost_of_cha_cha + cost_repeat (CURSOR_DOWN, (row - state.row));
 404                else if row < state.row
 405                then cost_of_cha_cha = cost_of_cha_cha + cost_repeat (CURSOR_UP, (state.row - row));
 406 
 407 
 408                if col > state.col
 409                then cost_of_cha_cha = cost_of_cha_cha + cost_repeat (CURSOR_RIGHT, (col - state.col));
 410                else if col < state.col
 411                then cost_of_cha_cha = cost_of_cha_cha + cost_repeat (CURSOR_LEFT, (state.col - col));
 412           end;
 413 
 414 /* cost of cha cha is less than OMEGA iff the required functions were there */
 415 
 416           least_cost = min (cost_of_abs, cost_of_cha_cha, cost_of_home_cha_cha);
 417           if least_cost >= OMEGA
 418           then call tc_error (video_et_$tc_cannot_position, "");
 419 
 420           if cost_of_abs = least_cost
 421           then call do_operation (ABS_POS, row, col, (1), ns);
 422                                                             /* ns is already correct for atomic position call */
 423 
 424           else if cost_of_home_cha_cha = least_cost
 425           then do;
 426                ns.row, ns.col = 1;                          /* state reflects home call */
 427                call do_operation (HOME, 1, 1, (1), ns);
 428                if row > 1
 429                then do;
 430                     ns.row = row;                           /* now we do just the row */
 431                     call do_operation (CURSOR_DOWN, (0), (0), row - 1, ns);
 432                end;
 433                if col > 1
 434                then do;
 435                     ns.col = col;                           /* and the col here ... ns.row is correct */
 436                     call do_operation (CURSOR_RIGHT, (0), (0), col - 1, ns);
 437                end;
 438           end;
 439 
 440           else do;                                          /* cha-cha from current cursor position */
 441                ns.cursor_position = state.cursor_position;  /* wherever we are */
 442                if row > state.row
 443                then do;
 444                     ns.row = row;                           /* twiddle row */
 445                     call do_operation (CURSOR_DOWN, (0), (0), row - state.row, ns);
 446                end;
 447                else if row < state.row
 448                then do;
 449                     ns.row = row;
 450                     call do_operation (CURSOR_UP, (0), (0), state.row - row, ns);
 451                end;
 452                if col > state.col
 453                then do;
 454                     ns.col = col;
 455                     call do_operation (CURSOR_RIGHT, (0), (0), col - state.col, ns);
 456                end;
 457                else if state.col > col
 458                then do;
 459                     ns.col = col;
 460                     call do_operation (CURSOR_LEFT, (0), (0), state.col - col, ns);
 461                end;
 462           end;
 463      end position_cursor;
 464 ^L
 465 
 466 clear_screen:
 467      procedure;
 468           call clear_region_noopt (1, 1, tc_data.terminal.rows, tc_data.terminal.columns);
 469      end clear_screen;
 470 
 471 clear_region:
 472      procedure (a_row, a_col, a_n_rows, a_n_cols);
 473           declare (a_row, a_col, a_n_rows, a_n_cols)
 474                                            fixed bin;
 475           declare (row, col, n_rows, n_cols)
 476                                            fixed bin;
 477           declare i                        fixed bin;
 478           declare 1 ns                     aligned like new_state;
 479           declare noopt                    bit (1) aligned;
 480 
 481           noopt = "0"b;
 482           go to opt_common;
 483 
 484 clear_region_noopt:
 485      entry (a_row, a_col, a_n_rows, a_n_cols);
 486           noopt = "1"b;
 487 
 488 opt_common:
 489           unspec (ns) = ""b;                                /* hopefully, we do nuthin */
 490 
 491 /* copy for call efficiency */
 492           row = a_row;
 493           col = a_col;
 494           n_rows = a_n_rows;
 495           n_cols = a_n_cols;
 496 
 497 /* anything to clear? */
 498           if n_cols = 0
 499           then do;
 500                call position_cursor (row, col);
 501                return;
 502           end;
 503 
 504 /* Check for whole screen case. */
 505           if row = 1 & col = 1 & n_rows = tc_data.rows & n_cols = tc_data.columns
 506           then if available (CLEAR_SCREEN)
 507                then do;
 508                     call do_operation (CLEAR_SCREEN, (0), (0), (1), ns);
 509                     return;
 510                end;
 511 
 512 /* Check to see if the whole region is already clear. */
 513           if ^noopt & tc_screen$is_region_clear (tc_data.screen_data_ptr, row, col, n_rows, n_cols)
 514           then return;
 515 
 516           if (-1 + row + n_rows = tc_data.rows)             /* all the rows from here */
 517                & (col = 1)                                  /* starting in first col */
 518                & (n_cols = tc_data.columns)                 /* full width */
 519           then do;                                          /* EOS */
 520                if available (CLEAR_TO_EOS)
 521                then do;
 522                     call position_cursor (row, col);        /* hacks state */
 523                     call do_operation (CLEAR_TO_EOS, (0), (0), (1), ns);
 524                     call position_cursor (row, col);
 525                     return;
 526                end;
 527           end;
 528 
 529           if (-1 + col + n_cols = tc_data.columns)          /* Full width */
 530                & available (CLEAR_TO_EOL)
 531           then do;                                          /* CLEOL assumed better than delete-lines, insert lines */
 532 
 533 
 534                do i = row to row + n_rows - 1;
 535                     if noopt | ^tc_screen$is_region_clear (tc_data.screen_data_ptr, i, col, 1, n_cols)
 536                     then do;
 537                          call position_cursor (i, col);
 538                          call do_operation (CLEAR_TO_EOL, (0), (0), (1), ns);
 539                     end;
 540                end;
 541                call position_cursor (row, col);
 542                return;
 543           end;
 544 
 545 /* But if we cant tell easily that CLEOL is correct, we prefer
 546    i-del-lines */
 547 
 548           if col = 1 & n_cols = tc_data.columns & available (DELETE_LINES) & available (INSERT_LINES)
 549           then do;
 550                call position_cursor (row, 1);
 551                call do_operation (DELETE_LINES, (0), (0), n_rows, ns);
 552                if -1 + row + n_rows < tc_data.rows
 553                then do;
 554                     call do_operation (INSERT_LINES, (0), (0), n_rows, ns);
 555                     call position_cursor (row, col);
 556                end;
 557                return;
 558           end;
 559 
 560 
 561 /* This is still pretty primitive. I/DEL chars might be
 562    faster sometimes */
 563 
 564           begin;
 565                declare n_after                  fixed bin;
 566                declare first_after              fixed bin;
 567                declare have_cleol               bit (1) aligned;
 568 
 569                have_cleol = available (CLEAR_TO_EOL);
 570                first_after = col + n_cols;
 571                n_after = tc_data.columns - (first_after - 1);
 572 
 573                do i = row to -1 + row + n_rows;
 574                     if noopt | ^tc_screen$is_region_clear (tc_data.screen_data_ptr, i, col, 1, n_cols)
 575                     then do;
 576                          if have_cleol
 577                               & (noopt | tc_screen$is_region_clear (tc_data.screen_data_ptr, i, first_after, 1, n_after))
 578                          then do;
 579                               call position_cursor (i, col);
 580                               call do_operation (CLEAR_TO_EOL, (0), (0), (1), ns);
 581                          end;
 582                          else do;
 583                               call position_cursor (i, col);/* erase only as many chars as necessary */
 584                               if have_cleol & n_after + cost (CLEAR_TO_EOL) < n_cols
 585                                                             /* cheaper to CEOL and repaint stuff to the right? */
 586                               then do;                      /* CEOL and repaint */
 587                                    call tc_screen$get_in_line (tc_data.screen_data_ptr, i, first_after, save_row);
 588                                    call do_operation (CLEAR_TO_EOL, (0), (0), (1), ns);
 589                                    call position_cursor (i, first_after);
 590                                    call write_text (i, first_after, addr (save_row), length (rtrim (save_row)));
 591                               end;
 592                               else do;                      /* erase with spaces and leave other windows to the right alone */
 593                                    call tc_screen$get_in_line (tc_data.screen_data_ptr, i, col, save_row);
 594                                    call write_text (i, col, addr (MANY_SPACES),
 595                                         length (rtrim (substr (save_row, 1, n_cols))));
 596                                                             /* write as few spaces as possible */
 597                               end;
 598                          end;
 599                     end;
 600                end;
 601           end;
 602           call position_cursor (row, col);
 603      end clear_region;
 604 ^L
 605 
 606 insert_text:
 607      procedure (a_row, a_col, text_ptr, text_length, last_column);
 608 
 609           declare (a_row, a_col, last_column)
 610                                            fixed bin;
 611 
 612           declare (row, col)               fixed bin;
 613           declare text_ptr                 pointer;
 614           declare text_length              fixed bin (21);
 615           declare overwrite                bit (1);
 616           declare 1 ns                     aligned like new_state;
 617           declare clear_start              fixed bin;
 618 
 619           overwrite = "0"b;
 620           go to common;
 621 
 622 overwrite_text:
 623      entry (a_row, a_col, text_ptr, text_length);
 624 
 625           overwrite = "1"b;
 626 
 627 common:
 628           unspec (ns) = ""b;
 629 
 630           row = a_row;
 631           col = a_col;
 632 
 633           if overwrite
 634           then if state.insert_mode                         /* could only happen if END avail */
 635                then do;
 636                     ns.pay_attention.insert = "1"b;
 637                     ns.insert_mode = "0"b;
 638                     call do_operation (END_INSERT_CHARS, (0), (0), (1), ns);
 639                     unspec (ns) = ""b;
 640                end;
 641                else ;
 642           else do;                                          /* request to insert */
 643                if available (END_INSERT_CHARS) & tc_data.columns = last_column
 644                then if ^state.insert_mode
 645                     then do;
 646                          ns.pay_attention.insert = "1"b;
 647                          ns.insert_mode = "1"b;
 648                          call do_operation (INSERT_CHARS, (0), (0), (1), ns);
 649                          unspec (ns) = ""b;
 650                     end;
 651                     else ;
 652                else do;                                     /* At this point we know that the terminal does not have
 653                                                                an insert-character mode.  It may have an "open up
 654                                                                some space" insert chars operation, a la the Teleray
 655                                                                1061. If so, we have to call do_operation with the
 656                                                                INSERT_CHARS op to get the sequences to the terminal,
 657                                                                and then we have to call tc_screen again to update the
 658                                                                screen image, since it knows that the INSERT_CHARS op
 659                                                                doesn't change the screen on terminals with an insert
 660                                                                char mode.  The two different types of INSERT_CHARS
 661                                                                should have been made two different ops when the TTF
 662                                                                video stuff was set up, and should be split when the
 663                                                                TTF is upgraded (MR 10.2?).  -WMY 7/16/82. */
 664 
 665                     if available (INSERT_CHARS) & tc_data.columns = last_column
 666                     then do;
 667                          call do_operation (INSERT_CHARS, (0), (0), (text_length), ns);
 668                                                             /* assume no cursor motion */
 669                          begin;
 670                               dcl  some_spaces              char (text_length) defined (MANY_SPACES) position (1);
 671                               call tc_screen$text (tc_data.screen_data_ptr, row, col, "1"b /* fake insert mode */,
 672                                    some_spaces);
 673                          end;
 674                     end;
 675                     else do;                                /* we get here if the terminal doesn't have i-chars
 676                                                                or if we aren't the rightmost window */
 677                                                             /* we have no real insert chars operation, so
 678                                                                we have to replay the part of the line past
 679                                                                the inserted text, so get it from the screen image */
 680                          call tc_screen$get_in_line (tc_data.screen_data_ptr, row, col, save_row);
 681                          call position_cursor (row, col);
 682                          call write_text (row, col, text_ptr, text_length);
 683 
 684 /* shorten to fit in what's left of the line. */
 685                          save_row = substr (save_row, 1, last_column - (col + text_length) + 1);
 686 
 687 /* now strip any trailing whitespace from this new
 688    string and write it. */
 689 
 690                          call write_text (row, col + text_length, addr (save_row), length (rtrim (save_row)));
 691                                                             /* now clear the rest of the line */
 692                          clear_start = col + text_length + length (rtrim (save_row));
 693                          call clear_region (row, clear_start, 1, last_column - clear_start + 1);
 694                          call position_cursor (row, col + text_length);
 695                          return;
 696                     end;
 697                end;
 698           end;
 699 
 700           call position_cursor (row, col);
 701           call write_text (row, col, text_ptr, text_length);
 702      end insert_text;
 703 ^L
 704 
 705 delete_chars:
 706      procedure (a_row, a_col, a_count, last_column);
 707 
 708           declare (a_row, a_col, a_count, last_column)
 709                                            fixed bin;
 710 
 711           declare (row, col, count)        fixed bin;
 712           declare 1 ns                     aligned like new_state;
 713           declare clear_start              fixed bin;
 714           declare write_length             fixed bin (21);
 715 
 716           unspec (ns) = ""b;
 717 
 718           row = a_row;
 719           col = a_col;
 720           count = a_count;
 721 
 722           call position_cursor (row, col);
 723           if available (DELETE_CHARS) & last_column = tc_data.columns
 724           then call do_operation (DELETE_CHARS, (0), (0), count, ns);
 725           else do;                                          /* nasty simulation */
 726                call tc_screen$get_in_line (tc_data.screen_data_ptr, row, col + count, save_row);
 727 
 728                write_length = length (rtrim (substr (save_row, 1, last_column - col - count + 1)));
 729                                                             /* be sure not to write in the next window */
 730                call write_text (row, col, addr (save_row), write_length);
 731 
 732 /* now clear the rest of the line. this should help with
 733    whitespace optomization. */
 734                clear_start = col + write_length;
 735                call clear_region (row, clear_start, 1, last_column - clear_start + 1);
 736                call position_cursor (row, col);
 737           end;
 738 
 739      end delete_chars;
 740 ^L
 741 
 742 scroll_region:
 743      procedure (a_row, n_rows, a_distance);
 744 
 745           declare (a_row, n_rows, a_distance)
 746                                            fixed bin;
 747 
 748           declare (row, distance)          fixed bin;
 749 
 750           declare save_row                 fixed bin;
 751           declare save_col                 fixed bin;
 752 
 753           declare 1 ns                     aligned like new_state;
 754 
 755           if ^(available (INSERT_LINES) & available (DELETE_LINES))
 756           then go to capabilities_lacking;                  /* too hard to simulate */
 757 
 758           row = a_row;
 759           distance = a_distance;
 760 
 761           if distance = 0
 762           then return;                                      /* ??? */
 763 
 764           unspec (ns) = ""b;
 765 
 766           save_row = state.row;
 767           save_col = state.col;
 768 
 769           if distance > 0                                   /* down */
 770           then do;
 771                if (row + n_rows - 1) = tc_data.rows
 772                then do;                                     /* insert is all we need */
 773                     call position_cursor (row, 1);
 774                     call do_operation (INSERT_LINES, (0), (0), distance, ns);
 775                end;
 776                else do;
 777                     call position_cursor (row + n_rows - distance, 1);
 778                     call do_operation (DELETE_LINES, (0), (0), distance, ns);
 779                     call position_cursor (row, 1);
 780                     call do_operation (INSERT_LINES, (0), (0), distance, ns);
 781                end;
 782           end;
 783           else do;                                          /* up */
 784                call position_cursor (row, 1);
 785                call do_operation (DELETE_LINES, (0), (0), -distance, ns);
 786                if (row + n_rows - 1) ^= tc_data.rows        /* bottom region */
 787                then do;
 788                     call position_cursor (row + n_rows + distance, 1);
 789                                                             /* it is negative */
 790                     call do_operation (INSERT_LINES, (0), (0), -distance, ns);
 791                end;
 792           end;
 793 
 794           call position_cursor (save_row, save_col);
 795      end scroll_region;
 796 ^L
 797 
 798 bell:
 799      procedure (a_row, a_col);
 800 
 801           declare (a_row, a_col)           fixed bin;
 802 
 803           declare (row, col)               fixed bin;
 804 
 805           row = a_row;
 806           col = a_col;
 807 
 808           call position_cursor (row, col);                  /* visual effect too */
 809           call write_bell;                                  /* knows it 0 length on screen */
 810      end bell;
 811 ^L
 812 
 813 cost:
 814      procedure (op) returns (fixed bin);
 815           declare op                       fixed bin;
 816 
 817           declare count                    fixed bin;
 818 
 819           count = 1;
 820           go to cost_common;
 821 
 822 cost_repeat:
 823      entry (op, a_count) returns (fixed bin);
 824           declare a_count                  fixed bin;
 825 
 826 
 827           count = a_count;
 828 
 829 cost_common:
 830           ttyvseqp = addr (tty_video_table.sequences (op));
 831           if ^tty_video_seq.present
 832           then return (OMEGA);                              /* Quite expensive */
 833           if tty_video_seq.able_to_repeat
 834           then return (tty_video_seq.len);
 835           else return (count * tty_video_seq.len);
 836 
 837 available:
 838      entry (op) returns (bit (1) aligned);
 839 
 840           ttyvseqp = addr (tty_video_table.sequences (op));
 841           return (tty_video_seq.present);
 842 
 843      end cost;
 844 ^L
 845 
 846 do_operation:
 847      procedure (op, a_op_row, a_op_col, op_n, a_new_state);
 848 
 849 /* If op_row or op_col is zero we use current position, if something
 850    demands coords. This makes for redundant positions, but so be it for now */
 851 
 852 /* ASSERT: that even a line's worth of text will fit into
 853    the hardcore's take it or leave it buffer. */
 854 
 855 /* This program manages state. For each operation, it makes
 856    the character string for the terminal, and calculates the net
 857    effect on the cursor position, updating the state structure,
 858    and the screen image via tc_screen. */
 859 
 860 
 861           declare (op, op_row, op_col, op_n, a_op_row, a_op_col)
 862                                            fixed binary;
 863 
 864           declare 1 a_new_state            aligned like new_state;
 865           declare 1 ns                     aligned like new_state;
 866 
 867           declare 1 seq                    aligned like tty_video_seq based (ttyvseqp);
 868           declare chars                    character (seq.len) based (chars_ptr);
 869           declare chars_ptr                pointer;
 870 
 871 
 872           ttyvseqp = addr (tty_video_table.sequences (op)); /* Do this first do avoid faults in the begin block prologue. */
 873 
 874           ns = state, by name;
 875           if a_new_state.pay_attention.cursor
 876           then ns.cursor_valid = a_new_state.cursor_valid;
 877           if a_new_state.pay_attention.insert
 878           then ns.insert_mode = a_new_state.insert_mode;
 879           if a_new_state.pay_attention.position
 880           then ns.cursor_position = a_new_state.cursor_position;
 881 
 882           begin;
 883                declare i                        fixed bin;
 884                declare loop                     fixed bin;
 885                declare cx                       fixed bin;
 886                declare vchars                   character (seq.len) defined (tty_video_table.video_chars)
 887                                                 position (seq.seq_index);
 888 
 889                op_row = a_op_row;
 890                if op_row = 0
 891                then op_row = state.row;
 892                op_col = a_op_col;
 893                if op_col = 0
 894                then op_col = state.col;
 895 
 896 /* HOME is a bit magic */
 897 
 898                if op = HOME
 899                then op_row, op_col = 1;
 900                if ^seq.present
 901                then call tc_error (video_et_$tc_missing_operation, "");
 902 
 903                chars_ptr = addr (vchars);                   /* so we can see chars in probe */
 904 
 905                if ^seq.interpret                            /* easy */
 906                then do;
 907                     do i = 1 to op_n;                       /* supply repeats */
 908                          call add_to_buffer (chars);
 909                          call pad;
 910                     end;
 911                     go to update_state;
 912                end;
 913 
 914 /* don't bother if nothing is going to happen */
 915                else if (op_n > 0)
 916                then do;
 917                     if seq.able_to_repeat
 918                     then loop = 1;
 919                     else loop = op_n;
 920                     do i = 1 to loop;
 921 
 922                          do cx = 1 to seq.len;
 923                               begin;
 924                                    declare the_char                 character (1) defined (chars) position (cx);
 925                                    declare 1 encoded                unaligned like tty_numeric_encoding based (enc_ptr);
 926                                    declare enc_ptr                  pointer;
 927 
 928 
 929                                    enc_ptr = addr (the_char);
 930 
 931                                    if ^encoded.must_be_on
 932                                    then call add_to_buffer (the_char);
 933                                    else cx = cx + encode (encoded);
 934                               end;                          /* begin */
 935                          end;                               /* do over chars in seq */
 936                          call pad;
 937                     end;                                    /* over repeat count */
 938                end;                                         /* was nontrivial */
 939 update_state:
 940                state = ns, by name;
 941 
 942                if op_n > 0
 943                then call tc_screen$operation (tc_data.screen_data_ptr, op, op_row, op_col, op_n);
 944           end;                                              /* simulated terminal */
 945           return;
 946 
 947 
 948 pad:
 949      procedure;
 950           if seq.cpad_present
 951           then do;
 952                if seq.cpad_in_chars
 953                then call add_pad_to_buffer ((seq.cpad));
 954                else call add_pad_to_buffer (divide (seq.cpad /* .0001 secs */ * tc_data.line_speed, 10000, 21, 0));
 955           end;
 956      end pad;
 957 
 958 
 959 encode:
 960      procedure (thing) returns (fixed bin);
 961 
 962 /* ASSERT that n is positive. what should negatives look like? */
 963 
 964           declare 1 thing                  unaligned like tty_numeric_encoding;
 965           declare value                    fixed bin;
 966           declare skip                     fixed bin;
 967 
 968           skip = 0;
 969           go to VALUE (thing.l_c_or_n);
 970 
 971 VALUE (0):                                                  /* LINE */
 972           value = op_row;
 973           go to got_value;
 974 
 975 VALUE (1):                                                  /* COLUMN */
 976           value = op_col;
 977           go to got_value;
 978 VALUE (2):                                                  /* N */
 979           value = op_n;
 980 
 981 got_value:
 982           if ^thing.offset_is_0
 983           then do;
 984                value = value + thing.offset;
 985                skip = 1;
 986           end;
 987 
 988 
 989           if thing.express_in_decimal
 990           then do;
 991                if thing.num_digits = 0
 992                then call add_to_buffer_ltrim_char (value);
 993 
 994                else call add_to_buffer_last_n (value, (thing.num_digits));
 995           end;
 996           else if thing.express_in_octal
 997           then do;                                          /* this is a mess, cause pl1 do not grok octal */
 998                begin;
 999                     declare bits                     (-5:6) bit (3) unaligned;
1000                     declare ib                       fixed bin;
1001                     declare saw_nonzero              bit (1);
1002                     declare start                    fixed bin;
1003 
1004                     saw_nonzero = "0"b;
1005                     unspec (bits) = unspec (value);
1006                     if thing.num_digits = 0
1007                     then start = 1;
1008                     else start = 6 - thing.num_digits + 1;
1009 
1010                     do ib = start to 6;
1011                          if bits (ib) = "000"b
1012                          then if saw_nonzero | start > 1
1013                               then call add_to_buffer ("0");
1014                               else ;                        /* suppress */
1015                          else do;
1016                               call add_to_buffer (byte (bin (bits (ib), 3) + rank ("0")));
1017                               saw_nonzero = "1"b;
1018                          end;
1019                     end;
1020                end;                                         /* begin */
1021           end;                                              /* octalness */
1022 
1023           else call add_to_buffer (byte (value));
1024           return (skip);
1025      end encode;
1026 
1027      end do_operation;
1028 
1029 /* parallel routine to do_operation for writing text to the terminal and
1030    updating the screen image. */
1031 
1032 write_text:
1033      procedure (op_row, op_col, text_ptr, text_length);
1034 
1035           dcl  (op_row, op_col)         fixed bin;
1036           dcl  text_ptr                 pointer;
1037           dcl  text_length              fixed bin (21);
1038 
1039           dcl  text                     char (text_length) based (text_ptr);
1040 
1041 /* Can not be called with 0 values for row and col. */
1042 
1043           call add_to_buffer_splittable (text_ptr, text_length);
1044 
1045           state.row = op_row;
1046           state.col = op_col + text_length;
1047 
1048           call tc_screen$text (tc_data.screen_data_ptr, op_row, op_col, (state.insert_mode), text);
1049           return;
1050 
1051 write_bell:
1052      entry;
1053 
1054           call add_to_buffer (byte (7));
1055           return;
1056 
1057      end write_text;
1058 ^L
1059 /* Internal procedures for handling the buffering and sending
1060    of data to ring 0 tty routines. */
1061 
1062 add_to_buffer:
1063      procedure (string);
1064 
1065 /* Entry to add a string to the output buffer.  Always ensures that the
1066    entire string is added without breaks, so tty sequences won't get broken */
1067 
1068           dcl  string                   character (*);
1069           dcl  chunk_length             fixed bin;
1070           dcl  stuff_idx                fixed bin;
1071           dcl  ok_to_split              bit (1) aligned;
1072 
1073           dcl  a_stuff_ptr              pointer;
1074           dcl  a_stuff_length           fixed bin (21);
1075 
1076           dcl  stuff_ptr                pointer;
1077           dcl  stuff_length             fixed bin (21);
1078 
1079           dcl  stuff                    char (stuff_length) based (stuff_ptr);
1080 
1081           stuff_ptr = addr (string);
1082           stuff_length = length (string);
1083 
1084           ok_to_split = "0"b;
1085           goto add_to_buffer_common;
1086 
1087 add_to_buffer_splittable:
1088      entry (a_stuff_ptr, a_stuff_length);
1089 
1090 /* Entry to write potentially large strings, which can be split up
1091    arbitrarily among different calls to ring 0. */
1092 
1093           stuff_ptr = a_stuff_ptr;
1094           stuff_length = a_stuff_length;
1095 
1096           ok_to_split = "1"b;
1097           goto add_to_buffer_common;
1098 
1099 add_to_buffer_common:                                       /* Make sure that there is room in the buffer, and flush it
1100                                                                out if it is full. */
1101           if (tc_data.global_buffer_index + length (stuff)) > tc_data.global_buffer_limit
1102           then if ok_to_split
1103                then do;                                     /* first fill the buffer completely and write it */
1104                     stuff_idx = 1;
1105 
1106                     do while ((length (stuff) - stuff_idx + 1) > tc_data.global_buffer_limit);
1107                          chunk_length = tc_data.global_buffer_limit - tc_data.global_buffer_index;
1108                          substr (tc_data.global_output_buffer, tc_data.global_buffer_index + 1, chunk_length) =
1109                               substr (stuff, stuff_idx, chunk_length);
1110                          tc_data.global_buffer_index = tc_data.global_buffer_limit;
1111                          call write_global_buffer;
1112                          stuff_idx = stuff_idx + chunk_length;
1113                     end;
1114 
1115 /* now put the remaining stuff in the buffer */
1116                     chunk_length = length (stuff) - stuff_idx + 1;
1117                     substr (tc_data.global_output_buffer, tc_data.global_buffer_index + 1, chunk_length) =
1118                          substr (stuff, stuff_idx);
1119                     tc_data.global_buffer_index = tc_data.global_buffer_index + chunk_length;
1120                     return;
1121                end;
1122 
1123                else call write_global_buffer;               /* not OK to split */
1124 
1125 /* Add entire string. This better not be bigger than the buffer */
1126 
1127           substr (tc_data.global_output_buffer, tc_data.global_buffer_index + 1, length (stuff)) = stuff;
1128           tc_data.global_buffer_index = tc_data.global_buffer_index + length (stuff);
1129           return;
1130 
1131      end add_to_buffer;
1132 
1133 add_pad_to_buffer:
1134      procedure (number);
1135           declare number                   fixed bin;
1136 
1137           declare pad_length               fixed bin;       /* the 254 here is due to a compiler limitation in init clauses */
1138           declare pad_string               char (254) static options (constant) init ((254)"^@");
1139 
1140           pad_length = min (number, length (pad_string));
1141           begin;
1142                dcl  defined_pad              char (pad_length) defined (pad_string) pos (1);
1143                call add_to_buffer (defined_pad);
1144           end;
1145           return;
1146      end add_pad_to_buffer;
1147 
1148 add_to_buffer_ltrim_char:
1149      procedure (number);
1150           declare number                   fixed bin;
1151           declare pic_                     picture "9999";
1152           declare char_temp                char (4);
1153           declare first_nonspace           fixed bin;
1154 
1155           pic_ = number;
1156           first_nonspace = verify (pic_, "0");              /* digits start here, there must be 1 */
1157           if first_nonspace = 0
1158           then first_nonspace = 4;
1159 
1160 add_in_number:
1161           char_temp = pic_;
1162           begin;
1163                dcl  defined_pic              char (length (char_temp) - first_nonspace + 1) defined (char_temp)
1164                                              pos (first_nonspace);
1165                call add_to_buffer (defined_pic);
1166           end;
1167           return;
1168 
1169 add_to_buffer_last_n:
1170      entry (number, digits);
1171           declare digits                   fixed bin;
1172 
1173           pic_ = number;
1174           first_nonspace = 5 - digits;                      /* first digit we want */
1175           go to add_in_number;
1176 
1177      end add_to_buffer_ltrim_char;
1178 
1179 /* Internal routine to write the buffered output to the terminal */
1180 
1181 write_global_buffer:
1182      procedure;
1183 
1184           declare to_write                 character (tc_data.global_buffer_index)
1185                                            defined (tc_data.global_output_buffer) position (1);
1186           declare n_wrote                  fixed bin (21);
1187 
1188           if length (to_write) = 0
1189           then return;
1190 
1191           tc_data.change_pclock = tc_data.change_pclock + 1;
1192 
1193 write:
1194           n_wrote = 0;
1195 
1196           if tc_data.network_type = DSA_NETWORK_TYPE
1197           then                                              /* DSA */
1198                call dsa_tty_$write_whole_string (tc_data.tty_handle, to_write, "1"b /* MARK */, n_wrote, tty_state, code);
1199           else if tc_data.network_type = MOWSE_NETWORK_TYPE
1200           then                                              /* MOWSE */
1201                call ws_tty_$write_whole_string (tc_data.mowse_terminal_iocb_ptr, to_write, "1"b, n_wrote, tty_state, code)
1202                     ;
1203           else                                              /* MCS */
1204                call hcs_$tty_write_whole_string (tc_data.devx, to_write, "1"b /* MARK */, n_wrote, tty_state, code);
1205 
1206           if code ^= 0
1207           then call tc_disconnect$check (TC_data_ptr, code);
1208 
1209           if code ^= 0
1210           then do;                                          /* If the stuff couldn't be written, all our assumptions about
1211                                                                the cursor position on the actual terminal are wrong. */
1212                tc_data.state.cursor_valid = "0"b;
1213                call tty_write_error (code);
1214           end;
1215 
1216           if length (to_write) > 0 & n_wrote = 0            /* did not happen */
1217           then do;
1218                if tc_data.network_type ^= MOWSE_NETWORK_TYPE
1219                then call block;
1220                go to write;
1221           end;
1222           call bump_mark;
1223 
1224           tc_data.global_buffer_index = 0;                  /* indicate buffer empty */
1225 
1226      end write_global_buffer;
1227 ^L
1228 
1229 write_no_mark:
1230      procedure (text);
1231           declare text                     character (*);
1232           declare n_wrote                  fixed bin (21);  /* ASSERT text_to_echo is aligned */
1233           declare buffer_ptr               pointer;
1234           declare offset                   fixed bin (21);
1235           declare n_left                   fixed bin (21);
1236           declare char_offset_             entry (ptr) returns (fixed bin (21)) reducible;
1237           declare add_char_offset_         entry (ptr, fixed bin (21)) returns (ptr) reducible;
1238 
1239           if length (text) = 0
1240           then return;
1241 
1242           n_left = length (text);
1243 
1244           buffer_ptr = addr (text);
1245           offset = char_offset_ (buffer_ptr);
1246 
1247 /**** The hardcore demands a word aligned buffer ****/
1248 
1249           if offset > 0
1250           then buffer_ptr = add_char_offset_ (buffer_ptr, -offset);
1251 
1252 /* first write out any buffered stuff to get in sync */
1253           call write_global_buffer;
1254 
1255 echo_write:
1256           if tc_data.network_type = DSA_NETWORK_TYPE
1257           then                                              /* DSA */
1258                call dsa_tty_$write (tc_data.tty_handle, buffer_ptr, offset, n_left, n_wrote, tty_state, code);
1259           else if tc_data.network_type = MOWSE_NETWORK_TYPE
1260           then                                              /* MOWSE */
1261                call ws_tty_$write (tc_data.mowse_terminal_iocb_ptr, buffer_ptr, offset, n_left, n_wrote, tty_state, code);
1262           else                                              /* MCS */
1263                call hcs_$tty_write (tc_data.devx, buffer_ptr, offset, n_left, n_wrote, tty_state, code);
1264 
1265           if code ^= 0
1266           then call tc_disconnect$check (tc_data_ptr, code);
1267           if code ^= 0
1268           then call tty_write_error (code);
1269           if n_wrote < n_left
1270           then do;                                          /* Lets try it again */
1271 
1272 /* This should NEVER happen. */
1273 
1274                if tc_data.network_type ^= MOWSE_NETWORK_TYPE
1275                then call block;
1276                n_left = n_left - n_wrote;
1277                offset = offset + n_wrote;
1278                go to echo_write;
1279           end;
1280           return;
1281      end write_no_mark;
1282 
1283 /* This should be the only non-error return point from tc_request. */
1284 
1285 request_done:
1286           Code = 0;
1287           return;
1288 
1289 capabilities_lacking:
1290           Code = video_et_$capability_lacking;
1291           go to request_done;
1292 
1293 
1294 block:
1295      procedure;
1296 
1297           declare UNMASK_NOTHING           bit (36) aligned initial ("01"b) internal static options (constant);
1298 
1299           call tc_block (tc_data_ptr, request_ptr, UNMASK_NOTHING);
1300 
1301      end block;
1302 ^L
1303 
1304 tty_write_error:
1305      procedure (code);
1306           declare code                     fixed bin (35);
1307           declare msg                      character (100) aligned;
1308           declare convert_status_code_     entry (fixed binary (35), character (8) aligned, character (100) aligned);
1309 
1310           call convert_status_code_ (code, (8)" ", msg);
1311           call tc_error (video_et_$tc_tty_error, rtrim (msg));
1312      end tty_write_error;
1313 
1314 
1315 write_raw_text:
1316      procedure (row, col, text);
1317           declare (row, col)               fixed bin;
1318           declare text                     character (*);
1319           declare n_wrote                  fixed bin (21);
1320           declare code                     fixed bin (35);
1321           declare tty_state                fixed bin;
1322           declare offset                   fixed bin (21);
1323           declare text_length              fixed bin (21);
1324 
1325           if length (text) = 0
1326           then return;
1327 
1328           offset = 0;
1329           text_length = length (text);
1330 
1331           tc_data.change_pclock = tc_data.change_pclock + 1;
1332 
1333 /* first write out any buffered stuff */
1334           call write_global_buffer;
1335 
1336 write:
1337           begin;
1338                declare to_write                 character (text_length) defined (text) position (1 + offset);
1339 
1340                n_wrote = 0;
1341 
1342 /* write the whole string at once, with mark */
1343 
1344                if tc_data.network_type = DSA_NETWORK_TYPE
1345                then                                         /* DSA */
1346                     call dsa_tty_$write_whole_string (tc_data.tty_handle, to_write, "1"b /* with mark */, n_wrote,
1347                          tty_state, code);
1348                else if tc_data.network_type = MOWSE_NETWORK_TYPE
1349                then                                         /* MOWSE */
1350                     call ws_tty_$write_whole_string (tc_data.mowse_terminal_iocb_ptr, to_write, "1"b, n_wrote, tty_state,
1351                          code);
1352                else                                         /* MCS */
1353                     call hcs_$tty_write_whole_string (tc_data.devx, to_write, "1"b /* with mark */, n_wrote, tty_state,
1354                          code);
1355 
1356                if code ^= 0
1357                then call tc_disconnect$check (tc_data_ptr, code);
1358                if code ^= 0
1359                then call tty_write_error (code);
1360           end;
1361 
1362           if n_wrote < text_length
1363           then do;
1364                if tc_data.network_type ^= MOWSE_NETWORK_TYPE
1365                then call block;
1366                text_length = text_length - n_wrote;
1367                offset = offset + n_wrote;
1368                go to write;
1369           end;
1370           state.cursor_valid = "0"b;                        /* who knows what it did ? */
1371           call bump_mark;
1372      end write_raw_text;
1373 
1374 
1375 RECOMPUTE_OPERATION:
1376           if request_header.this_window                     /* it happened in the same window */
1377           then go to request_done;
1378           else go to recompute_operation_here;              /* was not this window */
1379 
1380 
1381 
1382 bump_mark:
1383      procedure;
1384           if state.current_mark = 511                       /* using the size condition is expensive */
1385           then do;
1386                state.current_mark = 1;
1387                state.last_mark_back = 0;
1388           end;
1389           state.current_mark = state.current_mark + 1;
1390      end bump_mark;
1391 
1392 write_echo:
1393      entry (TC_data_ptr, text_to_echo);
1394 
1395           declare text_to_echo             character (*) parameter;
1396 
1397           tc_data_ptr = TC_data_ptr;
1398           call write_no_mark (text_to_echo);
1399           call tc_screen$text (tc_data.screen_data_ptr, state.row, state.col, "0"b, text_to_echo);
1400           state.col = state.col + length (text_to_echo);
1401           return;
1402 %page;
1403 %include net_event_message;
1404 %page;
1405 %include tc_data_;
1406 %page;
1407 %include tc_operations_;
1408 %page;
1409 %include condition_info_header;
1410 %page;
1411 %include tc_asyncronity_info;
1412 %page;
1413 %include tty_video_tables;
1414 
1415      end tc_request;