1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
   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 /****^  HISTORY COMMENTS:
  16   1) change(89-02-02,Huen), approve(89-02-02,MCR8057), audit(89-05-24,RWaters),
  17      install(89-05-31,MR12.3-1051):
  18      Fix Bug 204 in qedx
  19      editor - Ignore trailing whitespace after a quit request.
  20                                                    END HISTORY COMMENTS */
  21 
  22 /* format: off */
  23 
  24 /* Multics qedx Editor subroutine interface: the actual editor. */
  25 
  26 /* Created:  August 1970 by R. C. Daley */
  27 /* Modified: August 1977 by R.J.C. Kissel to fix long entryname and garbage word bugs */
  28 /* Modified: 23 February 1979 by Steve Herbst to fix w and r error messages for MSFs */
  29 /* Modified: 4 September 1981 by E. N. Kittlitz to add -pathname, -no_rw_path, r request with no pathname, and to
  30       eliminate b.default_len */
  31 /* Modified: 14 July 1980 by T. Oke for gapped buffer management */
  32 /* Modified: 3 March 1981 by S. G. Harris (UNCA) for read entry point */
  33 /* Modified: 3 March 1982 by S. Herbst to merge all of above changes */
  34 /* Modified: 16 April 1982 by S. Herbst to add quit query for modified buffers (subsequently removed, sigh) */
  35 /* Modified: 5 May 1982 by S. Herbst to check that it has not been recursively interrupted */
  36 /* Modified: 7 October 1982 by S. Herbst to fix "Substitution failed." bug inside recursed buffer */
  37 /* Modified: 3 November 1982 by S. Herbst to fix ".a" bug in empty buffer */
  38 /* Modified: January 1983 by G. Palter to make reentrant, convert into qedx_, re-enable quit query if requested by caller,
  39       accept the archive component pathname convention on input, rename quit-force to "qf" from "Q", and add trusted
  40       pathnames as in ted */
  41 /* Modified April 1983 by Keith Loepere to make work in Bootload Multics */
  42 /* Modified August 1983 by Keith Loepere for new bce switches */
  43 /* Modified March 1985 by Keith Loepere to run in bce and Multics. */
  44 /* Modified Jan 1989 by Huen (204) - Allow whitespace after a "q" request (such as q, Q, qf, etc) */
  45 
  46 /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */
  47 
  48 qedx_:
  49      procedure (P_qedx_info_ptr, P_code);
  50 
  51 
  52 dcl  P_qedx_info_ptr pointer parameter;                     /* -> caller's initial buffers, etc. */
  53 dcl  P_code fixed binary (35) parameter;
  54 
  55 dcl  a_real_file bit (1) aligned;
  56 dcl  b0_bp ptr;
  57 dcl  b0_ifp ptr;
  58 dcl  buffer_idx fixed binary;
  59 dcl  callers_io_region_ptr pointer;
  60 dcl  ch char (1);
  61 dcl  cht char (1);
  62 dcl  code fixed bin (35);
  63 dcl  curbuf char (16) init ("0");
  64 dcl  delim char (1);
  65 dcl  error_sw ptr;                                          /* for "special" errors */
  66 dcl  explicit_pathname bit (1) aligned;
  67 dcl  fe fixed bin (21);
  68 dcl  fle fixed bin (21);
  69 dcl  fli fixed bin (21);
  70 dcl  flsw bit (1);
  71 dcl  fp ptr;
  72 dcl  have_truncated_buffers bit (1) aligned;
  73 dcl  i fixed bin (21);
  74 dcl  ife fixed bin (21);                                    /* index of last char in file */
  75 dcl  ifp ptr;                                               /* pointer to current file buffer */
  76 dcl  ift fixed bin (21);
  77 dcl  ignore_result bit (1) aligned;
  78 dcl  il fixed bin (21);
  79 dcl  ilb fixed bin (21);
  80 dcl  iline char (512);
  81 dcl  intsw bit (1);
  82 dcl  j fixed bin (21);
  83 dcl  je fixed bin (21);
  84 dcl  k fixed bin (21);
  85 dcl  ka fixed bin (21);
  86 dcl  kx fixed bin (21);
  87 dcl  l fixed bin (21);
  88 dcl  le fixed bin (21);                                     /* index of last char of current line */
  89 dcl  li fixed bin (21);                                     /* index of first char of current line */
  90 dcl  lle fixed bin (21);                                    /* index of last char of addressed line */
  91 dcl  lli fixed bin (21);                                    /* index of first char of addressed line */
  92 dcl  llsw bit (1);
  93 dcl  1 local_qbii aligned like qedx_buffer_io_info;
  94 dcl  1 local_qid aligned like qid;                          /* describes this invocation */
  95 dcl  me fixed bin (21);
  96 dcl  mi fixed bin (21);
  97 dcl  ml fixed bin (21);
  98 dcl  new_modes char (256);                                  /* for call to iox_$modes */
  99 dcl  old_modes char (256);
 100 dcl  output_routine entry (ptr, ptr, fixed bin (21), fixed bin (35)) variable;
 101 dcl  output_sw ptr;                                         /* bce/iox_ switch for "special" output */
 102 dcl  pfs fixed bin (35) init (0);
 103 dcl  pi_label label;
 104 dcl  pi_sw bit (1);
 105 dcl  process_type fixed bin;
 106 dcl  quit_force_sw bit (1);
 107 dcl  saved_current_buffer character (16);
 108 dcl  saved_ift fixed bin (21);                              /* copy of ift during call to "promote" */
 109 dcl  sdsw bit (1);
 110 dcl  subsw bit (1);
 111 dcl  sub_comp_string character (3) aligned init ("   ");
 112 dcl  tbp ptr;
 113 dcl  te fixed bin (21);                                     /* index of last character in tw line */
 114 dcl  1 the_buffer aligned like qedx_info.buffers based (the_buffer_ptr);
 115 dcl  the_buffer_ptr pointer;
 116 dcl  the_pathname character (256);
 117 dcl  ti fixed bin (21);                                     /* index of first unprocessed char in tw line */
 118 dcl  tik fixed bin (21);
 119 dcl  tname char (16);
 120 dcl  tp ptr;                                                /* pointer to current typewriter input request line */
 121 dcl  twbuff char (512);
 122 dcl  was_empty bit (1) aligned;
 123 dcl  xsw bit (1);
 124 dcl  yes_sw bit (1);
 125 
 126 /* ilb_offset is used for post-deletion of text during string substitution.
 127    Post deletion is necessary so the the string search /^ // on line 1 will
 128    not kill all spaces since first line anchoring tests for nothing before
 129    and pre-deletion to next search will ensure a re-match for ^ . */
 130 
 131 dcl  ilb_offset fixed bin (21);
 132 
 133 dcl  COMMANDS character (19) static options (constant) initial ("psaicdbmrwqg=xevn""Q");
 134 dcl  command_index fixed binary;                            /* current command being executed */
 135 
 136 dcl  QEDX_ character (32) static options (constant) initial ("qedx_");
 137 
 138 dcl  QEDX_INFO_VERSION_0 character (8) static options (constant) initial ("qxi_0001");
 139 
 140 dcl  MODIFIED_BUFFERS_EXPLANATION character (104) static options (constant)
 141           initial ("If you quit now, your latest changes to the above buffers will not be
 142 saved.  Do you still wish to quit?");
 143 
 144 dcl  TRUNCATED_BUFFERS_EXPLANATION character (100) static options (constant)
 145           initial ("If you quit now, some of the contents of the above buffers will be
 146 lost.  Do you still wish to quit?");
 147 
 148 dcl  TRUSTED_PATHNAMES_EXPLANATION character (198) static options (constant)
 149           initial ("More than one pathname has been used with the read and write requests
 150 in this buffer.  Do you want to ^a this buffer using the pathname ^a
 151 which I consider to be the correct default for this buffer?");
 152 
 153 dcl  1 t based (tp) aligned,                                /* structure to treat request line as character array */
 154        2 c (sys_info$max_seg_size * 4) char (1) unaligned;
 155 
 156 dcl  1 f based aligned,                                     /* structure to treat any file as character array */
 157        2 c (sys_info$max_seg_size * 4) char (1) unaligned;
 158 
 159 dcl  a_string char (sys_info$max_seg_size * 4) based aligned;
 160 
 161 dcl  CHASE fixed binary (1) static options (constant) initial (1);
 162 
 163 dcl  EC character (1) static options (constant) initial ("^Y");
 164                                                             /* ancient conceal character = ASCII 031 */
 165 
 166 dcl  NL character (1) static options (constant) initial ("
 167 ");
 168 
 169 /* format: off */
 170 dcl (error_table_$archive_component_modification, error_table_$archive_pathname, error_table_$bigarg, error_table_$dirseg,
 171      error_table_$fatal_error, error_table_$inconsistent, error_table_$moderr, error_table_$no_r_permission,
 172      error_table_$no_w_permission, error_table_$pathlong, error_table_$recoverable_error,
 173      error_table_$unimplemented_version)
 174           fixed binary (35) external;
 175 /* format: on */
 176 dcl  sys_info$max_seg_size fixed binary (19) external;
 177 dcl  sys_info$service_system bit (1) aligned external;
 178 
 179 dcl  (cleanup, program_interrupt, sub_request_abort_) condition;
 180 
 181 dcl  bce_data$console_put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)) external variable;
 182 dcl  bce_data$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)) external variable;
 183 dcl  iox_$user_output ptr ext;                              /* pointer to iocb for user_output */
 184 dcl  iox_$user_io ptr ext;                                  /* pointer to iocb for user_io */
 185 
 186 dcl  bce_check_abort entry;
 187 dcl  bce_query$yes_no entry options (variable);
 188 dcl  bootload_fs_$flush_sys entry;
 189 dcl  bootload_fs_$get_ptr entry (char (*), ptr, fixed bin (21), fixed bin (35));
 190 dcl  bootload_fs_$put_ptr entry (char (*), fixed bin (21), bit (1) aligned, ptr, fixed bin (35));
 191 dcl  check_entryname_ entry (char (*), fixed bin (35));
 192 dcl  com_err_ entry () options (variable);
 193 dcl  command_query_$yes_no entry options (variable);
 194 dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
 195 dcl  edx_util_$edx_cleanup entry (ptr);
 196 dcl  edx_util_$edx_init entry (ptr, ptr, ptr, ptr, fixed bin (35));
 197 dcl  edx_util_$end_buffer entry (ptr, fixed bin (35));
 198 dcl  edx_util_$get_buffer entry (ptr, ptr, fixed bin (21), fixed bin (21), char (16), ptr);
 199 dcl  edx_util_$list_buffers entry (ptr, char (16), ptr);
 200 dcl  edx_util_$list_modified_buffers entry (pointer, character (16), pointer);
 201 dcl  edx_util_$list_single_buffer entry (pointer, character (16), pointer, pointer);
 202 dcl  edx_util_$locate_buffer entry (ptr, char (16), ptr);
 203 dcl  edx_util_$modified_buffers entry (ptr) returns (bit (1));
 204 dcl  edx_util_$prime entry (ptr, ptr, fixed bin (21));
 205 dcl  edx_util_$read_ptr entry (ptr, ptr, fixed bin (21), fixed bin (21));
 206 dcl  edx_util_$resetread entry (ptr);
 207 dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
 208 dcl  expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
 209 dcl  get_addr_
 210           entry (ptr, ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (21),
 211           fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (35));
 212 dcl  get_system_free_area_ entry () returns (ptr);
 213 dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
 214 dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
 215 dcl  initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
 216 dcl  initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35));
 217 dcl  ioa_ entry () options (variable);
 218 dcl  ioa_$ioa_switch entry () options (variable);
 219 dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
 220 dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
 221 dcl  mrl_ entry (ptr, fixed bin (21), ptr, fixed bin (21));
 222 dcl  pathname_ entry (char (*), char (*)) returns (char (168));
 223 dcl  pathname_$component entry (char (*), char (*), char (*)) returns (char (194));
 224 dcl  qx_search_file_
 225           entry (ptr, ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (21),
 226           fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (35));
 227 dcl  qx_search_file_$cleanup entry (ptr);
 228 dcl  qx_search_file_$init entry (ptr);
 229 dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
 230 dcl  sub_err_ entry () options (variable);
 231 dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
 232 dcl  user_info_$process_type entry (fixed bin);
 233 
 234 dcl  (addr, divide, index, min, null, search, substr, length, reverse, rtrim, string) builtin;
 235 %page;
 236 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 237 
 238 /* qedx_: procedure (P_qedx_info_ptr, P_code); */
 239 
 240           if sys_info$service_system then do;
 241                output_routine = iox_$put_chars;
 242                output_sw = iox_$user_output;
 243                error_sw = iox_$user_io;
 244           end;
 245           else do;
 246                output_routine = bce_data$put_chars;
 247                error_sw = addr (bce_data$console_put_chars);
 248                output_sw = addr (bce_data$put_chars);
 249           end;
 250 
 251           qedx_info_ptr = P_qedx_info_ptr;
 252 
 253           if (qedx_info.version ^= QEDX_INFO_VERSION_0) & (qedx_info.version ^= QEDX_INFO_VERSION_1) then do;
 254                P_code = error_table_$unimplemented_version;
 255                return;
 256           end;
 257 
 258 
 259 /* Initialize per-invocation data */
 260 
 261           qid_ptr = addr (local_qid);                       /* use the one in automatic */
 262 
 263           qid.editor_name = qedx_info.editor_name;
 264           qid.editor_area_ptr = get_system_free_area_ ();
 265           qid.qedx_info_ptr = qedx_info_ptr;                /* edx_util_, etc. may need it */
 266 
 267           qid.flags = qedx_info.header.flags, by name;      /* all the same flags */
 268 
 269           qid.edx_util_data_ptr,                            /* for cleanup handler */
 270                qid.regexp_data_ptr, callers_io_region_ptr = null ();
 271 
 272           on condition (cleanup) call cleanup_invocation_data ();
 273 
 274           call edx_util_$edx_init (qid_ptr, addr (twbuff), b0_ifp, b0_bp, code);
 275           if code ^= 0 then do;
 276                call com_err_ (code, qid.editor_name, "Unable to initialize edx_util_.");
 277                P_code = error_table_$fatal_error;
 278                return;
 279           end;
 280 
 281           call get_buffer_state (b0_bp);                    /* let buffer "0" be current (for now) */
 282 
 283           call qx_search_file_$init (qid_ptr);
 284 
 285           if qedx_info.caller_does_io then do;              /* need an I/O buffer */
 286                call get_temp_segment_ (qid.editor_name, callers_io_region_ptr, code);
 287                if code ^= 0 then do;
 288                     call com_err_ (code, qid.editor_name, "Obtaining I/O buffer.");
 289                     P_code = error_table_$fatal_error;
 290                     go to RETURN_FROM_QEDX_;
 291                end;
 292           end;
 293 
 294 
 295 /* Initialize buffers to those supplied by the caller */
 296 
 297           do buffer_idx = 1 to qedx_info.n_buffers;
 298                the_buffer_ptr = addr (qedx_info.buffers (buffer_idx));
 299 
 300                call edx_util_$locate_buffer (qid_ptr, the_buffer.buffer_name, bp);
 301                if bp = null () then do;                     /* error already printed */
 302                     P_code = error_table_$fatal_error;
 303                     go to RETURN_FROM_QEDX_;
 304                end;
 305 
 306                call get_buffer_state (bp);
 307                b.callers_idx = buffer_idx;                  /* need to keep track of it */
 308 
 309                if the_buffer.read_write_region then do;     /* read/write from caller's character string */
 310                     if the_buffer.region_ptr = null () then do;
 311                          call sub_err_ (error_table_$inconsistent, QEDX_, ACTION_CANT_RESTART, null (), 0,
 312                               "Input/output area required for buffer ^a was not supplied.", the_buffer.buffer_name);
 313                          P_code = error_table_$fatal_error;
 314                          go to RETURN_FROM_QEDX_;
 315                     end;
 316                     else if qedx_info.caller_does_io then do;
 317                          call sub_err_ (error_table_$inconsistent, QEDX_, ACTION_CANT_RESTART, null (), 0,
 318                               "Input/output area can not be used for buffer ^a when caller performs I/O.",
 319                               the_buffer.buffer_name);
 320                          P_code = error_table_$fatal_error; /* ... caller I/O only works with pathnames */
 321                          go to RETURN_FROM_QEDX_;
 322                     end;
 323                     else do;                                /* ... and it's actually there */
 324                          a_real_file = "0"b;                /* ... ...don't terminate it */
 325                          the_pathname = the_buffer.buffer_pathname;
 326                          b.default_was_region = "1"b;
 327                          the_buffer.region_final_lth = the_buffer.region_initial_lth;
 328                     end;
 329                end;
 330 
 331                else do;                                     /* read/write from the specified file */
 332                     if the_buffer.buffer_pathname = "" then do;
 333                          call sub_err_ (error_table_$inconsistent, QEDX_, ACTION_CANT_RESTART, null (), 0,
 334                               "Default pathname not specified for buffer ^a.", the_buffer.buffer_name);
 335                          P_code = error_table_$fatal_error;
 336                          go to RETURN_FROM_QEDX_;
 337                     end;
 338                     else do;                                /* ... and there is a pathname given */
 339                          a_real_file = "1"b;
 340                          the_pathname = the_buffer.buffer_pathname;
 341                          b.default_was_region = "0"b;
 342                     end;
 343                end;
 344 
 345                fle = ife;                                   /* put it at the end (of the empty buffer) */
 346                if ^perform_read (a_real_file, the_pathname, "1"b) then do;
 347                     P_code = error_table_$fatal_error;      /* ... didn't work (sigh) */
 348                     go to RETURN_FROM_QEDX_;
 349                end;
 350 
 351                if qedx_info.version = QEDX_INFO_VERSION_1 then
 352                     b.default_locked = the_buffer.locked_pathname;
 353                else b.default_locked = ^the_buffer.locked_pathname;
 354                                                             /* version 0 structure: this flag had the opposite meaning */
 355 
 356                call save_buffer_state ();                   /* save it */
 357           end;
 358 
 359 
 360 /* Initialize everything else ... */
 361 
 362           pi_sw = "0"b;                                     /* set switch to ignore program interrupts */
 363 
 364           if sys_info$service_system then on condition (program_interrupt) call interrupt ();
 365                                                             /* establish handler for program interrupt */
 366           else on condition (sub_request_abort_) call interrupt ();
 367                                                             /* establish handler for request abort */
 368 
 369           tp = addr (iline);                                /* initialize pointer to input line buffer */
 370           substr (iline, 1, 3) = "b0 ";                     /* move to buffer zero */
 371           te = 3;
 372 
 373           do buffer_idx = 1 to qedx_info.n_buffers;         /* insure we execute all request buffers */
 374                the_buffer_ptr = addr (qedx_info.buffers (buffer_idx));
 375                if the_buffer.execute_buffer then do;
 376                     if (te + length ("\b() ") + length (rtrim (the_buffer.buffer_name))) > length (iline) then do;
 377                          call com_err_ (error_table_$bigarg, qid.editor_name, "Preparing to execute buffer ^a.",
 378                               the_buffer.buffer_name);
 379                          P_code = error_table_$fatal_error;
 380                          go to RETURN_FROM_QEDX_;
 381                     end;
 382                     substr (iline, (te + 1), (length ("\b() ") + length (rtrim (the_buffer.buffer_name)))) =
 383                          "\b(" || rtrim (the_buffer.buffer_name) || ") ";
 384                     te = te + length ("\b() ") + length (rtrim (the_buffer.buffer_name));
 385                end;
 386           end;
 387 
 388           substr (iline, te, 1) = NL;                       /* makes sure initial requests are executed properly */
 389 
 390           call edx_util_$prime (qid_ptr, tp, te);           /* prime input stream to read in and execute macro */
 391 %page;
 392 /*                  **** Start of working Code ****
 393 
 394 
 395    qedx returns here to process each new command line, from either the
 396    macro file, or the terminal,  if qedx is executing multiple commands from
 397    a single line, re-entry is made to the label next:, rather than nx_line:.
 398 
 399    At this point the basic command is cracked and addressing is determined. */
 400 
 401 
 402 nx_line:
 403           ti = 1;                                           /* read next request line from input stream */
 404           call edx_util_$read_ptr (qid_ptr, tp, length (iline), te);
 405 
 406 next:
 407           if ^sys_info$service_system then do;
 408                intsw = "0"b;
 409                call bce_check_abort;
 410                if intsw = "1"b then go to RETURN_FROM_QEDX_;
 411           end;
 412           call save_buffer_state ();                        /* save current buffer state */
 413           if ti >= te then go to nx_line;                   /* check after each request if request line exhausted */
 414           intsw = "0"b;                                     /* reset previous program_interrupt (if any) */
 415 
 416           call get_addr_ (qid_ptr, tp, ti, te, ifp, ilb, ift, ife, li, le, fli, fle, code);
 417                                                             /* find first address if any */
 418           if code = 0 then flsw, llsw = "0"b;               /* code = 0, no address found (use default) */
 419           else if code = 1 then do;                         /* code = 1, */
 420                flsw = "1"b;                                 /* single address found, */
 421                llsw = "0"b;                                 /* use default for second address if needed */
 422           end;
 423           else if code < 4 then do;                         /* code 2 or 3, */
 424                flsw, llsw = "1"b;                           /* both addresses found */
 425                if code = 2 then
 426                     call get_addr_ (qid_ptr, tp, ti, te, ifp, ilb, ift, ife, li, le, lli, lle, code);
 427                                                             /* code 2 = "," */
 428                else call get_addr_ (qid_ptr, tp, ti, te, ifp, ilb, ift, ife, fli, fle, lli, lle, code);
 429                                                             /* code 3 = ";" */
 430                if code = 4 then go to reg_err;              /* check for failure to match on regular expression */
 431                if code > 4 then go to rq_err;               /* check for other error */
 432           end;
 433           else if code = 4 then do;                         /* code = 4, */
 434 reg_err:
 435                call edx_util_$end_buffer (qid_ptr, code);   /* failure to match reg. expression, pop buffer stack */
 436                if code ^= 0 then do;                        /* if already at highest buffer level (0) */
 437                     call ioa_ ("Search failed.");           /* print error message */
 438                     go to rq_err;                           /* treat as normal error */
 439                end;
 440                else go to nx_line;                          /* resume input from next higher level */
 441           end;
 442           else if code > 4 then do;                         /* code > 4, error detected in get_addr_ */
 443 rq_err:
 444                call edx_util_$resetread (qid_ptr);          /* reset buffer push down stack and tw input buffer */
 445                go to nx_line;                               /* read next line from console typewriter (level=0) */
 446           end;
 447 
 448           ch = t.c (ti);                                    /* pick up first character after address */
 449           ti = ti + 1;                                      /* bump request line character index */
 450           if ch = NL then                                   /* check for new-line character */
 451                if flsw then
 452                     go to print1;                           /* print line pointed to by "." if address found */
 453                else go to nx_line;                          /* otherwise, ignore NL and read next request line */
 454           command_index = index (COMMANDS, ch);             /* which command given */
 455           pi_label = ACTION (0);                            /* assume we will be an error */
 456           go to ACTION (command_index);                     /* go do it */
 457 
 458 ACTION (0):                                                 /* here if unrecognized */
 459           call ioa_ ("^a: ^a not recognized as a request.", qid.editor_name, ch);
 460                                                             /* here if request not understood */
 461           go to rq_err;                                     /* treat as any other error */
 462 %page;
 463 /*    **** read request ****
 464 
 465    Read in specified file after addressed line in current buffer file.
 466 
 467    Current line is left at the end of the readin section.
 468 
 469    Operation is performed by splitting the buffer under where the readin should
 470    occur and reading appending to the bottom of the top section.
 471    This leaves the gap below the readin section, which is where it will tend to
 472    speed initial editing commands on the readin section.
 473 */
 474 
 475 ACTION (9):
 476 read:
 477           call determine_file ("0"b, a_real_file, the_pathname, explicit_pathname);
 478 
 479           if ^flsw then fle = ife;                          /* no address: append to end of file */
 480 
 481           if perform_read (a_real_file, the_pathname, explicit_pathname) then
 482                go to nx_line;                               /* successfull read */
 483           else go to rq_err;
 484 %page;
 485 /*    **** write request ****
 486 
 487    Write out the specified contents of the current buffer into the spec file.
 488 
 489    This operation is done without gap movement by calculating if the data is
 490    split across the gap, or entirely contained within either the top or bottom
 491    sections of the buffer.  If the data is contiguous, then a single substr is
 492    used, otherwise the section within the bottom, and the section within the
 493    top are separately written, with the top write appended on the bottom.
 494 
 495    The current line position is not altered by writing.
 496 */
 497 
 498 ACTION (10):
 499 write:
 500           call defaults (1, ife);                           /* supply default addresses (1,$) if necessary */
 501           pi_label = wr_quit;                               /* in case of quit */
 502           pi_sw = "1"b;                                     /* activate quit handler and label */
 503 
 504           call determine_file ("1"b, a_real_file, the_pathname, explicit_pathname);
 505                                                             /* firgure out where it goes */
 506 
 507           if ^perform_write (a_real_file, the_pathname, explicit_pathname, "1"b) then go to rq_err;
 508                                                             /* didn't work */
 509 
 510 wr_quit:
 511           pi_sw = "0"b;                                     /* turn of pi handler */
 512           go to nx_line;                                    /* go pick up next qedx request line */
 513 %page;
 514 /* * * * * quit request .......... clean up and exit from qedx editor (i.e., return to caller) * * * * * * * * */
 515 
 516 ACTION (19):                                                /* Q request: don't worry about modified buffers */
 517           quit_force_sw = "1"b;
 518           go to DO_QUIT_REQUEST;
 519 
 520 ACTION (11):                                                /* q/qf request */
 521           if t.c (ti) = "f" then do;                        /* ... it's qf: don't worry about modified buffers */
 522                quit_force_sw = "1"b;
 523                ti = ti + 1;
 524           end;
 525           else quit_force_sw = "0"b;                        /* ... it's q: may query if modified buffers exist */
 526 
 527 DO_QUIT_REQUEST:
 528           if (flsw) then do;  /* special syntax check for quit request */
 529                call ioa_ ("Syntax error in quit request.");
 530                go to rq_err;
 531           end;
 532           /* Bug_204 : Ignore trailing whitespace after a quit request */
 533           if (t.c (ti) ^= NL) then do;
 534                ti = ti + verify (substr (iline, ti), "      ") - 1;
 535                if (t.c (ti) ^= NL) then do;
 536                   call ioa_ ("Syntax error in quit request.");
 537                   go to rq_err;
 538                end;
 539           end;
 540 
 541 
 542 /* Check for modified buffers if caller so desires */
 543 
 544           if qid.query_if_modified & ^quit_force_sw then    /* ... but only if user doesn't want out */
 545                if edx_util_$modified_buffers (qid_ptr) then do;
 546 
 547                     if sys_info$service_system then
 548                          call user_info_$process_type (process_type);
 549                     else process_type = 1;
 550                     if process_type = 1 then do;            /* ... and only if interactive */
 551                          call ioa_$ioa_switch (error_sw, "Modified buffers exist:");
 552                          call edx_util_$list_modified_buffers (qid_ptr, (b.name), error_sw);
 553 
 554                          if sys_info$service_system then
 555                               call command_query_$yes_no (yes_sw, 0, qid.editor_name, MODIFIED_BUFFERS_EXPLANATION,
 556                                    "Do you still wish to quit and lose these changes?");
 557                          else call bce_query$yes_no (yes_sw, MODIFIED_BUFFERS_EXPLANATION);
 558                          if yes_sw then                     /* ... is equivalent to using Q */
 559                               quit_force_sw = "1"b;
 560                          else go to rq_err;                 /* ... no: back to request loop */
 561                     end;
 562                end;
 563 
 564           if quit_force_sw then go to SET_OUTPUT_VALUES;    /* quit force: don't update anything requesting auto_write */
 565 
 566 
 567 /* Update any buffers with auto-write and query if there are truncated buffers */
 568 
 569           saved_current_buffer = b.name;                    /* in case user doesn't want to quit */
 570           call save_buffer_state ();
 571 
 572           have_truncated_buffers = "0"b;                    /* need this locally */
 573 
 574           do buffer_idx = 1 to qedx_info.n_buffers;
 575                the_buffer_ptr = addr (qedx_info.buffers (buffer_idx));
 576                call edx_util_$locate_buffer (qid_ptr, the_buffer.buffer_name, bp);
 577                call get_buffer_state (bp);                  /* switch buffers */
 578 
 579                if the_buffer.read_write_region then do;     /* check this buffer and/or write it */
 580 
 581                     if the_buffer.auto_write then do;       /* ... write it */
 582                          fli = 1;                           /* ... ... setup to write entire buffer */
 583                          lle = ife;
 584                          ignore_result = perform_write ("0"b, "", "0"b, "0"b);
 585                     end;                                    /* put it back without error messages */
 586 
 587                     if the_buffer.region_final_lth > the_buffer.region_max_lth then do;
 588                          if ^have_truncated_buffers then do;/* ... first truncated buffer */
 589                               call ioa_$ioa_switch (error_sw, "Buffers which will be truncated:");
 590                               have_truncated_buffers = "1"b;
 591                          end;
 592                          call edx_util_$list_single_buffer (qid_ptr, saved_current_buffer, output_sw, bp);
 593                     end;
 594                end;
 595           end;
 596 
 597           if have_truncated_buffers then do;                /* need permission for this ... */
 598                if sys_info$service_system then
 599                     call command_query_$yes_no (yes_sw, 0, qid.editor_name, TRUNCATED_BUFFERS_EXPLANATION,
 600                          "Do you still wish to quit?");
 601                else call bce_query$yes_no (yes_sw, TRUNCATED_BUFFERS_EXPLANATION);
 602                if ^yes_sw then do;                          /* ... user got scared */
 603                     call edx_util_$locate_buffer (qid_ptr, saved_current_buffer, bp);
 604                     call get_buffer_state (bp);             /* ... back to where user thinks he is */
 605                     go to rq_err;
 606                end;
 607           end;
 608 
 609 
 610 /* Set output parameters in query_info structure and P_code */
 611 
 612 SET_OUTPUT_VALUES:
 613           qedx_info.quit_forced = quit_force_sw;            /* let caller know */
 614           qedx_info.buffers_truncated = "0"b;               /* until following check proves otherwise */
 615 
 616           do buffer_idx = 1 to qedx_info.n_buffers;
 617                the_buffer_ptr = addr (qedx_info.buffers (buffer_idx));
 618                if the_buffer.read_write_region then         /* ... only check those not using a file */
 619                     if the_buffer.region_final_lth > the_buffer.region_max_lth then
 620                          qedx_info.buffers_truncated, the_buffer.truncated = "1"b;
 621           end;
 622 
 623           if qedx_info.quit_forced | qedx_info.buffers_truncated then
 624                P_code = error_table_$recoverable_error;     /* caller beware */
 625           else P_code = 0;
 626 
 627 
 628 /* Control arrives here when it is time to exit qedx (with P_code already set) */
 629 
 630 RETURN_FROM_QEDX_:
 631           call cleanup_invocation_data ();
 632 
 633           return;
 634 %page;
 635 /*     **** Print value of current addressed line ****
 636 
 637    This entry is used to print a line from a single address, such as dot, relative
 638    or absolute.  The line addressed by lli,lle is printed.  New input line is
 639    forced by mating ti and te. */
 640 
 641 print1:
 642           ti = te;                                          /* force nx_line call through next label */
 643 
 644 /*    **** print request  print out specified portion of current buffer ****
 645 
 646    This code is directly the same as used in write, with the character stream
 647    going to the terminal, rather than the output file. */
 648 
 649 ACTION (1):
 650 print:
 651           call defaults (li, le);                           /* supply default addresses (.,.) if necessary */
 652           pi_label = end_pr;                                /* allow printing to be aborted */
 653           pi_sw = "1"b;                                     /* by means of a program interrupt */
 654           if lle <= ilb | fli >= ift then do;               /* portion addressed is purely in bottom or top */
 655                i = lle - fli + 1;
 656                call output_routine (output_sw, addr (ifp -> f.c (fli)), i, code);
 657           end;                                              /* print specified portion of buffer on user's console */
 658           else if fli <= ilb then do;                       /* top in top, bottom in bottom */
 659                i = lle - ift + 1 + ilb - fli;
 660                call output_routine (output_sw, addr (ifp -> f.c (fli)), ilb - fli + 1, code);
 661                                                             /* print specified portion of buffer on user's console */
 662                call output_routine (output_sw, addr (ifp -> f.c (ift)), lle - ift + 1, code);
 663                                                             /* print specified portion of buffer on user's console */
 664           end;
 665           pi_sw = "0"b;                                     /* turn off program interrupt handling */
 666 end_pr:
 667           call last_line (lle);                             /* set current line to last line printed */
 668           go to next;                                       /* go pick up next qedx request */
 669 %page;
 670 /*     **** delete request    delete specified lines from current buffer *** */
 671 
 672 ACTION (6):
 673 delete:
 674           call defaults (li, le);                           /* supply default addresses (.,.) if necessary */
 675           call delete_text ();                              /* flush the text */
 676           call next_line (ift);                             /* reposition at line after last line deleted (if any) */
 677           b.modified = "1"b;                                /*  deletion is a modification */
 678           go to next;                                       /* get next qedx request */
 679 
 680 
 681 
 682 /* Actually deletes text (used also by the change request) */
 683 
 684 delete_text:
 685      procedure ();
 686 
 687 /* deletion is done to make gap movement minimized.  Three situations are
 688    considered.
 689    1.  Bottom of range is above gap.  Then only undeleted chars are moved and
 690    ift is moved to delete.
 691    2.  Top of range is below gap.  Then only undeleted chars are moved and
 692    ilb is moved down to delete.
 693    3.  Range spans gap.  The ift and ilb are updated and fli -> ift.
 694 */
 695 
 696           if lle <= ilb then do;                            /* move chars up til end of range */
 697                call open_gap (lle);
 698                ilb = fli - 1;                               /* set lower bound of delete */
 699           end;
 700           else if fli >= ift then do;                       /* move chars down from bottom of range */
 701                call open_gap ((fli - 1));                   /* open gap in front of section to delete */
 702                ift = lle + 1;                               /* set upper bound of delete */
 703           end;
 704           else do;                                          /* range spans gap */
 705                ilb = fli - 1;                               /* delete lower end */
 706                ift = lle + 1;                               /* delete upper end */
 707                fli = ift;                                   /* clear range */
 708           end;
 709 
 710           return;
 711 
 712      end delete_text;
 713 %page;
 714 /*     **** append, insert or change request, append after, insert before or replace addressed text. ****
 715 
 716    All actions are performed by calculating a split point for the buffer and
 717    then opening the gap at that point.  For change, one also moves the
 718    lower section top pointer to delete text before reading in the new
 719    text.
 720 
 721    Space allocation for reading of new text is done by input calling
 722    for possible buffer promotion prior to each line of input being moved from
 723    the working line buffer, to the temporary file buffer.
 724 
 725    The current line position is left at the last line input.
 726 */
 727 
 728 ACTION (3):                                                 /* append text after addressed line */
 729 append:
 730           if ^flsw |                                        /* if no address given or */
 731                fle > ife then                               /* addres is "." and buffer empty then */
 732                fle = le;                                    /* append after current line */
 733           call open_gap ((fle));                            /* open gap after current line */
 734           go to in_mode;                                    /* join common console input code */
 735 
 736 ACTION (4):                                                 /* insert text before addressed line */
 737 insert:
 738           if ^flsw then fli = li;                           /* insert before current line if no address given */
 739           fle = fli - 1;                                    /* back up one line (.-1) */
 740           call open_gap ((fle));                            /* open the gap before the current line */
 741           go to in_mode;                                    /* join common console input code */
 742 
 743 ACTION (5):                                                 /* replace addressed lines with input from console */
 744 change:
 745           call defaults (li, le);
 746           call delete_text ();                              /* get rid of the old text */
 747           b.modified = "1"b;                                /* buffer is modified even if nothing is input here */
 748 
 749 
 750 in_mode:                                                    /* attempt to enter cheap input mode */
 751           if sys_info$service_system then do;
 752                new_modes = "wake_tbl";
 753                call iox_$modes (iox_$user_io, new_modes, old_modes, code);
 754           end;
 755 
 756           was_empty = (ilb < 1) & (ift > ife);              /* remember whether buffer was empty or not */
 757 
 758           pi_label = in_mode;                               /* setup recovery info for promote */
 759           call input (ifp, ilb);                            /* input from console, append to input buffer file */
 760           pi_label = nx_line;                               /* kill input flag to promote */
 761 
 762 /* If we have added a line which does not end in a newline then the gap spans
 763    within a line and violates standards.  Compact the line by finding the start
 764    and end of the last line entered and opening the gap before it.
 765 */
 766 
 767           call last_line (ilb);                             /* position at last line input from console */
 768           call open_gap ((li - 1));                         /* compact the possible split line */
 769           call next_line (li);                              /* find end of current line (may be across gap) */
 770 
 771           if sys_info$service_system then do;
 772                new_modes = "^wake_tbl";                     /* turn off cheap input */
 773                call iox_$modes (iox_$user_io, new_modes, old_modes, code);
 774           end;
 775 
 776           if was_empty then                                 /* if buffer was empty, can no longer trust default path */
 777                b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
 778 
 779           go to next;                                       /* get next qedx request */
 780 %page;
 781 /*     **** substitute request  s/string1/string2/ replaces all occurrences of string1 with string2 ****
 782 
 783    This operation is done through constant and non-standard buffer gap moves.
 784    This is the only operation in which the buffer gap would not be at a line
 785    boundary.  Moves are done as the scan through the line is done, with
 786    processed characters left in the bottom section and unprocessed
 787    characters in the top.  As processing continues characters move down to
 788    the bottom section.  This permits all additions to the buffer to be done
 789    by appending to the lower section, and deletions to be done by
 790    moving the top pointer of the bottom section, with the one exception
 791    being if the last substitution has been done such that fli>lle, then
 792    the lower pointer of the upper section is moved.  This is due to the
 793    action of the sdsw increment of fli to bypass the NL, and the requirement
 794    to delete immediately, since post deletion is not possible.
 795 
 796    Post deletion of text is used where the replacing string is null, or
 797    contains &'s.  In the case of null replacement the construct s/^.// would
 798    replace the entire line with null, unless post deletion was done.
 799    In the case of & replacement, we have to retain the original source matched
 800    by the & to replace, therefore post deletion is necessary.
 801    Otherwise immediate deletion is done to retain the ability to edit an
 802    entire segment.
 803 
 804    Post deletion of text is accomplished by setting up an ilb correction factor
 805    to be applied after the next qx_search_file_.  This is to prevent /^.// from
 806    matching all characters, since deletion immediately would result in the
 807    end of line moving up and being found again.  This post deletion requires
 808    substitute to always pass through a final qx_search_file_ which doesn't find
 809    the string.  When this occurs the correction is already done.  The exception
 810    is already noted above, and only occurs if fli is incremented when the
 811    string ended in *$.
 812 */
 813 
 814 ACTION (2):
 815           pi_label = sub_done;                              /* say we are a substitute */
 816 substitute:
 817           call defaults (li, le);                           /* provide default addresses in needed */
 818           delim = t.c (ti);                                 /* pick up string delimiter */
 819           intsw = "0"b;                                     /* trap interrupts in long substitutes */
 820           subsw = "0"b;                                     /* set switch for first string */
 821           sdsw = "0"b;                                      /* initiate star-dollar match switch */
 822 
 823           ilb_offset = 0;                                   /* no post-deletion needed */
 824 
 825           tik = ti + 1;                                     /* set index to first char of string1 */
 826           i = tik;                                          /* and hold it.  */
 827           sub_comp_string = delim || EC || "\";             /* set compare for  delim conceal two char conceal */
 828 
 829 sub_search:
 830           k = search (substr (tp -> a_string, tik, te - tik + 1), sub_comp_string);
 831                                                             /* search for delim or conceal char */
 832 
 833           if k = 0 then do;                                 /* syntax error -- no delimiter */
 834 sub_err:
 835                call ioa_ ("Syntax error in substitute request.");
 836                go to rq_err;
 837           end;
 838 
 839           kx = index (sub_comp_string, t.c (tik + k - 1));  /* which character was found? */
 840           go to sub_case (kx);                              /* process case found */
 841 
 842 sub_case (1):
 843           if ^subsw then do;                                /* working on first string */
 844                j = tik + k;                                 /* set index, first char string2 */
 845                il = j - 1 - i;                              /* save length of string1 */
 846                if substr (tp -> a_string, j - 3, 2) = "*$"  /* check last chars of string1 for star dollar */
 847                     then
 848                     if substr (tp -> a_string, j - 4, 1) ^= EC
 849                                                             /* check for conceal character */
 850                          then
 851                          if (substr (tp -> a_string, j - 5, 2)) ^= "\c" then
 852                               if (substr (tp -> a_string, j - 5, 2)) ^= "\C" then sdsw = "1"b;
 853                                                             /* found star dollar */
 854                tik = j;
 855                subsw = "1"b;                                /* working on second string, string2 */
 856                go to sub_search;
 857           end;
 858           else go to sub2;                                  /* found end of string2 */
 859 
 860 sub_case (2):
 861           if (ti + k) < te then do;                         /* is there a char after the concealed char? */
 862                tik = (tik + k) + 1;                         /* skip concealed char */
 863                go to sub_search;                            /* and continue scan  */
 864           end;
 865           else go to sub_err;                               /* no delimiter found */
 866 
 867 sub_case (3):
 868           if (tik + k) > te then go to sub_err;             /* there is no char after the escape, 134 */
 869           if (t.c (tik + k) = "C") | (t.c (tik + k) = "c")  /* is this conceal symbol */
 870                then
 871                if (tik + k) + 1 < te                        /* is more after concealed char */
 872                then do;
 873                     tik = tik + k + 2;                      /* start at next char */
 874                     go to sub_search;
 875                end;
 876                else go to sub_err;                          /* no delimiter */
 877           else do;                                          /* this was not a conceal symbol */
 878                tik = tik + k;                               /* search continues at next char */
 879                go to sub_search;
 880           end;
 881 
 882 sub2:
 883           ti = tik + k;                                     /* set index to next character after substitue request */
 884           je = tik + k - 2;                                 /* get index of last character in strin2 */
 885           call open_gap ((fli - 1));                        /* setup buffer for substitution */
 886 
 887           subsw = "0"b;                                     /* initialize switch to indicate nothing found yet */
 888 sub_loop:
 889           call qx_search_file_ (qid_ptr, tp, i, il, ifp, fli, lle, mi, me, ilb, ift, code);
 890                                                             /* try to match on string1 */
 891           ilb = ilb - ilb_offset;                           /* post-delete previous stuff */
 892           ilb_offset = 0;                                   /* and don't delete more til we are ready */
 893           if ^sys_info$service_system then call bce_check_abort;
 894           if intsw then do;                                 /* interrupt in substitution */
 895                call ioa_ ("^a: Interrupt during substitute, remainder unprocessed.", qid.editor_name);
 896                intsw = "0"b;
 897                goto sub_done;
 898           end;
 899 
 900           if code ^= 0 then goto sub_done;                  /* if nothing found, all done */
 901           ml = me - mi + 1;                                 /* otherwise, get length of string found */
 902           subsw = "1"b;                                     /* indicate something found */
 903           il = 0;                                           /* use canned regular expression next time thru */
 904           l = mi - fli;                                     /* copy buffer up to char(mi) */
 905           if l > 0 then                                     /* .. (if anything to copy) */
 906                fli = fli + l;                               /* set point of copy */
 907 
 908 /* ****   This is the only point at which the gap is part way through a line **** */
 909           call open_gap ((fli - 1));
 910 
 911           l = j;                                            /* set index to beginning of input string */
 912 sub_string_search:                                          /* search input string for special symbols */
 913           k = search (substr (tp -> a_string, l, je - l + 1), "&^Y\");
 914                                                             /* search for special symbol &, conceal = 031, "\" */
 915           if k = 0 then do;                                 /* no special symbols */
 916                if je >= j then                              /* only process if sub string not null */
 917                     if ml ^= 0 then do;
 918                          call promote ((je - l + 1 - ml));  /* make sure space exists */
 919                                                             /* Check here to prevent inadvertant deletion of matched string */
 920                          ift = ift + ml;                    /* immediate delete since no & present */
 921                          ml = -1;                           /* indicate already deleted */
 922                     end;
 923 
 924                saved_ift = ift;
 925                call promote ((je - l + 1));                 /* make sure space exists */
 926 
 927                substr (ifp -> a_string, ilb + 1, (je - l + 1)) = substr (tp -> a_string, l, (je - l + 1));
 928                                                             /* insert string */
 929                ilb = ilb + je - l + 1;                      /* update output buffer length */
 930                b.modified = "1"b;                           /* substitute is a modify */
 931                go to sub_next;                              /* see if more substitution */
 932           end;
 933 
 934           kx = index ("&^Y\", t.c (l + k - 1));             /* which one found/ */
 935           go to do_sub (kx);                                /* go process it */
 936 
 937 do_sub (1):                                                 /* found &, insert matched string here */
 938           if k > 1 then do;                                 /* input non special chars before special */
 939                call promote ((k - 1));                      /* ensure space exists */
 940                substr (ifp -> a_string, ilb + 1, k - 1) = substr (tp -> a_string, l, k - 1);
 941                                                             /* copy nonspecial chars */
 942                ilb = ilb + k - 1;                           /* update output coount */
 943                b.modified = "1"b;                           /* substitute is a modify */
 944           end;
 945 
 946 /* Insertion of the original matched text is done by copying from the top
 947    to the bottom sections.  This permits multiple inclusions of text.  This
 948    operation is safe since data is moved from the top to the
 949    bottom, and buffer promotion ensures that the gap is big enough to
 950    prevent overlap. */
 951           if ml > 0 then do;                                /* length of matched string */
 952                call promote ((ml));                         /* ensure space exists */
 953                substr (ifp -> a_string, ilb + 1, ml) = substr (ifp -> a_string, mi, ml);
 954                                                             /* copy section */
 955                ilb = ilb + ml;                              /* update end of bottom */
 956                b.modified = "1"b;                           /* substitute is a modify */
 957           end;
 958 
 959           l = l + k;                                        /* update index into input string */
 960 
 961           go to sub_string_search;                          /* and continue search */
 962 
 963 do_sub (2):                                                 /* found conceal character 031 */
 964           ka = 0;                                           /* single character conceal symbol */
 965 do_sub_conceal:                                             /* append string to here plus concealed character */
 966           call promote ((k));                               /* ensure space exists */
 967           substr (ifp -> a_string, ilb + 1, k) = substr (tp -> a_string, l, k - 1) || t.c (l + k + ka);
 968           ilb = ilb + k;                                    /* update output string index */
 969           b.modified = "1"b;                                /* substitute is a modify */
 970           l = l + k + ka + 1;                               /* update input string index */
 971           go to sub_string_search;                          /* and continue search */
 972 
 973 do_sub (3):                                                 /* found "\" so check for following "c" */
 974           if (t.c (k + l) = "C") | (t.c (k + l) = "c") then do;
 975                                                             /* if two character conceal symbol */
 976                ka = 1;                                      /* then set special character counter */
 977                go to do_sub_conceal;                        /* found two character conceal symbol */
 978           end;
 979           else do;                                          /* some other character */
 980                call promote ((k));                          /* ensure space exists */
 981                substr (ifp -> a_string, ilb + 1, k) = substr (tp -> a_string, l, k);
 982                                                             /* copy up to and including "\" */
 983                ilb = ilb + k;                               /* update output buffer index */
 984                b.modified = "1"b;                           /* substitute is a modify */
 985                l = l + k;                                   /* set input index */
 986                go to sub_string_search;                     /* and continue search */
 987           end;
 988 
 989 sub_next:
 990           if ml = 0 then                                    /* if matched string was null */
 991                fli = fli + 1;                               /* ensure we find a different null string next time */
 992           else do;                                          /* if matched string not null, resume search */
 993                fli = me + 1;                                /* set index after last matched character */
 994                if sdsw                                      /* for star dollar match, step over new line. */
 995                     then
 996                     fli = fli + 1;                          /* update search index */
 997                if ml < 0 then ilb_offset = 0;
 998                else if fli > lle then ift = ift + ml;       /* delete text if we will quit */
 999                else ilb_offset = ml;                        /* post-delete matched section from buffer */
1000           end;
1001 
1002 /* This gap opening is necessary due to post-deletion.  If we opened the
1003    gap purely at fli-1 then .*$ would cause us to post-delete the 'NL'.
1004    By opening the gap at the end of the matched string everything
1005    is okay. */
1006 
1007           if sdsw then                                      /* Check if fli is overstepped */
1008                call open_gap ((fli - 2));
1009           else call open_gap ((fli - 1));
1010           if fli <= lle then go to sub_loop;                /* until end of addressed portion of buffer reached */
1011 sub_done:
1012           call last_line (min (fli, lle));                  /* find start of this line */
1013           call open_gap ((li - 1));                         /* fixup gap to line boundary */
1014           call next_line (lle);                             /* set current line to end of range */
1015 
1016 /* The following call to last_line is necessary to find the true beginning
1017    of the current line, since last_line and next_line both set the other end
1018    of the line, one must have at least one of them supplied with a true end.
1019    The above next_line truely sets up the end of the line, the following
1020    last_line truely sets up the beginning. */
1021 
1022           call last_line (le);
1023 
1024 /* **** After this point buffer is again following line gap standards **** */
1025 
1026           if ^subsw then do;                                /* error if nothing found */
1027                call edx_util_$end_buffer (qid_ptr, code);   /* attempt to pop buffer recursion stack */
1028                if code = 0 then go to nx_line;              /* and continue execution in calling buffer */
1029 
1030                call ioa_ ("Substitution failed.");          /* print error message if at recursion level 0 */
1031                go to rq_err;                                /* and treat as normal error */
1032           end;
1033           else go to next;                                  /* go pick up next request */
1034 %page;
1035 /* * * * *  execute request ... pass remainder of line to command processor (i.e. escape to command system) * */
1036 
1037 ACTION (15):
1038 execute:
1039           substr (tp -> a_string, 1, (ti - 1)) = " ";       /* blank out preceding portion of request line */
1040           pi_label = nx_line;                               /* allow command to be aborted */
1041           if sys_info$service_system then do;
1042                pi_sw = "1"b;                                /* by means of a program interrupt */
1043                call cu_$cp (tp, te, code);                  /* pass request line to command processor */
1044                pi_sw = "0"b;                                /* disable program interrupt upon return */
1045           end;
1046           else call ioa_ ("^a: Escape to command level not allowed.", qid.editor_name);
1047           go to nx_line;                                    /* get fresh request line from input stream */
1048 
1049 
1050 
1051 /* * * * * buffer request ..... change working buffer after saving status of current buffer * * * * * * * * * */
1052 
1053 ACTION (7):
1054 buffer:
1055           call save_buffer_state ();                        /* save previous buffer's state */
1056           call edx_util_$get_buffer (qid_ptr, tp, ti, te, tname, tbp);
1057                                                             /* pick up pointer to control block of new buffer */
1058           if tbp = null then go to rq_err;
1059           call get_buffer_state (tbp);                      /* instantiate new one */
1060           go to next;
1061 %page;
1062 /*     **** move request   move addressed lines from current buffer into auxilliary buffer ****
1063 
1064    This move is directly borrowed from write, and print.  It does not alter the
1065    current line, or move the gap. */
1066 
1067 ACTION (8):
1068 move:
1069           call defaults (li, le);                           /* provide default addresses in needed */
1070           call edx_util_$get_buffer (qid_ptr, tp, ti, te, tname, tbp);
1071                                                             /* get pointer to control block of specified buffer */
1072           if tbp = null then go to rq_err;
1073           fp = tbp -> b.dp;                                 /* get pointer to buffer file */
1074           if lle <= ilb | fli >= ift then do;               /* portion addressed is purely in bottom or top */
1075                fe = lle - fli + 1;
1076                if fe > sys_info$max_seg_size * 4 then do;
1077 move_overflow:
1078                     call ioa_ ("^a: Buffer full!! Move not performed.", qid.editor_name);
1079                     goto rq_err;
1080                end;
1081                substr (fp -> a_string, 1, fe) = substr (ifp -> a_string, fli, fe);
1082                                                             /* copy specified portion of buffer into new buffer */
1083           end;
1084           else if fli <= ilb then do;                       /* top in top, bottom in bottom */
1085                fe = lle - ift + 1 + ilb - fli + 1;
1086                if fe > sys_info$max_seg_size * 4 then goto move_overflow;
1087                substr (fp -> a_string, 1, ilb - fli + 1) = substr (ifp -> a_string, fli, ilb - fli + 1);
1088                substr (fp -> a_string, ilb - fli + 2, lle - ift + 1) = substr (ifp -> a_string, ift, lle - ift + 1);
1089           end;
1090           if fe < 4 * 4 * 1024 then i = 4 * 4 * 1024;
1091           else if fe < 16 * 4 * 1024 then i = 16 * 4 * 1024;
1092           else if fe < 64 * 4 * 1024 then i = 64 * 4 * 1024;
1093           else i = 255 * 4 * 1024;
1094           i = min (i, sys_info$max_seg_size * 4);
1095 
1096           tbp -> b.lb = fe;
1097           tbp -> b.de = i;                                  /* update buffer status */
1098           tbp -> b.ft = i + 1;                              /* upper buffer is empty */
1099           tbp -> b.li = 1;                                  /* .. */
1100           tbp -> b.le = index (substr (fp -> a_string, 1, fe), NL);
1101           if tbp -> b.le = 0 then tbp -> b.le = fe;         /* set to last line */
1102           if tbp -> b.le = 0 then tbp -> b.le = ilb;        /* if no new line then set to end of buffer */
1103           tbp -> b.modified = "1"b;                         /* target buffer is now modified */
1104           tbp -> b.default_untrusted = ^tbp -> b.default_locked & (tbp -> b.default_path ^= "");
1105                                                             /* target's pathname is no longer trusted */
1106           go to delete;                                     /* now delete addressed lines from current buffer */
1107 %page;
1108 /* * * * * status ("x") request ..... list status of all buffers (current and auxiliary) * * * * * * * * * * * */
1109 
1110 ACTION (14):
1111 status:
1112           call save_buffer_state ();
1113           call edx_util_$list_buffers (qid_ptr, curbuf, output_sw);
1114           go to next;                                       /* and go pick up next qedx request */
1115 %page;
1116 /*     **** print current line number ("=") request   prints out line number of current line in buffer ****
1117 
1118    This is one of the grottier pieces of code, not due to poor coding, but due
1119    to poor design for a paging system.  = must read the entire temp file, and
1120    count line feeds until the current character index of the current line is
1121    reached.  The modifications done here are entirely to account for the gap in
1122    the middle of the buffer. */
1123 
1124 ACTION (13):
1125 cur_line:
1126           call defaults (li, le);                           /* provide default addresses if necessary */
1127           call last_line (lle);                             /* set current line to addressed line */
1128           if ifp -> f.c (lle) = NL then
1129                j = 0;                                       /* watch out for last line with no new-line character */
1130           else j = 1;                                       /* .. */
1131           i = 1;                                            /* start with first character */
1132           do while (i <= lle);                              /* up to last character of current line */
1133                if i > ilb & i < ift then i = ift;           /* fixup gap entry */
1134 retry_top:
1135                if i >= ift then
1136                     k = index (substr (ifp -> a_string, i, lle - i + 1), NL);
1137                                                             /* find a new line */
1138                else do;
1139                     k = index (substr (ifp -> a_string, i, ilb - i + 1), NL);
1140                                                             /* find a new line */
1141                     if k = 0 & ift <= ife then do;          /* move to upper and continue line */
1142                          i = ift;
1143                          goto retry_top;
1144                     end;
1145                end;
1146                if k = 0 then
1147                     i = lle + 1;                            /* done */
1148                else j = j + 1;                              /* add to count of new lines */
1149                i = i + k;                                   /* start with next character  */
1150           end;
1151           call ioa_ ("^d", j);                              /* print out line number */
1152           go to next;                                       /* get next qedx request */
1153 %page;
1154 /*     **** global/exclude request  repeat given request for lines containing (or not containing) reg. exp ****
1155 
1156    This command may move the gap, for deletion, if it finds a line which must
1157    be deleted.  At this point the gap will be opened below the next
1158    line to be processed.  This means all operations will execute on a
1159    contiguous buffer.  Deletion is done simply by moving the ift pointer up to
1160    indicate that the line no longer exists in the buffer. */
1161 
1162 ACTION (16):
1163 exclude:
1164           xsw = "1"b;                                       /* exclude request */
1165           go to gb1;                                        /* set switch and join common code */
1166 
1167 ACTION (12):
1168 global:
1169           xsw = "0"b;                                       /* global request */
1170 gb1:
1171           call defaults (1, ife);                           /* provide default addresses (1,$) if necessary */
1172           if ti > te then go to gb_err;                     /* error if nothing follows g or v request */
1173           ch = t.c (ti);                                    /* get request following global request */
1174           if ch ^= "p" then
1175                if ch ^= "d" then
1176                     if ch ^= "=" then do;                   /* check for valid global request */
1177 gb_err:
1178                          call ioa_ ("Syntax error in global request.");
1179                          go to rq_err;
1180                     end;
1181           delim = t.c (ti + 1);                             /* pick up regular expression delimiter */
1182           i = ti + 2;                                       /* get index of first character of regular expression */
1183           do ti = i to te;                                  /* find end of regular expression */
1184                cht = t.c (ti);                              /* pickup one character */
1185                if cht = delim then go to gb2;               /* found end of string */
1186                else if cht = EC then ti = ti + 1;           /* escape in one character */
1187                else if cht = "\" then
1188                     if ti < te then
1189                          if (t.c (ti + 1) = "C") | (t.c (ti + 1) = "c") then ti = ti + 2;
1190                                                             /* ... */
1191           end;
1192           go to gb_err;                                     /* error if end cannot be found */
1193 
1194 gb2:
1195           il = ti - i;                                      /* get length of regular expression */
1196           ti = ti + 1;                                      /* leave request line index pointing to next character */
1197           l = 0;                                            /* initialize line counter */
1198           if ch ^= "=" then go to gb_loop;                  /* count lines only for "=" request */
1199           do j = 1 to (fli - 1);                            /* for "=" request up to starting line number */
1200                if j > ilb & j < ift then j = ift;           /* move across gap */
1201                if j <= fli - 1 then
1202                     if ifp -> f.c (j) = NL then l = l + 1;  /* .. */
1203           end;
1204 gb_loop:
1205           l = l + 1;                                        /* increment line counter */
1206           if fli > ilb & fli < ift then fli = ift;          /* move across gap */
1207           if fli > lle then goto gb_quit;
1208           le = index (substr (ifp -> a_string, fli, (lle - fli + 1)), NL);
1209                                                             /* find end of next line */
1210           if le = 0 then
1211                le = lle;                                    /* worry about no new-line at end of buffer */
1212           else le = fli + le - 1;                           /* get index of end of line (NL character) */
1213           call qx_search_file_ (qid_ptr, tp, i, il, ifp, fli, le, mi, me, ilb, ift, code);
1214                                                             /* search line for regular expression */
1215           if code > 1 then go to gb_quit;                   /* bad regular expression */
1216           il = 0;                                           /* null regular expression to form // */
1217           if xsw then
1218                if code ^= 0 then go to gb_test;             /* check for match on exclude request */
1219           if ^xsw then
1220                if code = 0 then go to gb_test;              /* check for match on global request */
1221           fli = le + 1;                                     /* no match (global or exclude) skip to next line */
1222           go to gb_end;                                     /* .. */
1223 
1224 gb_test:
1225           if ch = "p" then do;                              /* match found, check for global print (p) request */
1226                j = le - fli + 1;                            /* compute number of characters in line to print */
1227                pi_label = gb_quit;                          /* in case of a quit */
1228                pi_sw = "1"b;                                /* activate the label */
1229                call output_routine (output_sw, addr (ifp -> f.c (fli)), j, code);
1230                                                             /* print line */
1231                pi_sw = "0"b;                                /* disable the label */
1232                fli = le + 1;                                /* move to next line */
1233                if ^sys_info$service_system then call bce_check_abort;
1234                if intsw then go to gb_quit;                 /* abort request if program interrupt has occurred */
1235           end;
1236           else if ch = "d" then do;                         /* check for global delete (d) request */
1237                call open_gap ((fli - 1));                   /* open gap below delete point */
1238                ift = le + 1;                                /* start of good text */
1239                fli = ift;                                   /* move up index */
1240                b.modified = "1"b;                           /* deletion is a modification */
1241                if ^sys_info$service_system then call bce_check_abort;
1242                if intsw then go to gb_quit;                 /* abort request if program interrupt has occurred */
1243           end;
1244           else if ch = "=" then do;                         /* check for global "=" request (print line number) */
1245                call ioa_ ("^d", l);                         /* print line number */
1246                fli = le + 1;                                /* move to next line */
1247                if ^sys_info$service_system then call bce_check_abort;
1248                if intsw then go to gb_quit;                 /* abort request if program interrupt has occurred */
1249           end;
1250 gb_end:
1251           if fli <= lle then go to gb_loop;                 /* check for last line processed */
1252 gb_quit:
1253           if ch = "p" then call ioa_ ("");
1254           call last_line (lle);                             /* when done, leave current line at last line processed */
1255           go to next;                                       /* and pick up next qedx request */
1256 %page;
1257 /* * * * * null request .......... change value of "." and get next request from input line */
1258 
1259 ACTION (17):
1260 nullrq:
1261           if ^flsw then go to next;                         /* ignore request if no address given */
1262           call defaults (li, le);                           /* provide default addresses if necessary */
1263           call last_line (lle);                             /* change "." to last line addressed */
1264           go to next;
1265 
1266 
1267 /* * * * * comment delimiter (") found ..... change value of "." to last line addressed and ignore rest of line */
1268 
1269 ACTION (18):
1270 comment:
1271           if ^flsw then go to nx_line;                      /* ignore completely if no address given */
1272           call defaults (li, le);                           /* provide default addresses if necessary */
1273           call last_line (lle);                             /* change "." to last line addressed */
1274           go to nx_line;                                    /* ignore remainder of this request line */
1275 %page;
1276 /* * * * * * * * * * * * * * * * * * * *     INTERNAL PROCEDURES     * * * * * * * * * * * * * * * * * * * */
1277 
1278 /* Cleans up the data structures used by this invocation of qedx_ */
1279 
1280 cleanup_invocation_data:
1281      procedure ();
1282 
1283           if callers_io_region_ptr ^= null () then do;
1284                call release_temp_segment_ (qid.editor_name, callers_io_region_ptr, (0));
1285                callers_io_region_ptr = null ();
1286           end;
1287 
1288           call edx_util_$edx_cleanup (qid_ptr);
1289 
1290           call qx_search_file_$cleanup (qid_ptr);
1291 
1292           return;
1293 
1294      end cleanup_invocation_data;
1295 %page;
1296 /* Saves the current buffer's state variables */
1297 
1298 save_buffer_state:
1299      procedure ();
1300 
1301           b.dp = ifp;
1302           b.de = ife;
1303           b.lb = ilb;
1304           b.ft = ift;
1305           b.li = li;
1306           b.le = le;
1307 
1308           return;
1309 
1310      end save_buffer_state;
1311 
1312 
1313 /* Restores the state of the specifier buffer causing it to be current */
1314 
1315 get_buffer_state:
1316      procedure (p_bp);
1317 
1318 dcl  p_bp pointer parameter;
1319 
1320           bp = p_bp;                                        /* switch to new buffer */
1321           curbuf = b.name;                                  /* ... */
1322 
1323           ifp = b.dp;                                       /* pointer to buffer file */
1324           ife = b.de;                                       /* index of last character in buffer */
1325           ilb = b.lb;
1326           ift = b.ft;
1327           li = b.li;                                        /* index of first character of current line */
1328           le = b.le;                                        /* index of last character of current line */
1329 
1330           return;
1331 
1332      end get_buffer_state;
1333 %page;
1334 /* Determine the "file" to be read/written: only used by actual read/write requests */
1335 
1336 determine_file:
1337      procedure (write_request, a_real_file, the_pathname, explicit_pathname);
1338 
1339 dcl  write_request bit (1) aligned parameter;               /* an output operation */
1340 dcl  a_real_file bit (1) aligned parameter;                 /* set ON => using a "file" rather than caller's buffer */
1341 dcl  the_pathname character (256) parameter;                /* set to the name of the "file" */
1342 dcl  explicit_pathname bit (1) aligned parameter;           /* set ON => user supplied a pathname to the request */
1343 dcl  l fixed binary (21);
1344 
1345           if b.callers_idx = 0 then                         /* not a buffer known to our caller */
1346                the_buffer_ptr = null ();
1347           else the_buffer_ptr = addr (qedx_info.buffers (b.callers_idx));
1348 
1349           do ti = ti to te while (t.c (ti) = " ");          /* skip leading blanks in path name */
1350           end;
1351           l = te - ti;                                      /* compute length of path name */
1352 
1353           if l > 0 then do;                                 /* have a pathname ... */
1354                explicit_pathname = "1"b;
1355                if qid.no_rw_path then do;                   /* user specified path but is not allowed to do so */
1356                     call ioa_ ("A pathname cannot be specified with the ^[w^;r^] request", write_request);
1357                     go to rq_err;
1358                end;
1359                if l > length (the_pathname) then do;
1360                     call com_err_ (error_table_$pathlong, qid.editor_name, "^a", substr (tp -> a_string, ti, l));
1361                     b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1362                     go to rq_err;
1363                end;
1364                a_real_file = "1"b;                          /* will be reading from a segment all right */
1365                the_pathname = substr (tp -> a_string, ti, l);
1366           end;                                              /* save the input pathname */
1367 
1368           else do;                                          /* determine source/destination */
1369                explicit_pathname = "0"b;
1370                a_real_file = ^b.default_is_region;          /* ... check if reading/writing a file */
1371 
1372                if the_buffer_ptr ^= null () then            /* ... check that user may use default "pathname" */
1373                     if the_buffer.read_write_region & b.default_is_region then
1374                          if (write_request & ^the_buffer.default_write_ok)
1375                               | (^write_request & ^the_buffer.default_read_ok) then do;
1376                               call ioa_ ("No pathname given.");
1377                               go to rq_err;
1378                          end;
1379 
1380                if ^write_request & b.default_is_region then /* can only read back original if buffer's empty */
1381                     if ^((ift > ife) & (ilb < 1)) then do;
1382                          call ioa_ ("Cannot restore original text unless buffer is empty.");
1383                          go to rq_err;
1384                     end;
1385 
1386                if a_real_file then                          /* verify that we have a pathname ... */
1387                     if b.default_path ^= "" then
1388                          the_pathname = b.default_path;
1389                     else do;
1390                          call ioa_ ("No pathname given.");
1391                          go to rq_err;
1392                     end;
1393           end;
1394 
1395           return;
1396 
1397      end determine_file;
1398 %page;
1399 /* Read the "file" into the buffer: returns "1"b if successfull */
1400 
1401 perform_read:
1402      procedure (a_real_file, the_pathname, explicit_pathname) returns (bit (1) aligned);
1403 
1404 dcl  a_real_file bit (1) aligned parameter;                 /* ON => reading from a real "file" vs. caller's buffer */
1405 dcl  the_pathname character (256) parameter;                /* the file to be read */
1406 dcl  explicit_pathname bit (1) aligned;                     /* ON => above pathname given by the user */
1407 
1408 dcl  file_ptr pointer;
1409 dcl  dirname character (168);
1410 dcl  (ename, component) character (32);
1411 dcl  (was_empty, read_ok) bit (1) aligned;
1412 dcl  trust_the_pathname bit (1);
1413 dcl  (code, status_code) fixed binary (35);
1414 dcl  file_bc fixed binary (24);
1415 dcl  file_lth fixed binary (21);
1416 
1417 
1418 /* Establish pointer/length of the "file" */
1419 
1420           if b.callers_idx = 0 then                         /* our caller doesn't care about this buffer */
1421                the_buffer_ptr = null ();
1422           else the_buffer_ptr = addr (qedx_info.buffers (b.callers_idx));
1423 
1424           if qedx_info.caller_does_io then do;              /* let the caller get the file for us */
1425                local_qbii.version = QEDX_BUFFER_IO_INFO_VERSION_1;
1426                local_qbii.editor_name = qid.editor_name;
1427                local_qbii.pathname = the_pathname;
1428                local_qbii.buffer_ptr = callers_io_region_ptr;
1429                local_qbii.buffer_max_lth = 4 * sys_info$max_seg_size;
1430                local_qbii.direction = QEDX_READ_FILE;
1431                string (local_qbii.flags) = ""b;
1432                local_qbii.default_pathname = ^explicit_pathname;
1433                call qedx_info.buffer_io (addr (local_qbii), read_ok);
1434                if ^read_ok then do;                         /* caller will print any error messages */
1435                     if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1436                     return ("0"b);
1437                end;
1438                file_ptr = callers_io_region_ptr;
1439                file_lth = local_qbii.buffer_lth;
1440           end;
1441 
1442           else if a_real_file then do;                      /* get it from an honest to God file */
1443                if sys_info$service_system then do;
1444                     call expand_pathname_$component (the_pathname, dirname, ename, component, code);
1445                     if code ^= 0 then do;
1446                          call com_err_ (code, qid.editor_name, "^a", the_pathname);
1447                          if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1448                          return ("0"b);
1449                     end;
1450                     call initiate_file_$component (dirname, ename, component, R_ACCESS, file_ptr, file_bc, code);
1451                     if code ^= 0 then do;                   /* can't get it */
1452                          if code = error_table_$dirseg then do;
1453                               call hcs_$status_minf (dirname, ename, CHASE, 0, file_bc, status_code);
1454                               if (status_code = 0) & (file_bc ^= 0) then
1455                                    call com_err_ (0, qid.editor_name, "This operation is not allowed for an MSF. ^a",
1456                                         pathname_$component (dirname, ename, component));
1457                               else call com_err_ (code, qid.editor_name, "^a",
1458                                         pathname_$component (dirname, ename, component));
1459                          end;
1460                          else call com_err_ (code, qid.editor_name, "^a", pathname_$component (dirname, ename, component))
1461                                    ;
1462                          if explicit_pathname & (code ^= error_table_$moderr) & (code ^= error_table_$no_r_permission)
1463                               then
1464                               b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1465                          return ("0"b);
1466                     end;
1467                     file_lth = divide ((file_bc + 8), 9, 21, 0);
1468                end;
1469                else do;
1470                     call bootload_fs_$get_ptr (the_pathname, file_ptr, file_lth, code);
1471                     if code ^= 0 then do;
1472                          call com_err_ (code, qid.editor_name, "^a", the_pathname);
1473                          if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1474                          return ("0"b);
1475                     end;
1476                end;
1477           end;
1478 
1479           else do;                                          /* read from the caller's buffer */
1480                file_ptr = the_buffer.region_ptr;
1481                file_lth = min (the_buffer.region_final_lth, the_buffer.region_max_lth);
1482           end;
1483 
1484 
1485 /* Check if reading with an untrustworthy default pathname and ask for permission if so */
1486 
1487           if b.default_untrusted & ^explicit_pathname then do;
1488                if sys_info$service_system then
1489                     call command_query_$yes_no (trust_the_pathname, 0, qid.editor_name, TRUSTED_PATHNAMES_EXPLANATION,
1490                          "Do you wish to ^a with the untrustworthy default pathname ^a?", "read", the_pathname);
1491                else call bce_query$yes_no (trust_the_pathname, TRUSTED_PATHNAMES_EXPLANATION);
1492                if trust_the_pathname then
1493                     ;                                       /* user says it's OK ... */
1494                else go to rq_err;                           /* ... punt */
1495           end;
1496 
1497           else trust_the_pathname = "0"b;                   /* be sure it's initialized */
1498 
1499 
1500 /* Move the data into the buffer */
1501 
1502           was_empty = (ilb < 1) & (ift > ife);              /* remember whether buffer was empty or not */
1503 
1504           call open_gap ((fle));                            /* open a gap to add after */
1505           call promote (file_lth);                          /* ensure space exists */
1506 
1507           le = ift - 1;                                     /* mark end of buffer */
1508           ift = ift - file_lth;                             /* setup location where we will read */
1509 
1510           substr (ifp -> a_string, ift, file_lth) = substr (file_ptr -> a_string, 1, file_lth);
1511                                                             /* copy file */
1512 
1513           file_lth = le;                                    /* remember position of end of last line */
1514           call next_line (ift);                             /* get end of first line of new data */
1515           call last_line (le);                              /* get start of first line of data (and maybe more) */
1516           call open_gap ((li - 1));                         /* open gap at start of line (which might be in lower) */
1517           call last_line (file_lth);                        /* end of buffer has last line */
1518           call next_line (li);                              /* ensure a whole line */
1519 
1520 
1521 /* Set default pathname if necessary and cleanup */
1522 
1523           if b.default_locked then do;                      /* pathname is locked */
1524                b.default_untrusted = "0"b;
1525                b.modified = ^was_empty | explicit_pathname; /* ... make sure 1,$dr works right */
1526           end;
1527 
1528           else if was_empty then do;                        /* empty and not locked: set new default pathname */
1529                if sys_info$service_system then
1530                     if a_real_file & ^qedx_info.caller_does_io then
1531                          b.default_path = pathname_$component (dirname, ename, component);
1532                     else b.default_path = the_pathname;     /* ... if not from a file it wasn't expanded */
1533                else b.default_path = the_pathname;
1534                b.default_is_region = ^a_real_file;          /* ... might have been caller's buffer */
1535                b.default_untrusted = "0"b;                  /* ... we trust the pathname again */
1536                b.modified = "0"b;                           /* ... and this buffer is no longer modified */
1537           end;
1538 
1539           else do;                                          /* buffer wasn't empty */
1540                b.default_untrusted = (b.default_path ^= "");/* ... we can't trust the default anymore (if there is one) */
1541                b.modified = "1"b;                           /* ... and the buffer is modified */
1542           end;
1543 
1544           if sys_info$service_system then
1545                if a_real_file & ^qedx_info.caller_does_io then
1546                                                             /* terminate it when done */
1547                     call terminate_file_ (file_ptr, 0, TERM_FILE_TERM, (0));
1548 
1549           return ("1"b);                                    /* success */
1550 
1551      end perform_read;
1552 %page;
1553 /* Write the specified portion of the buffer into the "file": returns "1"b if successful */
1554 
1555 perform_write:
1556      procedure (a_real_file, the_pathname, explicit_pathname, issue_truncation_warning) returns (bit (1) aligned);
1557 
1558 dcl  a_real_file bit (1) aligned parameter;                 /* ON => writing to a file vs. caller's buffer */
1559 dcl  the_pathname character (256) parameter;                /* the name of the file */
1560 dcl  explicit_pathname bit (1) aligned parameter;           /* ON => user specified a pathname to the write request */
1561 dcl  issue_truncation_warning bit (1) aligned parameter;    /* ON => if it won't fit in caller's buffer: tell the user */
1562 
1563 dcl  file_ptr pointer;
1564 dcl  dirname character (168);
1565 dcl  ename character (32);
1566 dcl  (split_data, write_ok, created_file, wrote_whole_buffer) bit (1) aligned;
1567 dcl  trust_the_pathname bit (1);
1568 dcl  (code, status_code) fixed binary (35);
1569 dcl  file_bc fixed binary (24);
1570 dcl  file_lth fixed binary (21);
1571 
1572 
1573           if b.callers_idx = 0 then                         /* caller doesn't care about this buffer */
1574                the_buffer_ptr = null ();
1575           else the_buffer_ptr = addr (qedx_info.buffers (b.callers_idx));
1576 
1577           if (lle <= ilb) | (fli >= ift) then do;           /* all data is in one half of the buffer */
1578                split_data = "0"b;
1579                file_lth = lle - fli + 1;
1580           end;
1581           else do;                                          /* data spans the gap */
1582                split_data = "1"b;
1583                file_lth = (ilb - fli + 1) + (lle - ift + 1);
1584           end;
1585 
1586 
1587 /* Check if writing with an untrustworthy default pathname and ask for permission if so */
1588 
1589           if b.default_untrusted & ^explicit_pathname then do;
1590                if sys_info$service_system then
1591                     call command_query_$yes_no (trust_the_pathname, 0, qid.editor_name, TRUSTED_PATHNAMES_EXPLANATION,
1592                          "Do you wish to ^a with the untrustworthy default pathname ^a?", "write", the_pathname);
1593                else call bce_query$yes_no (trust_the_pathname, TRUSTED_PATHNAMES_EXPLANATION);
1594                if trust_the_pathname then                   /* user says it's OK ... */
1595                     b.default_untrusted = "0"b;
1596                else go to rq_err;                           /* ... punt */
1597           end;
1598 
1599           else trust_the_pathname = "0"b;                   /* be sure this is properly initialized */
1600 
1601 
1602           if qedx_info.caller_does_io then do;
1603 
1604 /* Caller does actual I/O: put the portion of the buffer being written into out buffer and have the caller write it */
1605 
1606                call put_data (callers_io_region_ptr);
1607 
1608                local_qbii.version = QEDX_BUFFER_IO_INFO_VERSION_1;
1609                local_qbii.editor_name = qid.editor_name;
1610                local_qbii.pathname = the_pathname;
1611                local_qbii.buffer_ptr = callers_io_region_ptr;
1612                local_qbii.buffer_lth = file_lth;
1613                local_qbii.direction = QEDX_WRITE_FILE;
1614                string (local_qbii.flags) = ""b;
1615                local_qbii.default_pathname = ^explicit_pathname;
1616 
1617                call qedx_info.buffer_io (addr (local_qbii), write_ok);
1618                if ^write_ok then do;                        /* failed: caller has already printed reason */
1619                     if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1620                     return ("0"b);
1621                end;
1622           end;
1623 
1624 
1625           else if a_real_file then do;
1626                if sys_info$service_system then do;
1627 
1628 /* A real file: initiate/create the file and then put the data into it (do not accept archive component pathnames) */
1629 
1630                     call expand_pathname_ (the_pathname, dirname, ename, code);
1631                     if code ^= 0 then do;
1632                          if code = error_table_$archive_pathname then code = error_table_$archive_component_modification;
1633                          call com_err_ (code, qid.editor_name, "^a", the_pathname);
1634                          if explicit_pathname & (code ^= error_table_$archive_component_modification) then
1635                               b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1636                          return ("0"b);
1637                     end;
1638 
1639                     call initiate_file_$create (dirname, ename, RW_ACCESS, file_ptr, created_file, (0), code);
1640                     if created_file then do;                /* insure that the file just created has an acceptable name */
1641                          call check_entryname_ (ename, code);
1642                          if code ^= 0 then do;              /* ... sorry: be sure to delete the unwanted file */
1643                               call terminate_file_ (file_ptr, 0, TERM_FILE_DELETE, (0));
1644                               call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename));
1645                               if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1646                               return ("0"b);
1647                          end;
1648                     end;
1649 
1650                     if code ^= 0 then do;                   /* unable to initiate/create it */
1651                          if code = error_table_$dirseg then do;
1652                               call hcs_$status_minf (dirname, ename, CHASE, 0, file_bc, status_code);
1653                               if (status_code = 0) & (file_bc ^= 0) then
1654                                    call com_err_ (0, qid.editor_name, "This operation is not allowed for an MSF. ^a",
1655                                         pathname_ (dirname, ename));
1656                               else call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename));
1657                          end;
1658                          else call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename));
1659                          if explicit_pathname & (code ^= error_table_$moderr) & (code ^= error_table_$no_r_permission)
1660                               & (code ^= error_table_$no_w_permission) then
1661                               b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1662                          return ("0"b);
1663                     end;
1664                end;
1665                else do;
1666                     call bootload_fs_$put_ptr (the_pathname, file_lth, "0"b, file_ptr, code);
1667                     if code ^= 0 then do;
1668                          call com_err_ (code, qid.editor_name, "^a", the_pathname);
1669                          if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1670                          return ("0"b);
1671                     end;
1672                end;
1673 
1674                call put_data (file_ptr);                    /* do it */
1675 
1676                if sys_info$service_system then do;
1677                     call terminate_file_ (file_ptr, (9 * file_lth), TERM_FILE_TRUNC_BC_TERM, code);
1678                     if code ^= 0 then do;                   /* couldn't cleanup */
1679                          call com_err_ (code, qid.editor_name, "^a", pathname_ (dirname, ename));
1680                          if explicit_pathname then b.default_untrusted = ^b.default_locked & (b.default_path ^= "");
1681                          return ("0"b);
1682                     end;
1683                end;
1684                else call bootload_fs_$flush_sys;            /* force write */
1685           end;
1686 
1687 
1688           else do;
1689 
1690 /* Using the caller's input/output area: put the data out and issue truncation warning if necessary */
1691 
1692                the_buffer.region_final_lth = file_lth;
1693                file_lth = min (file_lth, the_buffer.region_max_lth);
1694 
1695                call put_data (the_buffer.region_ptr);       /* stuff it */
1696 
1697                if issue_truncation_warning & (the_buffer.region_final_lth > the_buffer.region_max_lth) then
1698                     call com_err_ (0, qid.editor_name, "Warning: Buffer ^a will be truncated on exit from the editor.",
1699                          b.name);
1700           end;
1701 
1702 
1703 /* Set default pathname and reset modified flag as appropriate */
1704 
1705 /* format: off */
1706           wrote_whole_buffer = ((1 > ilb) & ((fli = ift) & (lle = ife))) |
1707                                ((ift > ife) & ((fli = 1) & (lle = ilb))) |
1708                                (((1 <= ilb) & (ift <= ife)) & ((fli = 1) & (lle = ife)));
1709                                                             /* format: on */
1710 
1711           if b.default_locked then do;                      /* pathname is locked */
1712                b.default_untrusted = "0"b;                  /* ... stays modified unless the entire buffer was ... */
1713                b.modified = b.modified & (^wrote_whole_buffer | explicit_pathname);
1714           end;                                              /* ... ... written to the default pathname */
1715 
1716           else if wrote_whole_buffer then do;               /* wrote it all and not locked: set new default pathname */
1717                if sys_info$service_system then
1718                     if a_real_file & ^qedx_info.caller_does_io then
1719                          b.default_path = pathname_ (dirname, ename);
1720                     else b.default_path = the_pathname;     /* ... not a real file: pathname isn't expanded */
1721                else b.default_path = the_pathname;
1722                b.default_is_region = ^a_real_file;          /* ... might have been caller's buffer */
1723                b.modified = "0"b;                           /* ... it's now safe */
1724                b.default_untrusted = "0"b;                  /* ... and we trust this pathname */
1725           end;
1726 
1727           else b.default_untrusted = (b.default_path ^= "");/* didn't write everything */
1728 
1729           return ("1"b);                                    /* success */
1730 
1731 
1732 
1733 /* Internal to perform_write: actually moves the data from our buffer into the output area */
1734 
1735 put_data:
1736           procedure (p_file_ptr);
1737 
1738 dcl  p_file_ptr pointer parameter;
1739 dcl  (part1_lth, part2_lth) fixed binary (21);
1740 
1741                if split_data then do;                       /* data spans the gap ... */
1742                     part1_lth = min ((ilb - fli + 1), file_lth);
1743                     part2_lth = min ((lle - ift + 1), (file_lth - part1_lth));
1744                     substr (p_file_ptr -> a_string, 1, part1_lth) = substr (ifp -> a_string, fli, part1_lth);
1745                     if part2_lth > 0 then                   /* it all really fits */
1746                          substr (p_file_ptr -> a_string, (part1_lth + 1), part2_lth) =
1747                               substr (ifp -> a_string, ift, part2_lth);
1748                end;
1749 
1750                else substr (p_file_ptr -> a_string, 1, file_lth) = substr (ifp -> a_string, fli, file_lth);
1751 
1752                return;
1753 
1754           end put_data;
1755 
1756      end perform_write;
1757 %page;
1758 /* Locate line ending with specified character (ale) */
1759 
1760 last_line:
1761      procedure (ale);
1762 
1763 dcl  ale fixed bin (21);                                    /* index of last character of line to be isolated */
1764 
1765 dcl  i fixed bin (21);                                      /* position returned from index */
1766 
1767           if ale < ift & ale > ilb then                     /* never - never land in the gap */
1768                le = ilb;
1769           else le = ale;                                    /* position at last character of line */
1770                                                             /* Modified last_line search to use index function across gapped buffer. */
1771 
1772           li = le - 1;                                      /* miss current NL */
1773 
1774 retry:
1775           if li >= ift then do;
1776                i = index (reverse (substr (ifp -> a_string, ift, li - ift + 1)), NL);
1777                                                             /* search upper */
1778                if i = 0 then
1779                     if ilb > 0 then do;                     /* move across gap to lower and re-try search */
1780                          li = ilb;
1781                          goto retry;
1782                     end;
1783                     else do;                                /* this must be the first line */
1784                          li = ift;
1785                          return;
1786                     end;
1787           end;
1788           else do;                                          /* search lower section */
1789                if li < 1 then do;
1790                     li = 1;                                 /* force to bottom */
1791                     return;
1792                end;
1793                if li > ilb then li = ilb;                   /* force across gap */
1794                i = index (reverse (substr (ifp -> a_string, 1, li)), NL);
1795                if i = 0 then do;                            /* not found - force to 1st character */
1796                     li = 1;
1797                     return;
1798                end;
1799           end;
1800           li = li - i + 1;                                  /* setup start index */
1801 
1802 /* correct for overstep */
1803 
1804           if li = ilb then
1805                li = ift;                                    /* force up */
1806           else li = li + 1;                                 /* correct for pointing at NL */
1807           return;                                           /* and return */
1808 
1809      end last_line;
1810 %page;
1811 /* Locate line beginning with specified character (ali) */
1812 
1813 next_line:
1814      procedure (ali);
1815 
1816 dcl  ali fixed bin (21);                                    /* index of first character of line */
1817 
1818           if ali <= ife then do;                            /* if line address within the buffer file */
1819                if ali < ift & ali > ilb then                /* never - never land in the gap */
1820                     li = ift;
1821                else li = ali;                               /* isolate line within file */
1822 retry_top:
1823                if li <= ilb then do;
1824                     le = index (substr (ifp -> a_string, li, (ilb - li + 1)), NL);
1825                                                             /* attempt to find NL char at end of this line */
1826                     if le = 0 & ift <= ife then do;
1827                          li = ift;
1828                          goto retry_top;
1829                     end;
1830                end;
1831                else le = index (substr (ifp -> a_string, li, (ife - li + 1)), NL);
1832                                                             /* attempt to find NL char at end of this line */
1833                if le = 0 then
1834                     le = ife;                               /* if no NL found, set line end to end of file */
1835                else le = (li - 1) + le;                     /* otherwise, compute index of NL within entire file */
1836           end;
1837           else do;                                          /* if line address is outside of buffer file */
1838                li = ife + 1;                                /* set line beginning to next char to be added to file */
1839                le = ife;                                    /* indicate address points outside of buffer */
1840           end;
1841           return;
1842 
1843      end next_line;
1844 %page;
1845 /* Compute default addresses if necessary */
1846 
1847 defaults:
1848      procedure (afli, alle);
1849 
1850 dcl  afli fixed bin (21),                                   /* default first index for first address */
1851      alle fixed bin (21);                                   /* default last index for last address */
1852 
1853 dcl  (qfli, qlle) fixed bin (21);
1854 
1855           if afli > ilb & afli < ift then
1856                qfli = ift;                                  /* fixup default in gap */
1857           else qfli = afli;
1858 
1859           if alle > ilb & alle < ift then
1860                qlle = ift;
1861           else qlle = alle;
1862 
1863 
1864           if ^flsw then do;                                 /* if no addresses provided */
1865                fli, lli = qfli;                             /* fill in addresses with given defaults */
1866                fle, lle = qlle;                             /* .. */
1867           end;
1868           else if ^llsw then do;                            /* if only one addr, make second addr same as first */
1869                if fli > ilb & fli < ift then
1870                     lli = ift;
1871                else lli = fli;                              /* .. */
1872                if fle > ilb & fle < ift then
1873                     lle = ift;
1874                else lle = fle;                              /* .. */
1875           end;
1876           if (ift > ife) & (ilb < 1) then do;               /* check for empty buffer */
1877                call ioa_ ("Buffer empty.");
1878                go to rq_err;
1879           end;
1880           if (fli = 0) | (lle = 0) | (fli > ife) then do;   /* check for address outside of buffer */
1881                call ioa_ ("Address out of buffer.");
1882                go to rq_err;
1883           end;
1884           if fli > lle then do;                             /* check for address wrap-around */
1885                call ioa_ ("Address wrap-around.");
1886                go to rq_err;
1887           end;
1888           if fli > ife then fli = ilb;                      /* over-range */
1889           if lli > ife then lli = ilb;
1890           if fle > ife then fle = ilb;
1891           if lle > ife then lle = ilb;
1892           return;
1893 
1894      end defaults;
1895 %page;
1896 /*     **** input data from input stream, append to text ****
1897 
1898    This command auxilliary for i,a, and c, calls promote to increase the size
1899    of the working text file, prior to moving data from the working line buffer.
1900    Promote will move the working file to the next aste pool boundary if space
1901    is available and is needed, and may abort the input command if no space is
1902    available in a 255K segment. */
1903 
1904 
1905 input:
1906      procedure (afp, afe);                                  /* procedure to append data from console to either file */
1907 
1908 dcl  afp ptr,                                               /* pointer to file to which data is to be appended */
1909      afe fixed bin (21);                                    /* index of (current) last character in file */
1910 
1911 
1912           if t.c (ti) = NL then go to rd_line;              /* check for NL immediately following input request */
1913           if t.c (ti) = " " then ti = ti + 1;               /* skip space following input request */
1914           if ti <= te then go to inp_search;                /* pick up any remaining characters from current line */
1915 rd_line:
1916           call edx_util_$read_ptr (qid_ptr, tp, length (iline), te);
1917                                                             /* read a line (or portion of line) from input stream */
1918           ti = 1;                                           /* initialize character index */
1919 
1920 inp_search:
1921           k = search (substr (tp -> a_string, ti, te - ti + 1), "^\^Y\");
1922                                                             /* search for end input (034), conceal (031) or escape ("\") */
1923 
1924           if k = 0 then do;                                 /* no special symbol found */
1925                k = te - ti + 2;                             /* set up string length */
1926 inp_move_string:
1927                call promote (k - 1);                        /* ensure space exists */
1928                substr (afp -> a_string, afe + 1, (k - 1)) = substr (tp -> a_string, ti, (k - 1));
1929                afe = afe + (k - 1);                         /* update output string index */
1930                if (k - 1) > 0 then b.modified = "1"b;
1931                go to rd_line;                               /* get the next line */
1932           end;
1933 
1934           kx = index ("^\^Y\", t.c (ti + (k - 1)));                   /* which symbol was found? */
1935           go to inp_case (kx);                              /* handle it */
1936 
1937 inp_case (1):
1938           ka = 0;                                           /* found single character terminate symbol */
1939 inp_act (1):
1940 inp_act (2):
1941 inp_final:
1942           call promote (k - 1);                             /* ensure space exists */
1943           substr (afp -> a_string, afe + 1, (k - 1)) = substr (tp -> a_string, ti, (k - 1));
1944                                                             /* move last of input */
1945           afe = afe + (k - 1);                              /* update output string index */
1946           if (k - 1) > 0 then b.modified = "1"b;
1947           ti = ti + k + ka;                                 /* update input string index */
1948           return;                                           /* done with input */
1949 
1950 inp_case (2):
1951           ka = 0;                                           /* found single character conceal */
1952 inp_act (3):
1953 inp_act (4):
1954 inp_conceal:
1955           if (ti + k + ka) > te then go to inp_move_string; /* check length for character to conceal */
1956           call promote (k);                                 /* ensure space xists */
1957           substr (afp -> a_string, afe + 1, k) = substr (tp -> a_string, ti, (k - 1)) || t.c (ti + k + ka);
1958                                                             /* move string and concealed character */
1959           afe = afe + k;                                    /* update output string */
1960           if k > 0 then b.modified = "1"b;
1961           ti = (ti + k + ka) + 1;                           /* update input string */
1962           if ti > te then
1963                go to rd_line;                               /* get the next input line */
1964           else go to inp_search;                            /* continue the search */
1965 
1966 inp_case (3):
1967           ka = 1;                                           /* escape character found */
1968 
1969           kx = index ("fFcC", t.c (ti + k));                /* is this end input or conceal */
1970 
1971           if kx = 0                                         /* it is neither */
1972           then do;
1973                call promote (k);                            /* ensure space exists */
1974                substr (afp -> a_string, afe + 1, k) = substr (tp -> a_string, ti, k);
1975                                                             /* copy everything */
1976                afe = afe + k;                               /* update output string */
1977                if k > 0 then b.modified = "1"b;
1978                ti = ti + k;                                 /* update input string */
1979                if ti > te then
1980                     go to rd_line;
1981                else go to inp_search;
1982           end;
1983 
1984           go to inp_act (kx);                               /* otherwise end input or conceal */
1985 
1986 
1987      end input;
1988 %page;
1989 /*     **** interrupt handling ****
1990 
1991    Interrupt handling is done in one of two modes, either we want to be interrupted
1992    and the current operation suspended, or we don't.  This interrupt processing
1993    includes some verbosity to indicate what has happened.
1994 */
1995 
1996 
1997 interrupt:
1998      procedure ();                                          /* procedure to handle program interrupts */
1999 
2000           if pi_sw then do;                                 /* are we currently accepting program interrupts */
2001                pi_sw = "0"b;                                /* if so, reset enable switch */
2002                go to pi_label;                              /* and do a non-local go to specified location */
2003           end;
2004           else do;                                          /* if no label assigned to handle interrupt */
2005                intsw = "1"b;                                /* set switch to indicate interrupt occurred */
2006                return;                                      /* and otherwise ignore the program interrupt */
2007           end;
2008 
2009      end interrupt;
2010 %page;
2011 /*     **** Promote ****
2012 
2013    This is an auxilliary routine called each time data is added to the working
2014    text buffer.  It will check to ensure that the gap is big enough to contain
2015    the data.  Otherwise it will grow the working file to a size great enough
2016    to contain the data. This is done by determining which aste pool size will
2017    be needed, and then moving the top section of the working buffer to the top
2018    of the new aste size.  Pointers are then cleaned up and editing can continue.
2019 
2020    If there cannot be enough space left in a max len segment, then promote will
2021    dump an error message to the terminal, and will abort the current operation.
2022 
2023    This will mean that the current line will be lost for terminal input, and
2024    that the entire read will not be done for reading.  */
2025 
2026 promote:
2027      procedure (string_length);
2028 
2029 dcl  string_length fixed bin (21);
2030 
2031 dcl  (new_fe, new_ft) fixed bin (21);
2032 
2033 dcl  offset_action fixed bin (21);
2034 
2035           if (ife - ift + 1) + (ilb) + string_length > ife then do;
2036                                                             /* determine end of next pool */
2037                new_fe = ife;
2038                do while ((ife - ift + 1) + ilb + string_length > new_fe);
2039                     if new_fe >= sys_info$max_seg_size * 4 then do;
2040                                                             /* error on size */
2041                          if pi_label = sub_done then do;
2042                               call ioa_ ("^a: Segment full!! Skipping remaining substitutions.", qid.editor_name);
2043                               goto sub_done;
2044                          end;
2045 
2046                          if pi_label = in_mode then
2047                               call ioa_ ("^a: Segment full!! Last line of input lost - back to command mode.",
2048                                    qid.editor_name);
2049                          else call ioa_ ("^a: Read will not fit in buffer - read not performed.", qid.editor_name);
2050                          if pi_label = in_mode then call last_line (ilb);
2051                                                             /* fixup last line input for input cleanup */
2052                          goto rq_err;
2053                     end;
2054                     else new_fe = min (new_fe * 4, sys_info$max_seg_size * 4);
2055                end;
2056                new_ft = ift - ife + new_fe;
2057 
2058                if ife - ift >= 0 then do;                   /* top exists and must be moved */
2059                     call mrl_ (addr (substr (ifp -> a_string, ift)), (ife - ift + 1),
2060                          addr (substr (ifp -> a_string, new_ft)), (ife - ift + 1));
2061                end;
2062 
2063 /* update current line pointers if they fall within the upper part. */
2064 
2065                offset_action = new_ft - ift;
2066                if lle >= ift then lle = lle + offset_action;
2067                if lli >= ift then lli = lli + offset_action;
2068                if le >= ift then le = le + offset_action;
2069                if li >= ift then li = li + offset_action;
2070 
2071                if mi >= ift then mi = mi + offset_action;
2072                if me >= ift then me = me + offset_action;
2073                if fli >= ift then fli = fli + offset_action;
2074 
2075                if b.ti >= ift then do;
2076                     b.ti = b.ti + offset_action;
2077                     b.te = b.te + offset_action;
2078                end;
2079 
2080                ife = new_fe;
2081                ift = new_ft;
2082           end;
2083 
2084      end promote;
2085 %page;
2086 /* Open_gap is used to open a processing gap in the text buffer at the
2087    point of the current line.  This may require text to be moved up or down at
2088    the current gap.  When data has been moved appropriate pointers are cleaned
2089    up and moved if they were in the section of text which was moved. */
2090 
2091 open_gap:
2092      procedure (gap_index);
2093 
2094 /* gap is opened after the specified index */
2095 
2096 dcl  gap_index fixed bin (21);
2097 
2098 dcl  offset_action fixed bin (21);
2099 
2100 dcl  gap fixed bin (21);
2101 
2102           if ilb ^= gap_index & ift - 1 ^= gap_index then do;
2103                                                             /* gap not at  current index */
2104                if gap_index <= ilb then do;                 /* index in bottom, move upper bottom up */
2105                     gap = ilb - gap_index;
2106                     call mrl_ (addr (substr (ifp -> a_string, gap_index + 1)), gap,
2107                          addr (substr (ifp -> a_string, ift - gap)), gap);
2108                     offset_action = -gap_index + ift - gap - 1;
2109                                                             /* form offset for index movement */
2110                     if li <= ilb & li > gap_index then li = li + offset_action;
2111                     if le <= ilb & le > gap_index then le = le + offset_action;
2112                     if lli <= ilb & lli > gap_index then lli = lli + offset_action;
2113                     if lle <= ilb & lle > gap_index then lle = lle + offset_action;
2114                     if fli <= ilb & fli > gap_index then fli = fli + offset_action;
2115                     if fle <= ilb & fle > gap_index then fle = fle + offset_action;
2116 
2117                     if b.ti <= ilb & b.ti > gap_index then b.ti = b.ti + offset_action;
2118 
2119                     ift = ift - gap;
2120                     ilb = ilb - gap;
2121 
2122                     if b.ti <= ilb then
2123                          b.te = ilb;
2124                     else b.te = ife;
2125                end;
2126                else do;
2127                     gap = gap_index - ift + 1;
2128                     substr (ifp -> a_string, ilb + 1, gap) = substr (ifp -> a_string, ift, gap);
2129                     offset_action = -ift + ilb + 1;         /* offset for index move */
2130                     if li >= ift & li <= gap_index then li = li + offset_action;
2131                     if le >= ift & le <= gap_index then le = le + offset_action;
2132                     if lli >= ift & lli <= gap_index then lli = lli + offset_action;
2133                     if lle >= ift & lle <= gap_index then lle = lle + offset_action;
2134 
2135                     if b.ti >= ift & b.ti <= gap_index then b.ti = b.ti + offset_action;
2136 
2137                     if fli >= ift & fli <= gap_index then fli = fli + offset_action;
2138                     if fle >= ift & fle <= gap_index then fle = fle + offset_action;
2139                     ilb = ilb + gap;
2140                     ift = ift + gap;
2141                     if b.ti <= ilb then
2142                          b.te = ilb;
2143                     else b.te = ife;
2144 
2145                end;
2146           end;
2147 
2148      end open_gap;
2149 %page;
2150 %include qedx_internal_data;
2151 %page;
2152 %include qedx_info;
2153 %page;
2154 %include qedx_buffer_io_info;
2155 %page;
2156 %include access_mode_values;
2157 
2158 %include sub_err_flags;
2159 
2160 %include terminate_file;
2161 
2162      end qedx_;