1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Bull Inc., 1988                *
   6         *                                                         *
   7         * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   8         *                                                         *
   9         * Copyright (c) 1972 by Massachusetts Institute of        *
  10         * Technology and Honeywell Information Systems, Inc.      *
  11         *                                                         *
  12         *********************************************************** */
  13 
  14 
  15 
  16 /****^  HISTORY COMMENTS:
  17   1) change(88-08-03,RWaters), approve(88-08-03,MCR7950), audit(88-09-29,Huen),
  18      install(88-10-07,MR12.2-1146):
  19      Bug fixes for MR12.2.
  20   2) change(89-03-29,Huen), approve(89-03-29,MCR8062), audit(89-04-25,JRGray),
  21      install(89-05-02,MR12.3-1037):
  22      Fix bug 160: Modify ted to ignore trailing whitespace after a quit
  23      request.
  24   3) change(89-03-29,Huen), approve(89-03-29,MCR8079), audit(89-04-25,JRGray),
  25      install(89-05-02,MR12.3-1037):
  26                Fix bug 210: Modify ted to ltrim on the "help" request.
  27                Fix bug 208: Modify ted to ignore leading <TAB> characters.
  28                Fix bug 207: Modify ted to extend "help" request to work in
  29      "f" request.
  30                                                    END HISTORY COMMENTS */
  31 
  32 
  33 /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16            */
  34 /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
  35 /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
  36 /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
  37 
  38 /*                                                                           */
  39 /*   _|_              |                                                      */
  40 /*    |      _      _ |                                                      */
  41 /*    |     / \    / \|                                                      */
  42 /*    |    (__/   (   |                                                      */
  43 /*    \_    \_/    \_/|                                                      */
  44 /*                       -----                                               */
  45 /*                                                                           */
  46 
  47 /* ted is an editor based on qedx.  There have been extensive changes and    */
  48 /*  additions                                                                */
  49 /* ted    06/01/72  James Falksen                                            */
  50 /* ted3   01/01/73  James Falksen                                            */
  51 /* ted4   11/01/74  James Falksen                                            */
  52 /* ted2.5 05/01/80  jaf                                                      */
  53 /* ted2.6 02/25/81  jaf                                                      */
  54 /*        01/05/81  jaf  added g./  / request which uses null=X value        */
  55 /* ted3.0 05/10/84  jaf  added db_output iocb pointer support                */
  56 /*                       converted from tedmrl_ to mrl_                      */
  57 
  58 /* UPDATE HISTORY                                                            */
  59 /* EL#   date       TR        comments                                       */
  60 /* 119          phx15727 "#" doesn't always know a buffer is empty.          */
  61 /* 131          phx16660 "fo",no output. "+5" knows b(o) empty, "#" doesn't  */
  62 /* 142          phx17283 g* "d" leaving empty buffer, "x" didn't show that   */
  63 /* 145          phx17343 null_ptr_ref from "y" in empty buffer               */
  64 /* 129 84-10-08 phx16839 handle "locked" buffers properly.                   */
  65 /* 137 84-10-09 phx16858 make initial b0 same state as all other new buffers */
  66 /* 140 84-10-09 phx17209 "x" on windowed buffer not show windowed size       */
  67 /* 157 84-10-09 phx18306 pathname processing sometimes messed up. Problem    */
  68 /*                  was already fixed, but tightened things up a little.     */
  69 /* 147 84-10-10 phx17391 recursive fileout not always handled well           */
  70 /* 152 84-10-11 phx17594 OOB fault on empty buffer (after [buffer X])        */
  71 /* 153 84-10-12 phx17665 Got a no_read_permission fault doing a "w"          */
  72 /* 159 84-10-12 phx15158 let ted$qedx "q" check for modified buffers         */
  73 /* --a 84-10-19 -------- |function doesn't get right inp.lno if first line   */
  74 /*                  of buffer is empty                                       */
  75 /* 156 84-10-19 phx18195 prohibit invoking buffer in INPUT mode and          */
  76 /*                  modifying buffer being executed.                         */
  77 /* 160 84-10-19 phx17878 rtrim quit request lines (incomplete fix)           */
  78 /* 1xx 84-11-05 -------- fixes up to this point broke m/M/k/K                */
  79 /* 162 85-01-11 -------- "vd/x/" leaves "." undefined if last line deleted   */
  80 /* 191 88-08-07 phx19915,19147 print a better error message than             */
  81 /*     'unsupported operation' when reading a non-existent file              */
  82 /* 193 88-08-07 phx19382 tabin sometimes references thru null pointer when   */
  83 /*        '.' is undefined and buffer is empty                               */
  84 /* 194 88-08-07 phx19660 !f<NL> stopped working because of fix to #147       */
  85 /* 197 88-08-07 phx19916 rtrim all error messages                            */
  86 /* 200 88-09-07 phx20649 needed a ',' after "resetread" in 'o' request output*/
  87 /* 201 88-09-07 phx20688 et_$no_component rather than noentry should be      */
  88 /*        printed when talking about archive components                      */
  89 /* 160 89-01-11 phx17878 Rtrim the "quit" request.                           */
  90 /* 210 89-03-15 phx21267 Ltrim the "help" request.                           */
  91 /* 208 89-03-15 phx21260 Extend the ignoring of leading spaces to include    */
  92 /*       <TAB> character.                                                    */
  93 /* 207 89-03-15 phx21035 Extend "help" request to work in "f" request.       */
  94 /* END HISTORY                                                               */
  95 
  96 ted__:
  97 ted_:                                   /* main part of editor               */
  98    proc (ated_data_p, acode) options (variable);
  99 dcl (                                   /* +++++ */
 100     ated_data_p     ptr,                /* -> data structure                 */
 101     acode           fixed bin (35)      /* return code                       */
 102     )               parm;               /* <<>> */
 103 
 104 dcl ted_data_p      ptr;
 105 
 106       ted_data_p = ated_data_p;
 107       if (ted_data.version ^= ted_data_version_1)
 108       then do;
 109          call ioa_ ("^a: Assuming old version of ted_data structure given.",
 110               ted_data.tedname);
 111          ted_data.version = 1000;
 112       end;
 113       DBA = ted_data.tedname;
 114       ted_mode = ted_data.ted_mode;
 115       hold_db_output = db_output;
 116       if (db_output = null ())          /* make sure there is a switch for   */
 117       then db_output = iox_$user_output;/* ..debugging output                */
 118       if db_catch
 119       then do;
 120          if (db_output = iox_$user_output)
 121          then do;
 122             db_output = null ();        /* don't kill user_output            */
 123             call iox_$attach_name ("ted_db_output_", db_output,
 124                  "vfile_ ted.db_output", null (), code);
 125             if (code = 0)
 126             then call iox_$open (db_output, 2, ""b, code);
 127             if (code ^= 0)
 128             then do;
 129                call iox_$detach_iocb (db_output, 0);
 130                db_output = null ();
 131                acode = code;
 132                return;
 133             end;
 134          end;
 135       end;
 136 
 137       if (ted_mode ^= RESTART)
 138       then do;
 139 /**** A caller of ted_ may find it easier to include arguments in the call   */
 140 /****  instead of building an argument list for arg_list_p to point to. If   */
 141 /****  the arguments are fixed in number there is no good reason to have to  */
 142 /****  go to that trouble. To help this out, ted_ will allow additional      */
 143 /****  arguments to be passed to it. References to these will then be        */
 144 /****  plugged into the structure.                                           */
 145          call cu_$arg_count (hold_de, code);
 146          if (hold_de > 2)
 147          then do;
 148             call cu_$arg_list_ptr (ted_data.arg_list_p);
 149             ted_data.arg_list_1 = 3;
 150             ted_data.arg_list_n = hold_de;
 151          end;
 152       end;
 153 
 154       call tedinit_ (ted_data_p, dbase_p, code);
 155       if (code ^= 0)
 156       then do;
 157          acode = code;
 158          return;
 159       end;
 160       if db_catch
 161       then call ioa_$ioa_switch (db_output, "^/====Begin ted level ^i^/",
 162                 dbase.recurs);
 163 
 164       bp = ptr (dbase_p, cb_c_r);
 165       call make_consistent;
 166       ted_safe = (dbase.dir_db ^= "");
 167       if (ted_data.return_string_p = null ())
 168       then af_bp = null ();
 169       else do;
 170          argname = "(argn)";
 171          call tedget_buffer_ (dbase_p, addr (argname), length (argname),
 172               af_bp, msg);
 173          if (af_bp = null ())
 174          then goto rq_err_msg;
 175       end;
 176       call tedsrch_$init_exp (addr (dbase.regexp),
 177            divide (length (dbase.regexp), 4, 21, 0));
 178       gbp = null ();
 179       edit_sw = db_ted | db_trac;
 180       input_sw = db_ted | db_trac;
 181       break_sw, flow_sw = "0"b;
 182       old_style = "1"b;                 /* allowed for now                   */
 183 
 184 /*                             **** ***** ****                               */
 185 /* ------------------------------------------------------------------------- */
 186 /* Gapped standards permit a range to be split across the gap, but a line of */
 187 /*  text cannot be split between requests.  Some requests, like "w" and "p"  */
 188 /*  will function across the gap.  Others, like "i", or "r" will force the   */
 189 /*  gap to the place being worked at. Except, "d" will work differently      */
 190 /*  depending on whether when the gap is in the range or not.                */
 191 /* ------------------------------------------------------------------------- */
 192 
 193 get_the_string: proc;
 194 
 195       if (ted_data.input_l > 0)
 196       then call tedpseudo_ (bp, -1, ted_data.input_p, ted_data.input_l);
 197       b.no_io = "1"b;
 198       b.dname = "<<<external string>>";
 199       b.ename = "";
 200       b.file_sw = "1"b;
 201       b.cname = "";
 202       b.kind = "";
 203    end get_the_string;
 204       msg_ptr = addrel (addr (msg), 1);
 205       pi_passthru = "0"b;
 206       maxseg = sys_info$max_seg_size * 4;
 207       query_info.version = query_info_version_5;
 208       query_info.yes_or_no_sw = "1"b;
 209       b.a_.l.le (0), b.a_.l.re (0) = 1; /* set current line to null          */
 210       b.a_.r.le (0), b.a_.r.re (0) = addr_undef;
 211       gvx_p, sub_p = null ();
 212       if (ted_mode ^= RESTART)
 213       then do;
 214          nulreq = "p";
 215       end;
 216       else ted_mode = SAFE;
 217       b0_bp = bp;
 218       if (ted_data.input_p ^= null ())
 219       then call get_the_string;
 220       unspec (subf1) = "012014011011"b3;
 221       unspec (subf2) = "012012012"b3;
 222       qedx_mode = (DBA = "qedx");
 223       pi_sw, b_depth = 0;
 224       dbase.S_count = -1;
 225       app_sw, fo_sw, go_sw = "0"b;
 226       gvNL = ""b;
 227       read_sw = "1"b;
 228       on condition (program_interrupt)
 229          begin;
 230 dcl continue_to_signal_ entry (fixed bin (35));
 231             if pi_passthru
 232             then call continue_to_signal_ (code);
 233             else do;
 234                if (pi_sw = 1)           /* are we currently accepting PIs?   */
 235                then do;
 236                   pi_sw = 0;            /* if so, reset enable switch        */
 237                   call iox_$control (iox_$user_output, "resetwrite", null (),
 238                        code);
 239                   goto pi_label;        /* goto (non-local) specified loc    */
 240                end;
 241                else if (pi_sw = 2)
 242                then do;
 243                   pi_sw = 0;
 244                   intsw = "1"b;         /*  just indicate interrupt occurred */
 245                end;
 246                else if (pi_sw = 3)      /* during INPUT mode                 */
 247                then do;
 248                   pi_sw = 0;
 249                   which_mode = "EOF";   /* #117*/
 250                   goto pi_label;
 251                end;
 252                else goto nx_line;
 253             end;
 254          end;                           /* PROGRAM_INTERRUPT                 */
 255 
 256       req_not, req_ch, req_chx = " ";
 257       svpath = "";                      /* #157*/
 258       iocb_ptr = null ();
 259 
 260       on condition (cleanup) call cleaner;
 261 cleaner: proc;
 262 
 263       if (iocb_ptr ^= null ())
 264       then do;
 265          call iox_$close (iocb_ptr, code);
 266          call iox_$detach_iocb (iocb_ptr, code);
 267       end;
 268       if fo_sw
 269       then call detach ("1"b);
 270       i = dbase.recurs;                 /* hang on to recursion depth        */
 271       call tedcleanup_ (dbase_p);
 272       if db_catch
 273       then call ioa_$ioa_switch (db_output, "^/====End ted level ^i^/", i);
 274       if (hold_db_output = null ()) & (db_output ^= iox_$user_output)
 275       then do;
 276          call iox_$close (db_output, code);
 277          if ^lg_catch
 278          then do;
 279             call iox_$open (db_output, 2, ""b, code); /* throw away the data */
 280             call iox_$close (db_output, code);
 281          end;
 282          call iox_$detach_iocb (db_output, code);
 283       end;
 284       db_output = hold_db_output;
 285 
 286    end cleaner;
 287 
 288       reset = rq_err;
 289 
 290       on_quit, string_sw = "0"b;
 291       req_not = " ";
 292 
 293       if (ted_data.ted_com_l > 0)
 294       then do;
 295          call tedpseudo_ (dbase.cba_p, -1, ted_data.ted_com_p,
 296               ted_data.ted_com_l);
 297          dbase.cba_p -> b.ex.l.re = ted_data.ted_com_l;
 298          if db_ted
 299          then call tedshow_ (bp, ". rl* rl");
 300       end;
 301 /**** initialize b0 with the same code as all other buffers.             #137*/
 302       rl_i = 1;                         /* #137*/
 303       rl_l = 3;                         /* #137*/
 304       rl_s = "b0 ";                     /* #137*/
 305       goto next;                        /* #137*/
 306 %page;
 307 /* return here to process each new request line, from either a buffer or     */
 308 /*  user_input (which is not ever known to the request loop).  If there is   */
 309 /*  an error, control is returned here to cancel any unprocessed request     */
 310 /*  line.  Comes back here from "next" is there are no more requests on the  */
 311 /*  line.                                                                    */
 312 
 313 nx_line:
 314       req_str = "";
 315 
 316       err_go = " ";
 317       rl_i = 1;
 318       if go_sw                          /* goto does not turn off f req      */
 319       then goto nx_read;
 320       if fo_sw
 321       then call detach ("0"b);
 322 nx_read:
 323       if on_quit                        /* is condition(quit) enabled?       */
 324       then do;
 325          if (not_read_ct < 1)           /* if there are no ^read files left  */
 326          then do;
 327             revert quit;                /*   get rid of the quit handler     */
 328             on_quit = "0"b;
 329          end;
 330       end;
 331       else do;                          /* On the other hand, if no quit     */
 332          if (not_read_ct > 0)           /*  handler and there are ^read      */
 333          then do;                       /*  files, get one established       */
 334             on condition (quit)
 335                begin;
 336                   call tedset_ck_ptr_ (dbase_p);
 337                   call continue_to_signal_ (code);
 338                end;
 339             on_quit = "1"b;
 340          end;
 341       end;
 342 kill_read_ptr:
 343       pi_label = kill_read_ptr;
 344       pi_sw = 1;
 345       which_mode = "EDIT";
 346       call tedread_ptr_ (dbase_p, dbase.rl.sp, 0, dbase.rl.r.re, rl_l,
 347            which_mode);
 348       pi_sw = 0;
 349       if (chars_moved >= 0)             /* count chars moved into request    */
 350       then chars_moved = chars_moved + rl_l; /* ..buffer also                */
 351       if (which_mode = "\R\F")
 352       then goto eof_err;
 353       if (rl_l = dbase.rl.r.re) & (rl_c (dbase.rl.r.re) ^= NL)
 354       then call ioa_ ("*Request line exceeds ^i, error may follow.",
 355                 dbase.rl.r.re);
 356       if db_Ed
 357       then hold_db_ted = db_ted; %page;
 358 next:
 359       if b.get_bit_count
 360            | b.ck_ptr_sw
 361       then do;                          /* #152*/
 362          call tedcheck_buffer_state_ (dbase_p, bp, msg); /* #152*/
 363          if (b.b_.l.le > b.b_.l.re) & (b.b_.r.le < b.b_.r.re)
 364          then call demote (0);          /* #152*/
 365       end;                              /* #152*/
 366       if db_Ed
 367       then db_ted = hold_db_ted;
 368       b.INPUT = ""b;                    /* no INPUT in progress          #156*/
 369       pi_passthru = "0"b;
 370       if rl_i >= rl_l                   /* check after each req              */
 371       then goto nx_line;                /*  if request line exhausted        */
 372       rl_i
 373            = rl_i + verify (substr (rl_s, rl_i), "          ") - 1; /* #208*/
 374       if (rl_i >= rl_l)
 375       then goto nx_line;
 376 
 377       if (substr (rl_s, rl_i, 4) = "help") /* #207,210*/
 378       then do;
 379          if (rl_l = rl_i + 4)
 380          then do;
 381             if (length (dbase.err_msg) >= 4)
 382             then do;
 383                substr (rl_s, rl_i, 5) = "-msg ";
 384                substr (rl_s, rl_i + 5, 4) = substr (dbase.err_msg, 1, 4);
 385                substr (rl_s, rl_i + 9, length (err_req)) = err_req;
 386                rl_l = rl_l + 4 + length (err_req);
 387                substr (rl_s, rl_l, 1) = NL;
 388                rl_l = rl_l + 1;
 389             end;
 390          end;
 391          else substr (rl_s, rl_i, 4) = "";
 392          call tedhelp_ (substr (rl_s, rl_i));
 393 dcl tedhelp_        entry (char (*));
 394          goto nx_line;
 395       end;
 396 
 397       intsw = "0"b;                     /* reset previous PI (if any)        */
 398       if ^string_sw                     /* if not in string mode             */
 399       then do;
 400          b.a_.l.re (0) = b.a_.l.le (0); /* ignore carry-over strings         */
 401          b.a_.r.le (0) = b.a_.r.re (0);
 402       end; %skip (4);
 403       req_not, req_ch, req_chx, req_str = "";
 404       rl_b = 0;
 405       bp = ptr (dbase_p, dbase.cb_c_r);
 406       if (index ("0123456789,;+-/.$()<?\@[]", rl_c (rl_i)) = 0)
 407       then do;                          /* no address chars here, fake it    */
 408 /**** don't destroy address status for option request.                       */
 409                                         /* RW 88 */
 410          if (rl_c (rl_i) ^= "o")
 411          then do;
 412             b.present (1), b.present (2) = "0"b;
 413             b.a_ (1) = b.a_ (0);        /*#193*/
 414             goto got_add;
 415          end;
 416       end;
 417       used = rl_l - rl_i + 1;
 418       call tedaddr_ (dbase_p, addr (rl_c (rl_i)), used, bp, msg, code);
 419                                         /* find address if any               */
 420       rl_i = rl_i + used;
 421       if (code > 3)
 422       then goto print_error;
 423       if (code = 2)
 424       then do;
 425          if (err_go ^= " ")
 426          then goto print_error;
 427          goto cm_err;
 428       end;
 429       goto got_add; %skip (5);
 430 /*                 various and sundry error message routines                 */
 431 
 432 dcl EOF             bit (1);
 433 eof_err:
 434       msg = "Xrf) \r read \f.";
 435 
 436 cm_err:
 437       code = ted_mode;                  /* failure to match REGEXP           */
 438       call tedend_buffer_ (dbase_p, level); /*  pop buffer stack             */
 439       if level ^= 0                     /* if already at request level       */
 440       then do;
 441          call tederror_ (dbase_p, msg);
 442          goto rq_err;                   /* treat as normal error             */
 443       end;
 444       goto nx_line;                     /* resume input at next higher level */
 445 
 446 not_allowed:
 447       msg = "Xna) Not allowed on this buffer. ";
 448       goto add_request;
 449 
 450 err_Blv:
 451       msg = "Blv) Remembered >10 buffers.";
 452       goto add_request;
 453 
 454 err_Bnd:
 455       msg = "Bnd) Can't delete current or remembered buffer.";
 456       goto add_request;
 457 
 458 err_Bnr:
 459       msg = "Bnr) No buffer remembered.";
 460       goto add_request;
 461 
 462 err_Sbd:
 463       msg = "Sbd) Bad decimal digit.";
 464       goto add_request;
 465 
 466 err_Sd1:
 467       msg = "Sd1) No 1st delimiter.";
 468       goto add_request;
 469 
 470 err_Sd2:
 471       msg = "Sd2) No 2nd delimiter.";
 472       goto add_request;
 473 
 474 err_Sd3:
 475       msg = "Sd3) No 3rd delimiter.";
 476       goto add_request;
 477 
 478 err_Sje:
 479       msg = "Sje) Bad sort spec.";
 480       goto add_request;
 481 
 482 err_Sjk:
 483       msg = "Sjk) Bad key spec.";
 484       goto add_request;
 485 
 486 err_Slx:
 487       msg = "Slx) Label exceeds 16 chars.";
 488       goto add_request;
 489 
 490 err_Smp:
 491       msg = "Smp) Missing ).";
 492       goto add_request;
 493 
 494 err_Snb:
 495       msg = "Snb) No blank after ";
 496       goto add_request;
 497 
 498 err_Sne:
 499       msg = "Sne) No char for \=.";
 500       goto add_request;
 501 
 502 err_Sts:
 503       msg = "Sts) Tabstop not in 1-200.";
 504       goto add_request;
 505 
 506 err_Snf:
 507       msg = "Snf) No routine name supplied.";
 508       goto add_request;
 509 
 510 print_error_rc:
 511       call tederror_rc_ (dbase_p, msg, code);
 512       goto rq_err;
 513 
 514 syntax_error:
 515       msg = "Xse) Bad syntax for ";
 516 add_request:
 517       msg = msg || " ";
 518       msg = msg || req_str;
 519       if (rl_b > 0)
 520       then do;
 521          msg = msg || " """;
 522          msg = msg || substr (rl_s, rl_b, rl_i - rl_b + 1);
 523          msg = msg || """";
 524       end;
 525 print_error:
 526       if (rel (bp) ^= dbase.cb_c_r)     /* if working on some buffer other.. */
 527       then do;                          /*   ..than the "current" one,       */
 528          msg = msg || " (in b(";        /*   ..tell them where we are.       */
 529          msg = msg || rtrim (b.name);
 530          msg = msg || "))";
 531       end;
 532 rq_err_msg:
 533       if (msg ^= "")
 534       then call tederror_ (dbase_p, msg);
 535 rq_err:
 536       err_req = req_str;
 537       if (err_go ^= " ")
 538       then do;
 539          err_gol = err_go;
 540 dcl err_gol         char (16);
 541          err_go = "";
 542          code = 0;
 543          call tedset_ptr_ (dbase_p, rtrim (err_gol), code);
 544          if (code = 0)
 545          then goto nx_line;
 546       end;
 547       call tedresetread_ (dbase_p);     /* reset buffer push down stack   */
 548                                         /*  and input buffer                 */
 549       if (ted_mode = COM)
 550       then do;
 551          acode = tederror_table_$ted_com_abort;
 552                                         /* call com_err_ (acode, DBA);       */
 553          call cleaner;
 554          return;
 555       end;
 556       go_sw = "0"b;
 557       b_depth = 0;
 558       goto nx_line;
 559 
 560 got_add:
 561       cb_w_r = rel (bp);                /* remember which we are working on  */
 562       if (rl_i >= rl_l)
 563       then ch = NL;
 564       else ch = rl_c (rl_i);            /* pick up first char. after address */
 565       alt_sw, not_sw = "0"b;
 566       if ch = NL
 567       then do;                          /* if end of line                    */
 568          if b.present (1)               /* and "orphan" address              */
 569          then do;                       /* ...print line(s) referenced       */
 570             if nulreq ^= "p"            /* (chose which way)                 */
 571             then ch = "P";
 572             else ch = "p";
 573          end;
 574          else goto nx_line;             /* ...otherwise, done with line      */
 575       end;
 576       else rl_i = rl_i + 1;             /* bump request line char. index     */
 577 
 578       req_ch, req_str = ch;
 579       req_not, req_chx = "";
 580       if do_req (ch)
 581       then goto nx_line;
 582       goto next;
 583 
 584 exit:
 585       acode = 0;
 586       return;
 587 
 588 dcl (
 589     NX_LIN          init ("1"b),        /* forget rest of request line       */
 590     NX_REQ          init ("0"b)         /* continue execution on same line   */
 591     )               bit (1) int static options (constant); %page;
 592 do_req: proc (rqc) returns (bit (1));   /* returns 1 to abort request line   */
 593                                         /*         0 to continue             */
 594 dcl rqc             char (1);
 595 
 596 
 597       if (rqc < " ") | (rqc > "~") then goto invalid_request_octal;
 598       if ^caps
 599       then if (rqc >= "A") & (rqc <= "Z")
 600            then goto invalid_request;
 601       call tedshow_$init;
 602       goto cmd (rank (rqc));
 603 
 604 dcl fs_util_$suffix_info entry (char (*), char (*), ptr, fixed bin (35)); /* #--c*/
 605 %include copy_flags; /* #--c*/
 606 %include suffix_info; /* #--c*/
 607 dcl 1 SI            like suffix_info;   /* #--c*/
 608 dcl OC              (0:7) char (1) int static init
 609                     ("0", "1", "2", "3", "4", "5", "6", "7");
 610 dcl 1 oct           based (addr (req_ch)),
 611       2 (A, B, C)   bit (3);
 612 
 613 
 614 invalid_request_octal:
 615       msg = "Xrq) Invalid request \***.";
 616       substr (msg, 23, 1) = OC (fixed (oct.A, 35));
 617       substr (msg, 24, 1) = OC (fixed (oct.B, 35));
 618       substr (msg, 25, 1) = OC (fixed (oct.C, 35));
 619       req_str = substr (msg, 24, 4);
 620       goto print_error; %skip (2);
 621 /* . . . invalid requests . . */
 622 /* format: off */
 623 cmd (036):                    /* $  ADDR- last line of buffer                */
 624 cmd (038):                    /* & */
 625 cmd (040):                    /* (  ADDR- begin byte address                 */
 626 cmd (041):                    /* )  ADDR- end byte address                   */
 627 cmd (043):                    /* +  ADDR- positive relative address          */
 628 cmd (044):                    /* ,  ADDR- address separator                  */
 629 cmd (045):                    /* -  ADDR- negative relative address          */
 630 cmd (046):                    /* .  ADDR- current location                   */
 631 cmd (047):                    /* /  ADDR- expression delimiter               */
 632 cmd (048):                    /* 0  ADDR- linenumber/relative                */
 633 cmd (049):                    /* 1  ADDR- "                                  */
 634 cmd (050):                    /* 2  ADDR- "                                  */
 635 cmd (051):                    /* 3  ADDR- "                                  */
 636 cmd (052):                    /* 4  ADDR- "                                  */
 637 cmd (053):                    /* 5  ADDR- "                                  */
 638 cmd (054):                    /* 6  ADDR- "                                  */
 639 cmd (055):                    /* 7  ADDR- "                                  */
 640 cmd (056):                    /* 8  ADDR- "                                  */
 641 cmd (057):                    /* 9  ADDR- "                                  */
 642 cmd (059):                    /* ;  ADDR- address separator                  */
 643 cmd (060):                    /* <  ADDR- backup search marker               */
 644 cmd (063):                    /* ?  ADDR- prefix marker                      */
 645 cmd (064):                    /* @  ADDR- absolute buffer reference          */
 646 cmd (065):                    /* A */
 647 cmd (066):                    /* B */
 648 cmd (067):                    /* C */
 649 cmd (068):                    /* D */
 650 cmd (071):                    /* G */
 651 cmd (073):                    /* I */
 652 cmd (078):                    /* N */
 653 cmd (079):                    /* O */
 654 cmd (086):                    /* V */
 655 cmd (089):                    /* Y */
 656 cmd (090):                    /* Z */
 657 cmd (091):                    /* [  ADDR- range on search                    */
 658 cmd (092):                    /* \ */
 659 cmd (093):                    /* ]  ADDR- range on search                    */
 660 cmd (095):                    /* _ */
 661 cmd (096):                    /* ` */
 662 cmd (125):                    /* }  closing mark of evaluaton                */
 663 invalid_request:;                       /* format: on */
 664       msg = "Xrq) Invalid request ";
 665       msg = msg || req_str;
 666       goto print_error; %skip (6);
 667 /* . . . call       : call specified buffer making parameters available      */
 668 
 669 cmd (037):                              /* % */
 670       call ignore_both;
 671       call tedcall_ (dbase_p, code);
 672       if (code ^= 0)
 673       then goto rq_err;
 674       return (NX_LIN); %page;
 675 /* . . . read       : read in specified file after addressed line in buffer  */
 676 
 677 abbrev: proc (ck_sw);
 678 dcl ck_sw           bit (1) aligned;
 679 
 680       if ck_sw then call ck_blank;
 681       begin;
 682 dcl hold            char (500);
 683 dcl it              fixed bin (21);
 684 dcl abbrev_$expanded_line entry (ptr, fixed bin (21), ptr, fixed bin (21), ptr,
 685                     fixed bin (21));
 686 
 687          i = rl_l - rl_i + 1;
 688          substr (hold, 1, i) = substr (rl_s, rl_i, i);
 689          call abbrev_$expanded_line (addr (hold), i, dbase.rl.sp, 512, tbp,
 690               it);
 691          if (tbp ^= dbase.rl.sp)
 692          then do;
 693             msg = "Iab) Abbrev result >512.";
 694             goto print_error;
 695          end;
 696          rl_i = 1;
 697          if (substr (rl_s, it, 1) ^= NL)
 698          then do;
 699             it = it + 1;
 700             substr (rl_s, it, 1) = NL;
 701          end;
 702          rl_l = it;
 703       end;                              /* begin block */
 704    end abbrev;
 705 
 706 cmd (082):                              /* R */
 707       call abbrev (com1_blank);
 708       if ""b
 709       then do;
 710 cmd (114):                              /* r */
 711          if alt_sw
 712          then call abbrev ("1"b);
 713          else if com1_blank
 714          then call ck_blank;
 715       end;
 716       if ^b.present (1)                 /* if no address given,              */
 717       then b.a_.l.re (1), b.a_.r.le (1) = b.b_.r.re; /*  add to EOB window */
 718       else b.a_.l.re (1) = max (0, b.a_.r.le (1));
 719       call ignore_2;
 720       string (b.bs) = "0"b;             /* reset old-style escape seen       */
 721       if (b.cur.sn ^= 0)                /* if buffer not empty               */
 722       then trustsw = "0"b;              /* ... then can't trust name         */
 723       else trustsw = "1"b;              /* ... else can                      */
 724       wsw = "0"b;
 725       write_l = 0;
 726       if ^b.no_io
 727       then goto get_file;
 728       if (b.cur.sn ^= 0)                /* if buffer not empty               */
 729       then goto not_allowed;            /* ..too bad                         */
 730       call get_the_string;
 731       return (NX_LIN); %page;
 732 /* . . . write      : write out specified contents of buffer into a file     */
 733 
 734 cmd (087):                              /* W */
 735       call abbrev ("1"b);
 736 cmd (119):                              /* w */
 737       if alt_sw
 738       then call abbrev ("1"b);
 739       else if com1_blank
 740       then do;                          /* optional writes                   */
 741          if (rl_c (rl_i) = "m")
 742          then do;                       /* write-modified request            */
 743             req_chx = "m";
 744             req_str = req_str || "m";
 745             rl_i = rl_i + 1;
 746          end;
 747          call ck_blank;
 748          if (req_chx = "m")
 749          then do;
 750             tbi = 2;
 751             call ignore_all;            /* tell 'em we won't take addr's     */
 752             b.present (1), b.present (2) = "1"b; /* make sure none there     */
 753             trustsw = "1"b;
 754             wct = 0;
 755             pi_label = write_loop_pi;
 756             pi_sw = 1;
 757             goto write_loop;
 758 write_loop_error:
 759             call ioa_ ("In b(^a)^/^a", b.name, substr (msg, 6));
 760 write_loop:
 761             tbi = tbi + 1;
 762             if (tbi > bufnum)
 763             then do;
 764 write_loop_pi:
 765                if (wct = 0)
 766                then call ioa_ ("No buffers written.");
 767                return (NX_REQ);
 768             end;
 769             bp = addr (CB (tbi));
 770             if (b.cur.sn = 0) | b.no_io
 771             then goto write_loop;
 772             if ((b.b_.l.re - b.b_.l.le + 1) + (b.b_.r.re - b.b_.r.le + 1) = 0)
 773             then goto write_loop;       /* no data                           */
 774             b.a_.l.re (1) = 1;          /* write whole buffer                */
 775             b.a_.r.le (2) = b.maxl;
 776             svlen = 0;
 777             msg = "";
 778             mustreprotect = "0"b;
 779          end;
 780       end;
 781       if b.no_io
 782       then goto not_allowed;
 783       if b.present (1) & ^b.present (2)
 784            & (b.a_.l.re (1) = 1) & (b.a_.r.le (1) = 0)
 785       then write_l = 0;
 786       else do;
 787          if ^b.present (1)              /* default is whole buffer           */
 788          then do;                       /* ..regardless of window            */
 789             if (b.cur.sn = 0)
 790             then do;
 791                msg = "Abe) Buffer empty.";
 792                goto print_error;
 793             end;
 794             b.a_.l.le (1), b.a_.l.re (1) = 1;
 795             b.a_.r.le (2), b.a_.r.re (2) = b.maxl;
 796             b.present (1), b.present (2) = "1"b;
 797          end;
 798          else call default$whole_buffer;
 799          call addr_status_ends (1, b.maxl);
 800          if (b.a_.l.re (1) ^= b_lhe) | (b.a_.r.le (2) ^= b_rhe)
 801          then trustsw = "0"b;           /* not writing whole thing           */
 802          else trustsw = "1"b;
 803          write_l = b.a_.r.le (2) - b.a_.l.re (1) + 1;
 804          if (b_stat = B_LO_HI)          /* if range spans the hole, take out */
 805          then write_l = write_l - (b.b_.r.le - b.b_.l.re - 1); /* its size  */
 806       end;
 807       wsw = "1"b;
 808       if (req_chx ^= "m")
 809       then do;
 810 get_file:
 811          subfile_name = "%%%%%";        /* to catch uninitilized uses        */
 812          msg = "";
 813          rl_i = rl_i + verify (substr (rl_s, rl_i), " ") - 1;
 814          if (rl_c (rl_i) = "(")         /* its a buffer read or write        */
 815          then do;
 816             if wsw                      /* w (x) is same as m (x) with..     */
 817             then goto mo3;              /*   ..different defaults            */
 818             goto read_buffer;
 819          end;
 820          if b.no_io
 821          then goto not_allowed;
 822          mustreprotect = "0"b;
 823          svlen = rl_l - rl_i;           /* calc length of pathname           */
 824       end;
 825       fd = b.file_d;                    /* pull the remembered file data     */
 826       if (svlen = 0)                    /* if no pathname supplied           */
 827       then do;
 828          if ^fd.file_sw                 /* ...do we have one saved?          */
 829          then do;                       /*  NO                               */
 830             if (req_chx = "m")
 831             then goto write_loop;
 832             msg = "Inp) No pathname given.";
 833             goto print_error;
 834          end;
 835          if ^fd.trust_sw                /* can we trust pathname?            */
 836          then do;
 837             if (ted_mode ^= COM)
 838             then do;
 839                query_info.status_code = 0;
 840                call command_query_ (addr (query_info), answer, DBA,
 841                     "Do you want to ^a with the untrusted pathname ^a>^a^a^a?",
 842                     req_str, fd.dname, fd.ename, fd.kind, fd.cname);
 843                if (substr (answer, 1, 1) = "y")
 844                then do;
 845                   fd.trust_sw = "1"b;   /* looks OK from here                */
 846                   if not_sw
 847                   then trustsw = "1"b;
 848                   goto accept_name;     /* (may look different there)        */
 849                end;
 850             end;
 851             msg = "Int) Can't trust saved pathname ";
 852             call msg_path (fd.kind);
 853             if (req_chx = "m")
 854             then goto write_loop_error;
 855             if (ted_mode = COM)
 856             then goto print_error;
 857             return (NX_LIN);
 858          end;
 859 accept_name:
 860          if not_sw                      /* we must force this name           */
 861          then do;
 862             fd.trust_sw = "1"b;         /* ...remember the fact              */
 863             fd.file_sw = "1"b;          /* ...and indicated that it is saved */
 864             fd.force_name = "1"b;
 865             b.file_d = fd;
 866             return (NX_LIN);
 867          end;
 868          if ^trustsw                    /* if we can't trust pathname after  */
 869          then fd.trust_sw = "0"b;       /* ...this, remember the fact        */
 870          else do;
 871             if ^fd.mod_sw & wsw         /* Don't write unmodified buffer     */
 872                  & (req_chx = "m")      /*  if wm                            */
 873             then goto write_loop;
 874          end;
 875       end;                              /*  (using remembered name)          */
 876 
 877       else do;                          /* process the supplied pathname     */
 878          if b.force_name & not_sw       /* don't let her change a            */
 879          then do;                       /* ..forced name                 #129*/
 880             msg = "Ifp) Cannot change forced pathname.";
 881             call msg_path (b.kind);
 882             goto print_error;
 883          end;
 884          svpath = substr (rl_s, rl_i, svlen);
 885          fd.kind = "";
 886          if ^qedx_mode
 887          then do;
 888             enl = search (reverse (svpath), "<>");
 889             if (enl = 0)
 890             then enl = 1;
 891             else enl = length (svpath) + 2 - enl; /* #157*/
 892             i = index (substr (svpath, enl + 1), "|");
 893             if (i ^= 0)
 894             then do;
 895                i = enl + i - 1;
 896                fd.kind = "|";
 897                subfile_name = substr (svpath, i + 2, svlen - i - 1);
 898                svpath = substr (svpath, 1, i);
 899                if (svlen - i > 32)
 900                then do;
 901                   msg = "Isn) Subfile name too long. ";
 902                   msg = msg || rtrim (svpath);
 903                   call tederror_ (dbase_p, msg);
 904                   goto rq_err;
 905                end;
 906                svlen = i;
 907             end;
 908          end;
 909          if (substr (svpath, 1, 4) = "[pd]")
 910          then do;
 911             if (pdname = " ")
 912             then pdname = get_pdir_ ();
 913             svpath = pdname || substr (svpath, 5, svlen - 4);
 914             svlen = svlen + 28;
 915          end;
 916          call expand_pathname_$component (svpath, fd.dname, fd.ename, fd.cname,
 917               code);
 918          if (code ^= 0)
 919          then do;
 920 bad_path:
 921             msg = rtrim (svpath);
 922             goto print_error_rc;
 923          end;
 924          if (fd.kind = "|")
 925          then fd.cname = subfile_name;
 926          else if (fd.cname ^= "")
 927          then fd.kind = ":";
 928          if trustsw | not_sw            /* if we can trust this pathname     */
 929          then do;
 930             fd.trust_sw = "1"b;         /* ...remember the fact              */
 931             fd.file_sw = "1"b;          /* ...and indicated that it is saved */
 932             fd.force_name = not_sw;
 933             if not_sw                   /* only remembering?                 */
 934             then do;
 935                b.file_d = fd;
 936                return (NX_LIN);
 937             end;
 938          end;
 939          else fd.trust_sw = "0"b;       /* ...mis-trust it                   */
 940       end;
 941 
 942       SI.version = SUFFIX_INFO_VERSION_1; /* #--c*/
 943       call fs_util_$suffix_info (fd.dname, fd.ename, addr (SI), code); /* #--c*/
 944       if (code ^= 0)
 945       then do;                          /* #--c*/
 946                                         /* RW 88 */
 947          if (code = error_table_$unsupported_operation) then do; /* #191*/
 948                                         /* try to get more information about the problem...    /* #191*/
 949             call hcs_$status_minf (fd.dname, fd.ename, 1, 0, 0, code); /* #191*/
 950                                         /* no error: stick with the unsupported op message     /* #191*/
 951                                         /* otherwise use the new error code, whatever it is    /* #191*/
 952             if (code = 0) then          /* #191*/
 953                  code = error_table_$unsupported_operation; /* #191*/
 954          end;                           /* #191*/
 955          if (code = error_table_$noentry) & wsw
 956          then goto make_one;            /* #--c*/
 957          goto get_err;                  /* #--c*/
 958       end;                              /* #--c*/
 959       if (SI.type_name ^= "segment")
 960       then do;                          /* #--c*/
 961          msg = "Ims) Can't process ";   /* #--c*/
 962          msg = msg || SI.type_name;     /* #--c*/
 963          call msg_path (fd.kind);       /* #--c*/
 964          if (req_chx = "m")
 965          then goto write_loop_error;    /* #--c*/
 966          goto print_error;              /* #--c*/
 967       end;                              /* #--c*/
 968 
 969 
 970       call hcs_$initiate_count (fd.dname, fd.ename, "", bc, 0, file_p, code);
 971       if (file_p = null)
 972       then do;
 973          if ^wsw
 974          then goto get_err;
 975          if (fd.kind = ":")
 976          then do;
 977 no_ac_write:
 978             if (req_chx = "m")
 979             then do;
 980                msg = "Xwa) Can't write to an archive. ";
 981                call msg_path (fd.kind);
 982                goto write_loop_error;
 983             end;
 984             call com_err_ (0, DBA, "Can't write to an archive. ^a>^a::^a",
 985                  fd.dname, fd.ename, fd.cname);
 986             goto rq_err;
 987          end;
 988 make_one:                               /* #--c*/
 989          call tedcheck_entryname_ (fd.ename, code);
 990          if (code ^= 0)
 991          then goto bad_path;
 992                                         /* try to create segment             */
 993          call hcs_$make_seg (fd.dname, fd.ename, "", 01011b, file_p, code);
 994          if (file_p = null)
 995          then do;
 996 get_err:
 997             if trustsw & ^wsw
 998                  & ^b.force_name        /* #129*/
 999             then b.file_d = fd;
1000             call msg_path (fd.kind);
1001             call tederror_rc_ (dbase_p, msg, code);
1002             if (req_chx = "m")
1003             then goto write_loop;
1004             goto rq_err;
1005          end;
1006          bc = 0;
1007       end;
1008 
1009 dcl real_dname      char (168);
1010 dcl real_ename      char (32);
1011 
1012       call hcs_$fs_get_path_name (file_p, real_dname, 0, real_ename, code);
1013       call hcs_$status_long (real_dname, real_ename, 1, addr (branch_status),
1014            null, code);
1015       if (branch_status.mode & "01000"b) ^= "01000"b
1016       then do;                          /* #153*/
1017          code = error_table_$insufficient_access; /* #153*/
1018          msg = "";                      /* #153*/
1019          goto get_err;                  /* #153*/
1020       end;                              /* #153*/
1021       file_l = divide (bc, 9, 21, 0);
1022       if wsw                            /* check for WRITE-protected file    */
1023       then do;
1024          if (fd.kind = ":")
1025          then goto no_ac_write;
1026          if b.pseudo                    /* is this a ^read file?             */
1027          then call promote (b.maxl);    /*    materialize it                 */
1028          if (branch_status.mode & "00010"b) ^= "00010"b
1029          then do;                       /* if segment has no w access        */
1030             query_info.status_code = error_table_$moderr;
1031             call command_query_ (addr (query_info), answer, DBA,
1032                  "Do you want to write to the protected ^[file^]^[archive^]"
1033                  || "^[subfile^] ^a>^a^a^a?",
1034                  (fd.kind = " "), (fd.kind = ":"), (fd.kind = "|"),
1035                  fd.dname, fd.ename, fd.kind, fd.cname);
1036             if (substr (answer, 1, 1) = "n")
1037             then do;
1038                if (req_chx = "m")
1039                then goto write_loop;
1040                return (NX_LIN);
1041             end;
1042             seg_acl.userid = get_group_id_ (); /* wants to update            */
1043             seg_acl.access = "1010"b;   /* give user rw                      */
1044             seg_acl.ex_access = "0"b;
1045             call hcs_$add_acl_entries (fd.dname, fd.ename, addr (seg_acl), 1,
1046                  code);
1047             if (code ^= 0)
1048             then do;
1049                msg = "(add_acl) ";
1050                goto get_err;
1051             end;
1052             mustreprotect = "1"b;
1053          end;
1054          bc = write_l * 9;              /* length of data to be written      */
1055       end;
1056 
1057       if (fd.kind = ":")                /* processing an archive             */
1058       then goto find_archive_element;
1059       if (fd.kind = "|")                /* processing a superfile            */
1060       then goto find_subfile;
1061 
1062       if wsw & (write_l = 0)
1063       then do;
1064          sub_type = " subfile ";
1065 x_not_found:
1066          msg = "";
1067          call msg_path ((sub_type));
1068                                         /* RW 88 */
1069          if (sub_type = " component ") then /*#201*/
1070               call tederror_rc_ (dbase_p, msg, (error_table_$no_component)); /*#201*/
1071          else                           /*#201*/
1072               call tederror_rc_ (dbase_p, msg, (error_table_$noentry));
1073          call reprotect;                /* put things back, if necessary     */
1074          if (req_chx = "m")
1075          then goto write_loop;
1076          goto rq_err;
1077       end;
1078 
1079 file_ready:
1080       if ^wsw
1081       then goto read_file;
1082       if (b_stat = B_LO_HI)             /* range is split, move high part    */
1083       then do;                          /*   into file first                 */
1084          i = b.a_.r.le (2) - b.b_.r.le + 1;
1085          call mrl_ (addr (b_c (b.b_.r.le)), i,
1086               addr (file_c (write_l - i + 1)), i);
1087          b.a_.r.le (2) = b.b_.l.re;     /* adjust to look like unsplit       */
1088       end;
1089                                         /* here always looks like unsplit    */
1090       i = b.a_.r.le (2) - b.a_.l.re (1) + 1;
1091 /***** MRL is used to get bounds faults over with ASAP                       */
1092       call mrl_ (addr (b_c (b.a_.l.re (1))), i, file_p, i);
1093       if trustsw
1094       then do;                          /* #129*/
1095          fd.not_pasted = "0"b;          /* #129*/
1096 /****    clear mod_sw if the buffer is not "locked"                      #129*/
1097 /****    or the default pathname is being used                           #129*/
1098          if ^b.force_name | (svlen = 0) /* #129*/
1099          then b.mod_sw, fd.mod_sw, fd.not_pasted = "0"b; /* #129*/
1100       end;                              /* #129*/
1101       b.trust_sw = trustsw;
1102 close_up_file:
1103       if b.force_name
1104       then b.trust_sw = "1"b;           /* #129*/
1105       else if trustsw
1106       then b.file_d = fd;
1107       call terminate_file_ (file_p, (bc), TERM_FILE_TRUNC_BC_TERM, code);
1108       if code ^= 0
1109       then do;
1110          msg = "(truncate) ";
1111          goto get_err;
1112       end;
1113       call reprotect;
1114       if (req_chx = "m")
1115       then do;
1116          wct = wct + 1;
1117          if (wct = 1)
1118          then call ioa_ ("Buffers written:");
1119          call ioa_ ("  (^a)   ^a>^a^a^a", b.name, b.dname, b.ename, b.kind,
1120               b.cname);
1121          goto write_loop;
1122       end;
1123       return (NX_LIN); %skip (3);
1124 reprotect: proc;
1125       if mustreprotect                  /* restore ACL to original state     */
1126       then do;
1127          delete_acl.userid = seg_acl.userid; /* delete ACL                   */
1128          call hcs_$delete_acl_entries (fd.dname, fd.ename,
1129               addr (delete_acl), 1, code);
1130          if code ^= 0
1131          then do;
1132             msg = "(delete_acl) ";
1133             goto get_err;
1134          end;
1135       end;
1136    end reprotect; %skip (3);
1137 read_buffer:
1138       b.cd.r.re = b.a_.r.le (1) + 1;    /* set destination point             */
1139       used = rl_l - rl_i + 1;
1140       call tedget_existing_buffer_ (dbase_p, addr (rl_c (rl_i)),
1141            used, tbp, msg);
1142       rl_l = rl_l + used;
1143       if (tbp = null)
1144       then goto rq_err_msg;
1145       if (tbp -> b.cur.sn = 0)
1146       then do;
1147          msg = "b(";
1148          msg = msg || rtrim (tbp -> b.name);
1149          msg = msg || ")";
1150          call tederror_rc_ (dbase_p, msg, tederror_table_$zero_length_buffer);
1151          goto rq_err;
1152       end;
1153       tbp -> b.cd.l.re = tbp -> b.a_.l.re (1); /* set source range           */
1154       tbp -> b.cd.r.le = tbp -> b.a_.r.le (2);
1155                                         /*  //                               */
1156       b.a_.l.ln (1) = -1;               /* <<----------                      */
1157                                         /*  \\                               */
1158       call buffer_buffer_copy (tbp, bp, "1"b); /* Add to right end for the */
1159                                         /*  same reason that files are added */
1160                                         /*  that way.                        */
1161       b.a_.r.le (2) = b.a_.r.le (1) - 1;/*  [bbc set rle(1) for us]          */
1162       if (b.a_.r.le (2) < 1)            /* buffer was empty                  */
1163       then b.a_.r.le (2) = b.b_.r.re;   /* ..so take end of data             */
1164       call iso_line;
1165       return (NX_LIN); %page;
1166 read_file:
1167       if trustsw & ^b.force_name
1168       then b.file_d = fd;
1169       else b.trust_sw = b.force_name;
1170       if (file_l = 0)
1171       then do;
1172          msg = "";
1173          call msg_path (" ");
1174          call tederror_rc_ (dbase_p, msg, (error_table_$zero_length_seg));
1175          if (req_chx = "m")
1176          then goto write_loop;
1177          return (NX_LIN);
1178       end;
1179       if (b.cur.sp = null ())           /* if buffer empty                   */
1180       then do;
1181          b.dtcm = branch_status.date_time_modified;
1182          b.uid = branch_status.unique_id;
1183       end;
1184 
1185       b.newa = tedcommon_$no_data;
1186       if ^read_sw                       /* if ^read is in effect             */
1187            & (b.cur.sn = 0)             /* ..and buffer is empty             */
1188       then do;                          /* just -> the data                  */
1189          call tedpseudo_ (bp, -1, file_p, file_l);
1190          b.terminate = "1"b;
1191          dbase.not_read_ct = dbase.not_read_ct + 1;
1192          b.initiate = "0"b;
1193          b.ck_ptr_sw = "0"b;
1194          b.a_.r.le (2) = b.b_.l.re;
1195          call iso_line;
1196          return (NX_LIN);
1197       end;
1198       else do;
1199 /**** Various conditions:     (AAAA is addressed string)                     */
1200 /**** xxxxxxxxxxAAAAxxxxxx..........zzzzzzzzzz    openup                     */
1201 /**** xxxxxxxxxx..........AAAAxxxxxxzzzzzzzzzz    add(RIGHT)                 */
1202 /**** xxxxxxxxxx......ffffAAAAxxxxxxzzzzzzzzzz    iso_line                   */
1203 /**** xxxxxxxxxx......zzzzzzzzzzzzzzzzzzzzzzzz                               */
1204 
1205 /**** ........................................    openup                     */
1206 /**** ........................................    add(RIGHT)                 */
1207 /**** ....................................ffff    iso_line                   */
1208 /**** ....................................zzzz                               */
1209 
1210 
1211          if (b.cur.sn = 0)              /* if buffer is empty                */
1212               & ^b.force_name           /* ..and not "locked"            #129*/
1213          then fd.mod_sw = "0"b;         /* ..it is not modified by reading   */
1214          else fd.mod_sw = "1"b;         /* ..otherwise it is.                */
1215          b.a_.l.re (1) = b.a_.l.re (1) + 1;
1216          call openup;                   /* move hole to where we need it     */
1217          call add_2r (ted_safe, file_p, file_l, NLct_unknown);
1218                                         /* copy in specified file            */
1219          b.mod_sw = fd.mod_sw;          /* add doesn't really know           */
1220          b.a_.r.le (2) = b.b_.r.le + file_l - 1;
1221          call iso_line;
1222          call hcs_$terminate_noname (file_p, code); /* don't be sloppy!      */
1223          if (req_chx = "m")
1224          then goto write_loop;
1225          return (NX_LIN);
1226       end; %page;
1227 find_archive_element:
1228       call archive_$get_component (file_p, (bc), fd.cname, ttp, bc, code);
1229       if (code ^= 0)
1230       then do;
1231          sub_type = " component ";
1232          goto x_not_found;
1233       end;
1234       file_p = ttp;                     /* -> component                      */
1235       file_l = divide (bc, 9, 21, 0);
1236       goto file_ready; %skip (3);
1237 find_subfile:                           /* bc already contains size of data  */
1238       subfile_name = rtrim (fd.cname);  /* .. to be written                  */
1239       header_l = length (subfile_name) + 7;
1240       bc = bc + file_l * 9;             /* add in length of existing segment */
1241       if (file_l = 0)                   /* no segment was found,             */
1242       then do;                          /* ..initialize brand new superfile  */
1243          substr (file_s, 1, length (superfile)) = superfile;
1244          file_l = length (superfile);
1245          bc = bc + file_l * 9;          /* add in length of segment header   */
1246          after_l = 0;                   /* nothing after component           */
1247                                         /* (since its not there)             */
1248       end;
1249       else do;                          /* the file already exists           */
1250          xfi = index (file_s, subf1 || subfile_name || subf2);
1251          if (xfi ^= 0)                  /* found the subfile                 */
1252          then do;
1253                                         /* look for end of subfile           */
1254             xfe = index (substr (file_s, xfi + 1), subf1);
1255             if (xfe = 0)
1256             then xfe = file_l - xfi + 1;
1257             after_l = file_l - xfi - xfe + 1; /* ...after  this              */
1258             file_l = xfe - header_l;    /* length of subfile                 */
1259             file_p = addr (file_c (xfi + header_l)); /* -> data              */
1260             if ^wsw
1261             then do;
1262                if db_ted
1263                then call ioa_$ioa_switch (db_output,
1264                          "^10p wl=^i fl=^i al=^i bc=^i",
1265                          file_p, write_l, file_l, after_l, bc);
1266                goto read_file;
1267             end;
1268             bc = bc - file_l * 9;       /* remove length of data being       */
1269                                         /* ..replaced                        */
1270          end;
1271          else after_l = 0;              /* subfile NOT FOUND                 */
1272       end;
1273 
1274       if (write_l ^= 0)                 /* writing a subfile                 */
1275       then do;
1276          if (after_l = 0)
1277          then do;                       /* new subfile, must create header   */
1278             file_p = addr (file_c (file_l + 1)); /* ..at the end             */
1279             substr (file_s, 1, 4) = subf1;
1280             substr (file_s, 5, length (subfile_name)) = subfile_name;
1281             substr (file_s, length (subfile_name) + 5, 3) = subf2;
1282             file_p = addr (file_c (header_l + 1));
1283             file_l = write_l;
1284             bc = bc + header_l * 9;     /* add in length of new header       */
1285          end;
1286                                         /* move past the header              */
1287          if db_ted
1288          then call ioa_$ioa_switch (db_output, "^10p wl=^i fl=^i al=^i bc=^i",
1289                    file_p, write_l, file_l, after_l, bc);
1290          if (after_l > 0)
1291          then do;
1292             if (file_l > write_l)       /* more found than being written,    */
1293             then do;                    /* ..close up hole in file           */
1294 (nostringrange):
1295                substr (file_s, write_l + 1, after_l)
1296                     = substr (file_s, file_l + 1, after_l);
1297             end;
1298             else if (file_l < write_l)  /* less found than being written,    */
1299             then do;                    /* ..open up hole in file            */
1300                call mrl_ (addr (file_c (file_l + 1)), after_l,
1301                     addr (file_c (write_l + 1)), after_l);
1302             end;
1303          end;
1304          goto file_ready;
1305       end;
1306                                         /* deleting a subfile                */
1307       if (after_l > 0)
1308       then do;                          /* move the following data down      */
1309 (nostringrange):
1310          substr (file_s, 1, after_l) = substr (file_s, file_l + 1, after_l);
1311       end;
1312       goto close_up_file; %page;
1313 /* . . .  request   : clean up and exit from ted editor (i.e., return to     */
1314 /*                    caller)                                                */
1315 
1316 cmd (113):                              /* q */
1317       if ^alt_sw & (substr (rl_s, rl_i, 1) = "f") /* #160*/
1318       then do;                          /* #160*/
1319          rl_i = rl_i + 1;               /* #160*/
1320          goto cmd (081);
1321       end;
1322       if ^alt_sw & (substr (rl_s, rl_i, 5) = "hold
1323 ")
1324       then do;
1325          if ted_safe
1326          then do;
1327             do tbi = 3 to bufnum;
1328                bp = addr (CB (tbi));
1329                if (b.cur.sn > 2) & ^b.pseudo
1330                then call promote$seg;   /* clean up garbage'ed words         */
1331             end;
1332             call tedhold_ (dbase_p);
1333             goto exit;
1334          end;
1335          msg = "Xns) Not in -safe mode";
1336          goto print_error;
1337       end;
1338    /*** special syntax checks for quit request                           #160*/
1339       if (b.present (1))
1340       then goto syntax_error;           /* #160*/
1341       if (rl_c (rl_i) ^= NL)
1342       then do;                          /* #160*/
1343          rl_i = rl_i + verify (substr (rl_s, rl_i), SP_HT) - 1; /* #160*/
1344          if (rl_c (rl_i) ^= NL)
1345          then goto syntax_error;        /* #160*/
1346       end;                              /* #160*/
1347       if ^alt_sw
1348 /****            & ^qedx_mode                                            #159*/
1349       then do;
1350 /**** really need to search for b0 since it could have been deleted          */
1351          save_mod = b0_bp -> b.mod_sw;
1352          if (ted_data.input_p ^= null ())
1353          then b0_bp -> b.mod_sw = "0"b;
1354          call tedcheck_buffers_ (dbase_p, wct);
1355          b0_bp -> b.mod_sw = save_mod;
1356          if (wct ^= 0)
1357          then do;
1358             query_info.status_code = 0;
1359             call command_query_ (addr (query_info), answer, DBA,
1360                  "Do you still wish to quit?");
1361             if (substr (answer, 1, 1) = "n")
1362             then return (NX_LIN);
1363          end;
1364       end;
1365 cmd (081):                              /* Q */
1366    /*** special syntax checks for quit request                           #160*/
1367       if (b.present (1))
1368       then goto syntax_error;           /* #160*/
1369       if (rl_c (rl_i) ^= NL)
1370       then do;                          /* #160*/
1371          rl_i = rl_i + verify (substr (rl_s, rl_i), SP_HT) - 1; /* #160*/
1372          if (rl_c (rl_i) ^= NL)
1373          then goto syntax_error;        /* #160*/
1374       end;                              /* #160*/
1375       bp = af_bp;
1376       if (bp ^= null ())
1377       then do;
1378          af_value = "";
1379          call addr_status_ends_set (1, b.maxl);
1380          if (b_stat ^= B_MT)
1381          then do;
1382             if (b_stat ^= B_HI_HI)      /* range is split, add low part     */
1383             then do;                    /* ..in first                        */
1384                af_value = af_value || substr (b_s, 1, b.b_.l.re);
1385                if (b_stat = B_LO_HI)
1386                then b_stat = B_HI_HI;
1387             end;
1388             if (b_stat ^= B_LO_LO)
1389             then do;
1390                af_value = af_value
1391                     || substr (b_s, b.b_.r.le, b.maxl - b.b_.r.le + 1);
1392             end;
1393          end;
1394       end;
1395       if (ted_data.input_p ^= null ())
1396       then do;
1397          bp = b0_bp;
1398 /**** b0_bp approach wrong because b0 could be deleted and then some other   */
1399 /****  buffer use its slot, while b0 gets regenerated somewhere else.        */
1400          call addr_status_ends_set (1, b.maxl);
1401          if (b_stat ^= B_MT)
1402          then do;
1403             write_l = (b.b_.l.re - b.b_.l.le + 1)
1404                  + (b.b_.r.re - b.b_.r.le + 1);
1405             if (ted_data.output_p ^= null ()) /* an output segment supplied  */
1406             then do;
1407                ted_data.output_l = write_l;
1408                tbp = ted_data.output_p;
1409                b.mod_sw = "1"b;         /* force it modified                 */
1410             end;
1411             else if b.mod_sw            /* don't replace input segment       */
1412             then do;                    /* ..unless it's changed             */
1413                ted_data.input_l = write_l;
1414                tbp = ted_data.input_p;
1415             end;
1416             if b.mod_sw
1417             then do;
1418                if (b_stat = B_LO_HI)    /* range is split, move high part    */
1419                then do;                 /*   into segment first              */
1420                   i = b.a_.r.le (2) - b.b_.r.le + 1;
1421                   call mrl_ (addr (b_c (b.b_.r.le)), i,
1422                        addr (tbp -> file_c (write_l - i + 1)), i);
1423                   b.a_.r.le (2) = b.b_.l.re; /* adjust to look unsplit      */
1424                end;
1425                                         /* here always looks like unsplit    */
1426                i = b.a_.r.le (2) - b.a_.l.re (1) + 1;
1427 /***** MRL is used to get bounds faults over with ASAP                       */
1428                call mrl_ (addr (b_c (b.a_.l.re (1))), i, tbp, i);
1429             end;
1430          end;
1431       end;
1432       call cleaner;
1433       goto exit;                        /* and return to caller of ted       */
1434 %page;
1435 /* . . . line-feed  :                                                        */
1436 
1437 cmd (076):                              /* L */
1438       ttp = iox_$error_output;
1439       goto line_feed;
1440 cmd (108):                              /* l */
1441       if alt_sw
1442       then ttp = iox_$error_output;
1443       else ttp = iox_$user_output;
1444 line_feed:
1445       if com_blank then call ck_blank;
1446       call ignore_all;
1447       call iox_$put_chars (ttp, addr (NL), 1, 0);
1448       return (NX_REQ);
1449 %skip (4);
1450 /* . . . print      : print out specified portion of current buffer file on  */
1451 /*                    user's console                                         */
1452 
1453 cmd (112):                              /* p */
1454       if com_blank then call ck_blank;
1455       call default$cur_line;
1456       if alt_sw then goto PRINTb;
1457       call print;
1458       call iso_line;                    /* set "." to last line printed   */
1459       return (NX_REQ); %skip (4);
1460 /* . . . delete     : delete specified lines from current buffer             */
1461 
1462 cmd (100):                              /* d */
1463       if com1_blank then call ck_blank;
1464       call default$cur_line_extend;
1465       call delete;                      /* what about when last char?        */
1466       call iso_line;
1467       return (NX_REQ); %page;
1468 /* . . . append     : after addressed line                                   */
1469 /****           b.a_.l.re(1)    b.a_.r.le (1)                                */
1470 /**** Addr:                |    |                                            */
1471 /****               xxxxxxxAAAAAAxxxxx.............yyyy                      */
1472 /**** adjust to:                 |                                           */
1473 /****                         b.a_.l.re (1)                                  */
1474 
1475 cmd (097):                              /* a */
1476       if com1_blank then call ck_blank;
1477       if (b.cur.sn = 0)                 /* if buffer empty                   */
1478       then b.a_.r.re (1), b.a_.r.le (1) = 0;
1479       else if ^b.present (1)
1480       then call default$cur_line_extend;
1481       call ignore_2;
1482       b.a_.l.re (1) = b.a_.r.le (1) + 1;
1483       goto in_mode; %skip (3);
1484 /* . . . change     : replace addressed line(s)                              */
1485 /****           b.a_.l.re(1)    b.a_.r.le (2)                                */
1486 /**** Addr:                |    |                                            */
1487 /****               xxxxxxxAAAAAAxxxxx.............yyyy                      */
1488 /**** adjust to:    xxxxxxx...................xxxxxyyyy                      */
1489 /****                                         |                              */
1490 /****                                   b.a_.l.re (1)                        */
1491 
1492 cmd (099):                              /* c */
1493       if com1_blank then call ck_blank;
1494       call default$cur_line;
1495       call delete;
1496       b.a_.l.re (1) = b.b_.r.le;
1497       goto in_mode; %skip (3);
1498 /* . . . insert     : before addressed line                                  */
1499 /****           b.a_.l.re(1)    b.a_.r.le (1)                                */
1500 /**** Addr:                |    |                                            */
1501 /****               xxxxxxxAAAAAAxxxxx.............yyyy                      */
1502 /**** adjust to:           |                                                 */
1503 /****               b.a_.l.re (1)                                            */
1504 cmd (105):                              /* i */
1505       if com1_blank then call ck_blank;
1506       if (b.cur.sn = 0)                 /* if buffer empty                   */
1507       then b.a_.l.le (1), b.a_.l.re (1) = 1;
1508       else call default$cur_line_extend;
1509       call ignore_2;
1510 %skip (5);
1511 in_mode:                                /* ---common code---                 */
1512       if (b.cur.sn = 0)
1513       then b.trust_sw = b.force_name;
1514       call openup;
1515       EOF = "0"b;
1516       if alt_sw
1517       then which_mode = "BULK";
1518       else do;
1519          which_mode = "INPUT";
1520          if (rl_c (rl_i) = NL)          /* skip NL or                        */
1521               | (rl_c (rl_i) = SP)      /* ..blank immediately following     */
1522          then rl_i = rl_i + 1;          /* .. input request                  */
1523 scan_req_line:
1524          k = index (substr (rl_s, rl_i), "\"); /* Any escapes?               */
1525          if (k = 0)                     /* if not found                      */
1526          then k = rl_l - rl_i + 1;      /*  take rest of line                */
1527          else k = k - 1;                /*  take everything up to there      */
1528          if (k > 0)                     /* if anything in between            */
1529          then do;                       /* ...add it to buffer               */
1530             call add_2l (ted_safe, addr (rl_c (rl_i)), k, NLct_check);
1531             rl_i = rl_i + k;
1532          end;
1533          if (rl_i <= rl_l)              /* if something left, handle it    */
1534          then do;
1535             k = index ("fcFC", rl_c (rl_i + 1));
1536             if (k > 2) then k = k - 2;
1537             if (k > 0)
1538             then do;
1539                rl_i = rl_i + 2;         /* skip the \f or \c                 */
1540                if (k = 1)
1541                then goto input_finish;
1542             end;
1543                                         /* just copy char across             */
1544             call add_2l (ted_safe, addr (rl_c (rl_i)), 1, NLct_check);
1545             rl_i = rl_i + 1;
1546             goto scan_req_line;
1547          end;
1548       end;
1549 
1550       if (b.cur.sn = 0)                 /* if no buffer there,               */
1551       then call promote (1);            /* ..get one                         */
1552       pi_label = input_pi;
1553       pi_sw = 3;
1554 
1555       b.INPUT = "1"b;                   /* indicate INPUT in progress    #156*/
1556       do while (which_mode ^= "EOF");
1557          k = b.b_.l.re;                 /* remember last char filled         */
1558          call tedread_ptr_ (dbase_p,    /* -> database                       */
1559               b.cur.sp,                 /* -> buffer                         */
1560               k,                        /* last char used in buffer          */
1561               b.b_.r.le - 2,            /* last char usable                  */
1562               b.b_.l.re,                /* last char filled             [OUT]*/
1563               which_mode);              /* mode                              */
1564 input_pi:
1565          k = b.b_.l.re - k;             /* how many characters were input    */
1566          if (k > 0)
1567          then b.mod_sw = "1"b;
1568          if (chars_moved >= 0)          /* count the chars that were put     */
1569          then chars_moved = chars_moved + k; /* ..the data buffer            */
1570          if (b.b_.l.ln ^= -1)
1571          then do;
1572                                         /* count NLs */
1573          end;
1574          b.maxln = -1;                  /* say we don't know # lines         */
1575          if (which_mode = "\R\F")
1576          then goto input_over;
1577          if (which_mode ^= "EOF")
1578          then call promote (b.b_.r.le - b.b_.l.re + 2); /* get more room   */
1579       end;
1580 
1581 input_over:
1582       if (b.b_.l.re < b.b_.l.le)        /* if no data present,               */
1583            & (b.b_.r.re < b.b_.r.le)
1584       then call delete$all;
1585       else do;
1586 input_finish:
1587          b.a_.r.le (2) = b.b_.l.re;
1588          b.a_.r.ln (2) = b.b_.l.ln;
1589       end;
1590       call iso_line;                    /* "."-> last line input             */
1591       if db_ted
1592       then call tedshow_ (bp, ". inp bcb");
1593       if (which_mode = "\R\F")
1594       then goto eof_err;
1595       return (NX_REQ); %page;
1596 
1597 cmd (074):                              /* J */
1598       alt_sw = "1"b;
1599 
1600 cmd (106):                              /* j */
1601       call scan;
1602       if com_blank then call ck_blank;
1603       if (substr (rl_s, expr_b, expr_l) = "?")
1604       then do;
1605          call tedsort_$show;
1606          return (NX_REQ);
1607       end;
1608       if (substr (rl_s, expr_b, 2) = "s=")
1609       then do;
1610          call tedsort_$set (substr (rl_s, expr_b + 2, expr_l - 2));
1611          return (NX_REQ);
1612       end;
1613       call default$whole_buffer;        /* Default: sorting whole window     */
1614       ii = i;
1615       do sort_l = 1 to 3;
1616          sort_sn (sort_l) = 0;
1617          call tedget_segment_ (dbase_p, sort_p (sort_l), sort_sn (sort_l));
1618       end;
1619       if alt_sw
1620       then do;
1621          expr_b = expr_b - 1;
1622          rl_c (expr_b) = "s";
1623          expr_l = expr_l + 1;
1624       end;
1625       rl_b = expr_b;
1626       call openup;
1627 dcl sort_l          fixed bin (21);     /* @@@@ */
1628       call tedsort_ (addr (rl_c (expr_b)), expr_l,
1629            addr (b_c (b.a_.l.re (1))), b.a_.r.le (2) - b.a_.l.re (1) + 1,
1630            sort_p, sort_l,
1631            msg, code);
1632       call tedfree_segment_ (dbase_p, sort_sn (1));
1633       call tedfree_segment_ (dbase_p, sort_sn (2));
1634       if (code ^= 0)
1635       then do;
1636          call tedfree_segment_ (dbase_p, sort_sn (3));
1637          if (code = 2)                  /* only 1 line sorted                */
1638          then return (NX_REQ);
1639          rl_i = expr_b + expr_l - 1;
1640          goto add_request;
1641       end;
1642       else do;                          /* there's a window here where ^safe */
1643          b.b_.r.le = b.a_.r.le (2) + 1; /* delete old copy                   */
1644          call add_2l (ted_safe, sort_p (3), sort_l, NLct_unknown);
1645          b.a_.r.le (2) = b.b_.l.re;
1646          call iso_line;
1647          call tedfree_segment_ (dbase_p, sort_sn (3));
1648          return (NX_REQ);
1649       end;
1650       goto rq_err; %skip (3);
1651 /* . . . type       : type a string                                          */
1652 
1653 cmd (084):                              /* T */
1654       ttp = iox_$error_output;
1655       goto type;
1656 cmd (116):                              /* t */
1657       if alt_sw
1658       then ttp = iox_$error_output;
1659       else ttp = iox_$user_output;
1660 type:
1661       call ignore_all;
1662       call scan;
1663       if com_blank then call ck_blank;
1664       call iox_$put_chars (ttp, addr (rl_c (expr_b)), (expr_l), 0);
1665       return (NX_REQ); %skip (3);
1666 /* . . . not        : inverse of a request (sorta)                           */
1667 
1668 cmd (039):                              /* ' */
1669 cmd (094):                              /* ^ */
1670 
1671       req_chx, ch = rl_c (rl_i);
1672       req_str = req_str || req_chx;
1673       rl_i = rl_i + 1;
1674       not_sw = "1"b;
1675       if (index ("#*>rb", req_chx) = 0)
1676       then goto invalid_request;
1677       req_not = req_ch;
1678       req_ch = req_chx;
1679       req_chx = " ";
1680       req_not = " ";
1681       goto cmd (rank (req_ch)); %skip (4);
1682 /* . . . alternate  : alternate form of a few requests                       */
1683 
1684 cmd (033):                              /* ! */
1685 
1686       if (substr (DBA, 1, 1) = "q")
1687       then goto invalid_request;
1688       req_chx, ch = rl_c (rl_i);
1689       req_str = req_str || req_chx;
1690       rl_i = rl_i + 1;
1691       alt_sw = "1"b;
1692       if (index ("abcefijklmnpqrstuwx!", req_chx) = 0)
1693       then goto invalid_request;
1694       if (req_chx = "!")                /* this is slipped in to handle      */
1695       then req_ch = "|";                /*    when a user has no "|" on his  */
1696       else do;                          /*    keyboard, i.e. unmodified      */
1697          req_not = "!";                 /*    Apple ][                       */
1698          req_ch = req_chx;
1699       end;
1700       req_chx = " ";
1701                                         /* RW 88 */
1702       if (req_ch = "f") then req_ch = "F"; /*#194*/
1703       goto cmd (rank (req_ch)); %page;
1704 /* . . . substitute : replace all occurences of str1 with str2               */
1705 
1706 cmd (042):                              /*"*"*/
1707 if:
1708       call scan;
1709       if com_blank then call ck_blank;
1710       call default$cur_line;
1711       if (expr_l > 0)
1712       then call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
1713                 addr (dbase.regexp), (string_sw), (dbase.lit_sw), msg, code);
1714       call tedsrch_$search (addr (dbase.regexp), bp,
1715            b.a_.l.re (1), b.a_.r.le (2), mi, me, me2, msg, code);
1716       if (code = 2)                     /* syntax error                      */
1717       then goto print_error;
1718       if (code = 0)
1719       then return (not_sw);             /* search succeeded                  */
1720       else return (^not_sw);            /* search failed                     */ %skip (5);
1721 cmd (083):                              /* S */
1722       subsw = "1"b;                     /* init switch so cannot fail        */
1723       if ""b
1724       then do;
1725 
1726 cmd (115):                              /* s */
1727          subsw = "0"b;                  /* init switch to nothing found yet  */
1728          if alt_sw
1729          then subsw = "1"b;             /*  wait! make it no-fail            */
1730       end;
1731       call default$cur_line;
1732       call scan;                        /* isolate str1 from request line    */
1733       call init_cfp (sub_p, repl_exp);
1734       gvx.tot_len = 0;
1735       call replace$compile;             /* compile str2                      */
1736       cf.op = 0;
1737       call end_cf;
1738 dcl repl_exp        char (500);
1739       if com_blank then call ck_blank;
1740       if (expr_l > 0)
1741       then call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
1742                 addr (dbase.regexp), (string_sw), (dbase.lit_sw), msg, code);
1743       if (code = 2)
1744       then goto print_error;
1745       dbase.S_count = 0;
1746       call init_cfp (sub_p, repl_exp);
1747       call substitute (addr (dbase.regexp)); /* cfp -> replace               */
1748 
1749    /*** code = 8 => search failed                                            */
1750       if ^subsw                         /* error if nothing found            */
1751       then do;
1752          if (err_go = "")               /* if user does not want to catch    */
1753                                         /*  errors attempt to pop buffer     */
1754          then call tedend_buffer_ (dbase_p, code); /*  recur stack    */
1755          if code = 0
1756          then return (NX_LIN);          /* and continue in calling buffer    */
1757          msg = "Xsf) Substitute failed.";
1758          goto print_error;
1759       end;
1760       return (NX_REQ); %page;
1761 /* . . . TRANSLATE UPPER/LOWER . . */
1762 
1763 cmd (085):                              /* U */
1764 cmd (117):                              /* u */
1765 
1766       call scan;
1767       call ck_blank;
1768       call default$cur_line;
1769       if b.pseudo
1770       then call promote (b.maxl);       /* change buffer into real one       */
1771       if (expr_l > 0)
1772       then call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
1773                 addr (dbase.regexp), (string_sw), (dbase.lit_sw), msg, code);
1774       call upper_lower (addr (dbase.regexp), (req_ch = "U") | alt_sw);
1775       return (NX_REQ); %skip (3);
1776 /* . . . option request       : set or display options */
1777 
1778 cmd (111):                              /* o */
1779       if (rl_i = rl_l)
1780       then do;
1781                                         /* RW 88 */ /*#200*/
1782          call ioa_ ("^a^[(^a)^;^s^][^i]^[safe^] ^[part_^]^[^;^^^]blank,"
1783               || "^[^;^^^]caps,^[^;^^^]resetread,^[^;^^^]break,^[^;^^^]edit,"
1784               || "^[^;^^^]input,^[^;^^^]label,^[^;^^^]read,^[^;^^^]old-style,"
1785               || "^[^;^^^]g*NL,"
1786               || "^[^;^^^]string,null=^a^[^/^-comment=""^a""^]",
1787 
1788               DBA, (DBA = "ted"), ted_vers, dbase.recurs, (dbase.dir_db ^= ""),
1789               (com_blank ^= com1_blank), com_blank, caps, reset_read,
1790               break_sw, edit_sw, input_sw, flow_sw,
1791               read_sw, old_style, gvNL, string_sw, nulreq,
1792               (dbase.comment ^= ""), dbase.comment);
1793       end;
1794       else do;
1795          substr (rl_s, rl_l, 1) = " ";
1796          do rl_i = rl_i to rl_l;
1797             if (substr (rl_s, rl_i, 1) ^= " ")
1798                  & (substr (rl_s, rl_i, 1) ^= ",")
1799             then do;
1800                if (substr (rl_s, rl_i, 1) = "^")
1801                then do;
1802                   not_sw = "1"b;
1803                   rl_i = rl_i + 1;
1804                end;
1805                else not_sw = "0"b;
1806 dcl optlen          fixed bin;
1807                if (substr (rl_s, rl_i, 4) = "edit")
1808                then do;
1809                   optlen = 4;
1810                   edit_sw = ^not_sw;
1811                end;
1812                else if (substr (rl_s, rl_i, 5) = "input")
1813                then do;
1814                   optlen = 5;
1815                   input_sw = ^not_sw;
1816                end;
1817                else if (substr (rl_s, rl_i, 2) = "on")
1818                then do;
1819                   optlen = 2;
1820                   input_sw, edit_sw = "1"b;
1821                end;
1822                else if (substr (rl_s, rl_i, 5) = "trace")
1823                then do;
1824                   optlen = 5;
1825                   input_sw, edit_sw = ^not_sw;
1826                end;
1827                else if (substr (rl_s, rl_i, 3) = "off")
1828                then do;
1829                   optlen = 3;
1830                   input_sw, edit_sw = "0"b;
1831                end;
1832                else if (substr (rl_s, rl_i, 5) = "label")
1833                then do;
1834                   optlen = 5;
1835                   flow_sw = ^not_sw;
1836                end;
1837                else if (substr (rl_s, rl_i, 9) = "partblank")
1838                then do;
1839                   optlen = 9;
1840                   com_blank = "0"b;
1841                   com1_blank = ^not_sw;
1842                end;
1843                else if (substr (rl_s, rl_i, 5) = "blank")
1844                then do;
1845                   optlen = 5;
1846                   com_blank, com1_blank = ^not_sw;
1847                end;
1848                else if (substr (rl_s, rl_i, 4) = "caps")
1849                then do;
1850                   optlen = 4;
1851                   caps = ^not_sw;
1852                end;
1853                else if (substr (rl_s, rl_i, 4) = "read")
1854                then do;
1855                   optlen = 4;
1856                   read_sw = ^not_sw;
1857                end;
1858                else if (substr (rl_s, rl_i, 9) = "resetread")
1859                then do;
1860                   optlen = 9;
1861                   reset_read = ^not_sw;
1862                end;
1863                else if (substr (rl_s, rl_i, 5) = "break")
1864                then do;
1865                   optlen = 5;
1866                   break_sw = ^not_sw;
1867                end;
1868                else if (substr (rl_s, rl_i, 9) = "old-style")
1869                then do;
1870                   optlen = 9;
1871                   old_style = ^not_sw;
1872                end;
1873                else if (substr (rl_s, rl_i, 4) = "g*NL")
1874                then do;
1875                   optlen = 4;
1876                   gvNL = ^not_sw;
1877                end;
1878                else if (substr (rl_s, rl_i, 5) = "null=")
1879                then do;
1880                   optlen = 5;
1881                   i = 0;
1882                   if (substr (rl_s, rl_i + 5, 2) = "!p")
1883                   then i = 2;
1884                   if (index ("pP", substr (rl_s, rl_i + 5, 1)) ^= 0)
1885                   then i = 1;
1886                   if i = 0
1887                   then goto inv_opt;
1888                   nulreq = substr (rl_s, rl_i + 5, i);
1889                   optlen = optlen + i;
1890                end;
1891                else if (substr (rl_s, rl_i, 9) = "comment=""")
1892                then do;
1893                   optlen = 9;
1894                   i = index (substr (rl_s, rl_i + 9), """");
1895                   if (i = 0)
1896                   then do;
1897                      call ioa_ ("Missing terminal quote on comment");
1898                      return (NX_LIN);
1899                   end;
1900                   dbase.comment = substr (rl_s, rl_i + 9, i - 1);
1901                   optlen = optlen + i;
1902                end;
1903                else if (substr (rl_s, rl_i, 2) = "ct") /* OBSOLETE! */
1904                then do;
1905                   optlen = 2;
1906                   call ioa_ ("ct= ^i", dbase.S_count);
1907                end;
1908                else if (substr (rl_s, rl_i, 2) = "gv")
1909                then do;
1910                   optlen = 2;
1911                   call gv_dump;
1912                end;
1913                else if (substr (rl_s, rl_i, 1) = "*")
1914                then do;
1915                   optlen = rl_l - rl_i + 1;
1916                   call tedshow_ (bp, "> opt", substr (rl_s, rl_i + 1), "<");
1917                end;
1918                else if (substr (rl_s, rl_i, 2) = "??")
1919                then do;
1920                   optlen = 2;
1921                   call ioa_ ("gv        gv_dump");
1922                   call ioa_ ("*xx       tedshow xx");
1923                end;
1924                else do;
1925 inv_opt:
1926                   msg = "Xio) Invalid option ";
1927                   msg = msg || substr (rl_s, rl_i,
1928                        rl_l - rl_i);
1929                   goto print_error;
1930                end;
1931                rl_i = rl_i + optlen - 1;
1932             end;
1933          end;
1934       end;
1935       return (NX_LIN); %page;
1936 /* . . .  execute request     : pass remainder of line to command processor  */
1937 
1938 cmd (069):                              /* E */
1939 cmd (101):                              /* e */
1940       if com1_blank then call ck_blank;
1941       call ignore_both;
1942       substr (rl_s, 1, rl_i - 1) = SP;  /* blank out up to here      */
1943       if (req_str ^= "e")
1944       then call iox_$put_chars (iox_$user_output, addr (rl_c (rl_i)),
1945                 rl_l - rl_i + 1, 0);
1946       pi_label = kill_execute;          /* allow request to be aborted       */
1947       pi_sw = 1;                        /* by means of a PI                  */
1948       call tedset_ck_ptr_ (dbase_p);
1949       call cu_$cp (dbase.rl.sp, rl_l, code);
1950 kill_execute:
1951       pi_sw = 0;                        /* disable PI upon return            */
1952       if fo_sw
1953       then fop -> b.get_bit_count = "0"b;
1954                                         /* delete    #152*/
1955       return (NX_LIN);                  /* get fresh request line from input stream */
1956 %skip (5);
1957 /* these routines are support for the dynamic call mechanism                 */
1958 ckpt: proc (p1, p2);
1959 
1960 dcl (p1, p2)        fixed bin (21);
1961                                         /* Temporarily unsupported           */
1962 /****      ofe = p2;                                                         */
1963 /****      ifse = p1;                                                        */
1964 
1965    end ckpt; %skip (2);
1966 getreq: proc ();
1967 
1968       call tedread_ptr_ (dbase_p, dbase.rl.sp, 0, dbase.rl.r.re,
1969            ted_sup.req.de, "|DATA");
1970       if (chars_moved >= 0)             /* count number of chars he asked to */
1971       then chars_moved = chars_moved + ted_sup.req.de; /* ..be gotten        */
1972 
1973    end getreq;
1974 %page;
1975 
1976 /* . . . dynamic call         : call ted support routine (perhaps user-written) */
1977 cmd (124):                              /* | */
1978       i = verify (substr (rl_s, rl_i),
1979            "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz");
1980       if (i = 1)
1981       then goto err_Snf;
1982       msg = "ted_";
1983       msg = msg || substr (rl_s, rl_i, i - 1);
1984       msg = msg || "_";
1985       req_str = req_str || substr (rl_s, rl_i, i - 1);
1986       rl_i = rl_i + i - 1;
1987       call ck_blank;
1988       rl_i = rl_i + 1;
1989       if (rl_i > rl_l)
1990       then rl_c (rl_i) = NL;
1991       if (b.cur.sn = 0)
1992       then do;
1993          b.a_.l.re (1) = 1;
1994          b.a_.r.le (2) = 0;
1995       end;
1996       else call default$cur_line;
1997 do_call:                                /* entry for old request simulators */
1998       call hcs_$make_ptr (codeptr (do_call), (msg), (msg), file_p, code);
1999       if (code ^= 0)
2000       then goto print_error_rc;
2001       ted_sup.version = ted_support_version_2;
2002       ted_sup.addr_ct = 0;
2003       if b.present (1)
2004       then ted_sup.addr_ct = 1;
2005       if b.present (2)
2006       then ted_sup.addr_ct = ted_sup.addr_ct + 1;
2007 
2008 /**** All the stuff relating to the ted_sup.inp.* values have to be handled  */
2009 /**** so that it will give the proper view when a window is in effect.       */
2010 
2011       b.a_.l.re (2) = b.a_.l.re (1);    /* save beginning address where it   */
2012                                         /* ..will be relocated               */
2013       b.a_.l.re (1) = b.b_.r.re + 1;    /* pack data within window           */
2014       call openup;                      /* ..to left End                     */
2015       b.a_.l.re (1) = b.a_.l.re (2);    /* restore beginning address         */
2016       call tedcount_lines_ (bp,         /*b.b_.l.le + 1,                           #--a*/
2017            b.b_.l.le, b.a_.l.re (1), ted_sup.inp.lno);
2018       ted_sup.inp.lno = max (ted_sup.inp.lno, 1); /* #--a*/
2019       ted_sup.inp.pt = addr (b_c (b.b_.l.le));
2020       ted_sup.inp.sb = b.a_.l.re (1) - b.b_.l.le + 1;
2021       ted_sup.inp.se = min (b.a_.r.le (2), b.b_.r.le) - b.b_.l.le + 1;
2022       ted_sup.inp.de = b.b_.l.re - b.b_.l.le + 1;
2023       if db_ted
2024       then call ioa_$ioa_switch (db_output, "inp.pt = ^10p inp.sb=^5i inp.se=^5i inp.de=^5i",
2025                 ted_sup.inp.pt, ted_sup.inp.sb, ted_sup.inp.se, ted_sup.inp.de);
2026       sort_sn (1) = 0;
2027       call tedget_segment_ (dbase_p, ted_sup.out.pt, sort_sn (1));
2028       ted_sup.out.de = ted_sup.inp.sb - 1;
2029       substr (ted_sup.out.pt -> b_s, 1, ted_sup.out.de)
2030            = substr (ted_sup.inp.pt -> b_s, 1, ted_sup.out.de);
2031 
2032       ted_sup.out.ml = 1048184;
2033       if db_ted
2034       then call ioa_$ioa_switch (db_output, "out.pt = ^10p out.de=^5i",
2035                 ted_sup.out.pt, ted_sup.out.de);
2036       ted_sup.current = 0;              /* "." undefined                     */
2037       ted_sup.req.pt = dbase.rl.sp;     /* make request line available       */
2038       ted_sup.req.de, ted_sup.req.nc = rl_l;
2039       ted_sup.req.cc = rl_i;
2040       ted_sup.req.ml = dbase.rl.r.re;
2041       ted_sup.string_mode = string_sw;
2042 /****      ifse = 0;                                                         */
2043 /****      iife = b.b_.r.re;                                                 */
2044       ted_sup.checkpoint = ckpt;
2045       ted_sup.get_req = getreq;
2046       ted_sup.proc_expr = tedglobal_$proc_expr;
2047       ted_sup.do_global = tedglobal_$do_global;
2048 dcl tedglobal_$proc_expr entry (ptr, char (168) var, fixed bin (35));
2049 dcl tedglobal_$do_global entry (entry (), char (1), ptr, char (168) var,
2050                     fixed bin (35));
2051       ted_sup.reg_exp_p = addr (dbase.regexp);
2052       ted_sup.bcb_p = bp;
2053       msg = "";                         /* clean up message                  */
2054       code = 0;                         /* ..and return code                 */
2055       pi_label = nochange;              /* allow PI to abort the action      */
2056       pi_sw = 1;
2057 
2058 call_again:
2059       call cu_$ptr_call (file_p, addr (ted_sup), msg, code);
2060       if (code = error_table_$unimplemented_version)
2061            & (ted_sup.version = ted_support_version_2)
2062       then do;
2063          ted_sup.version = ted_support_version_1;
2064          goto call_again;
2065 dcl ted_support_version_1 fixed bin int static init (1);
2066       end;
2067       if (ted_sup.version = ted_support_version_1)
2068       then do;                          /* convert old style codes           */
2069          if (code = 0)
2070          then code = tederror_table_$Copy_Set;
2071          else if (code = 1)
2072          then code = tederror_table_$NoChange;
2073          else if (code = 2)
2074          then code = tederror_table_$Set;
2075          else if (code = 4)
2076          then code = tederror_table_$Error_Msg;
2077       end;
2078 
2079       if (code = tederror_table_$Copy_Set)
2080       then do;                          /* copy back his result              */
2081          if db_ted
2082          then call ioa_$ioa_switch (db_output, "out.pt = ^10p out.de=^5i",
2083                    ted_sup.out.pt, ted_sup.out.de);
2084          b.a_.r.le (2) = min (ted_sup.inp.se, ted_sup.inp.de) + b.b_.l.le - 1;
2085          b.a_.l.re (1) = b.b_.l.le;     /* 1st, get rid everything up to     */
2086          call delete;                   /* ..the end of what he processed    */
2087                                         /* then add in his replacement       */
2088          call add_2l (ted_safe, ted_sup.out.pt, ted_sup.out.de, NLct_check);
2089          code = tederror_table_$Set;    /* copy part taken care of           */
2090       end;
2091       if ""b
2092       then do;
2093 nochange:                               /* PI resume point                   */
2094          code = tederror_table_$NoChange;
2095       end;
2096       pi_sw = 0;                        /* no more interrupts                */
2097       call tedfree_segment_ (dbase_p, sort_sn (1));
2098 
2099       if (code = tederror_table_$Set)
2100       then do;
2101          if (ted_sup.current > 0)
2102          then b.a_.r.le (2) = ted_sup.current;
2103          call iso_line;                 /* set current line as he (maybe)    */
2104          code = tederror_table_$NoChange;
2105       end;
2106       if (code = tederror_table_$NoChange)
2107       then do;
2108          rl_i = ted_sup.req.nc;         /* propagate request line status     */
2109          rl_l = ted_sup.req.de;
2110          return (NX_REQ);
2111       end;
2112       if (code = tederror_table_$Error_Msg)
2113       then do;
2114          if (substr (msg, 4, 2) ^= ") ")/* He didn't prefix his              */
2115          then msg = "Xef) " || msg;     /* ..message so add my prefix to it  */
2116          goto print_error;
2117       end;
2118       goto print_error_rc; %page;
2119 dcl 1 ted_sup       like ted_support;
2120 dcl hcs_$make_ptr   entry (ptr, char (*), char (*), ptr, fixed bin (35));
2121 dcl cu_$ptr_call    entry options (variable); %page;
2122 /* . . . buffer request       : change current buffer                        */
2123 
2124 cmd (098):                              /* b */
2125       call ignore_all;
2126 
2127       if (b.cur.sn ^= 0)                /* if buffer not empty               */
2128       then do;
2129          if (b.b_.l.le ^= 1) | (b.b_.r.re ^= b.maxl)
2130          then b.a_.l.ln (0), b.a_.r.ln (0), b.maxln = -1; /* #140*/
2131          b.b_.l.le = 1;                 /* open up window again              */
2132          b.b_.l.ln = 1;
2133          b.b_.r.re = b.maxl;
2134          b.b_.r.ln = b.maxln;
2135          if ^b.pseudo
2136          then if (b.cur.ast = 1) | (b.cur.ast = 2) /* if separate segment   */
2137               then call promote$seg;    /* ..garbage collect it              */
2138       end;
2139       if alt_sw
2140       then do;
2141          if (b_depth = 10)
2142          then goto err_Blv;
2143          b_depth = b_depth + 1;
2144          b_stack (b_depth) = bp;
2145       end;
2146       if (substr (rl_s, rl_i, 2) = "()") & ^not_sw
2147       then do;
2148          req_str = req_str || "()";
2149          rl_i = rl_i + 2;
2150          if (b_depth = 0)
2151          then goto err_Bnr;
2152          if com_blank then call ck_blank;
2153          bp = b_stack (b_depth);
2154          b_depth = b_depth - 1;
2155          if (b.b_.l.le ^= 1) | (b.b_.r.re ^= b.maxl)
2156          then b.a_.l.ln (0), b.a_.r.ln (0), b.maxln = -1; /* #140*/
2157          b.b_.l.le = 1;                 /* open up window again              */
2158          b.b_.l.ln = 1;
2159          b.b_.r.re = b.maxl;
2160          b.b_.r.ln = b.maxln;
2161       end;
2162       else do;
2163          used = rl_l - rl_i + 1;
2164          if not_sw                      /* must exist or is an error         */
2165          then call tedget_existing_buffer_ (dbase_p,
2166                    addr (rl_c (rl_i)), used, tbp, msg);
2167          else call tedget_buffer_ (dbase_p,
2168                    addr (rl_c (rl_i)), used, tbp, msg);
2169          rl_i = rl_i + used;
2170          if tbp = null
2171          then goto rq_err_msg;
2172          if com_blank then call ck_blank;
2173          if not_sw
2174          then do;
2175             if (tbp = bp)
2176             then goto err_Bnd;
2177             do i = 1 to b_depth;
2178                if (tbp = b_stack (i))
2179                then goto err_Bnd;
2180             end;
2181             if tbp -> b.no_io
2182             then goto not_allowed;
2183             bp = tbp;
2184             call delete;
2185             call iso_line;
2186             b.name = "";
2187             return (NX_REQ);
2188          end;
2189          bp = tbp;                      /* Make new buffer current           */
2190 /**** Make sure the gap is within window or we're in trouble elsewhere.      */
2191          if (b.b_.l.re > b.a_.r.le (2)) | (b.b_.r.le <= b.a_.l.re (1))
2192          then do;
2193             call openup;
2194             b.a_.l.re (1) = b.b_.l.re + 1;
2195          end;
2196 /**** fix up LN stuff here                                                   */
2197 
2198          b.b_.l.le = b.a_.l.re (1);     /* setup the addressed window        */
2199          b.b_.l.ln = b.a_.l.ln (1);
2200          b.b_.r.re = b.a_.r.le (2);
2201          b.b_.r.ln = b.a_.l.ln (2);
2202       end;
2203 
2204       if (b.b_.l.le > b.a_.r.re (0)) | (b.b_.r.re < b.a_.l.le (0))
2205       then do;                          /* "." outside window                */
2206          b.a_.l.le (0) = b.b_.l.le;
2207          b.a_.r.re (0) = addr_undef;
2208       end;
2209       else do;
2210       /*** anything here? */
2211       end;
2212       cb_w_r, cb_c_r = rel (bp);
2213       if db_ted
2214       then call tedshow_ (bp, ". b adr");
2215 
2216       return (NX_REQ); %page;
2217 /* . . . move request         : move data from one buffer to another         */
2218 
2219 cmd (109):                              /* m */
2220 cmd (107):                              /* k */
2221       app_sw = alt_sw;
2222       if ""b then do;
2223 cmd (077):                              /* M */
2224 cmd (075):                              /* K */
2225          app_sw = "1"b;
2226       end;
2227       if db_Ed
2228       then do;
2229          db_ted = "1"b;
2230       end;
2231       call default$cur_line;
2232 mo3:
2233       sbp = bp;
2234       b.a_.l.le (1) = b.a_.l.re (1);
2235 /**** Setup source address range                                             */
2236       b.cd.l.re = b.a_.l.re (1);
2237       b.cd.r.le = b.a_.r.le (2);
2238       used = rl_l - rl_i + 1;
2239       call tedget_buffer_ (dbase_p, addr (rl_c (rl_i)), used, dbp, msg);
2240                                         /* get ctl block of destination      */
2241       rl_i = rl_i + used;
2242       if (dbp = null)
2243       then goto rq_err_msg;
2244       if dbp -> b.present (2)
2245       then do;
2246          msg = "Gma) 2nd addr not allowed on destination.";
2247          goto add_request;
2248       end;
2249       bp = dbp;
2250       if ^b.present (1) & (b.cur.sn ^= 0)
2251       then call default$whole_buffer;
2252       bp = sbp;
2253       if com_blank then call ck_blank;
2254 /**** I don't remember why the 2nd line down got commented out.          JAF */
2255 /**** BECAUSE the only time b_.r.re<=a_.r.le(2) is when upper is empty       */
2256       if (dbp -> b.b_.l.le <= dbp -> b.b_.l.re) /* lower part not empty,    */
2257 /****    & (dbp -> b.b_.r.re < dbp -> b.b_.r.le) /* ..upper part empty, &    */
2258            & (dbp -> b.b_.r.re <= dbp -> b.a_.r.le (2)) /* ..addr refs upper   */
2259       then dbp -> b.a_.r.le (2) = dbp -> b.b_.l.re; /* ....use lower part    */
2260 
2261 /**** Setup destination address point                                        */
2262       dbp -> b.cd.r.re = dbp -> b.a_.r.le (2) + 1;
2263       if (dbp = sbp)
2264       then do;                          /* destination is current buffer     */
2265          if ^app_sw
2266          then do;                       /* doing "m" or "k"                  */
2267             msg = "Bnm) Can't m/k to current buffer.";
2268             goto add_request;
2269          end;
2270          else if (rqc = "M")            /* Can't move into middle of what    */
2271          then do;                       /* ..is being deleted by the move.   */
2272             if (b.cd.l.re <= b.cd.r.re) & (b.cd.r.re <= b.cd.r.le)
2273             then do;
2274                msg = "Xbm) Bad move spec.";
2275                goto add_request;
2276             end;
2277          end;
2278       end;
2279 
2280       if ^app_sw                        /* gonna wipe old buffer contents?   */
2281       then do;
2282          bp = dbp;
2283          if (b.cur.sn ^= 0)             /* are there any old contents?       */
2284          then if b.file_sw & b.mod_sw
2285                                         /* is this a modified file?          */
2286                    | b.not_pasted       /* or is it unused, moved text?      */
2287               then do;                  /*    ask first                      */
2288                  query_info.status_code = error_table_$inconsistent;
2289                  call command_query_ (addr (query_info), answer, DBA,
2290                       "Do you want to overwrite b(^a)? " ||
2291                       "It contains ^[modified file ^a>^a^a^a^;text ^a^]",
2292                       b.name, b.file_sw, b.dname, b.ename, b.kind, b.cname);
2293                  if (substr (answer, 1, 1) = "n")
2294                  then return (NX_LIN);
2295               end;
2296          if ^b.force_name               /* if name not forced on buffer..    */
2297          then b.file_sw = "0"b;         /*   ..set "no file associated" on.. */
2298                                         /*   ..receiving buffer              */
2299          call delete$all;
2300          bp = sbp;
2301       end;
2302 /**** Since it is felt that M/K will be done most often without a            */
2303 /****  destination address, the data is being placed on the left end to      */
2304 /****  minimize the movement as each new piece is appended.                  */
2305       call buffer_buffer_copy (sbp, dbp, "0"b);
2306       bp = dbp;                         /* go check things about destination */
2307       if (dbp ^= sbp)                   /* if source^=destination buffer     */
2308       then do;
2309 /****    Make sure the gap is between lines.  Everything assumes this to be  */
2310 /****      the case.                                                         */
2311          if (b.b_.l.re >= b.b_.l.le)    /* is there a lower part?            */
2312          then do;
2313             if (b_c (b.b_.l.re) ^= NL)  /* does lower part not end in NL...  */
2314                  & (b.b_.r.re >= b.b_.r.le) /* ..and is there an upper part?     */
2315             then do;
2316 /**** The hole gets moved to a line boundary. Data is moved upward.          */
2317 /****  N.B.: A file which does not end with NL could be all in lower part.   */
2318 /****        such as after doing "$($)d"                                     */
2319                i = index (reverse (
2320                     substr (b_s, b.b_.l.le, b.b_.l.re - b.b_.l.le + 1)), NL);
2321                if (i = 0)
2322                then b.a_.l.re (1) = b.b_.l.le; /* take what is left          */
2323                else b.a_.l.re (1) = b.b_.l.re - i + 2; /* -> just after NL   */
2324                call openup;
2325             end;
2326          end;
2327          b.a_.l.le (0), b.a_.l.re (0) = 1; /* set "." undefined              */
2328          b.a_.r.le (0), b.a_.r.re (0) = addr_undef;
2329       end;
2330       if ^b.file_sw
2331       then do;                          /* if there is no file name          */
2332          msg = "  ";                    /* ..then tell where the data        */
2333          msg = msg || req_str;          /* ..came from.                      */
2334          msg = msg || " from b(";
2335          msg = msg || rtrim (sbp -> b.name);
2336          msg = msg || ")";
2337          b.dname = msg;
2338       end;
2339       bp = sbp;                         /* go back to source buffer          */
2340 
2341       if (rqc = "m") | (rqc = "M")
2342       then do;
2343          if (ted_mode ^= COM)
2344          then dbp -> b.not_pasted = "1"b;
2345          b.a_.l.re (1) = b.cd.l.re;     /* restore source address range      */
2346          b.a_.r.le (2) = b.cd.r.le;
2347          call delete;
2348       end;
2349       else dbp -> b.not_pasted = "0"b;
2350       call iso_line;                    /* This is done for both move and    */
2351                                         /*  kopy for consistency.            */
2352       return (NX_REQ); %page;
2353 /* . . . status ("x") request           : list status of all buffers   . . . */
2354 
2355 cmd (088):                              /* X */
2356 X_status:
2357       if (rl_c (rl_i) = NL)
2358       then select = b.name;
2359       else do;
2360          rl_i = rl_i + verify (substr (rl_s, rl_i), " ") - 1;
2361          if (rl_c (rl_i) ^= "(")
2362          then do;
2363             select = rl_c (rl_i);
2364             rl_i = rl_i + 1;
2365          end;
2366          else do;
2367             i = index (substr (rl_s, rl_i + 1), ")");
2368             if (i = 0)
2369             then goto err_Smp;
2370             select = substr (rl_s, rl_i + 1, i - 1);
2371             rl_i = rl_i + i + 1;
2372          end;
2373       end;
2374       goto status;
2375 cmd (120):                              /* x */
2376       if alt_sw
2377       then goto X_status;
2378       select = " ";
2379       if com_blank
2380       then if (rl_c (rl_i) = "m")
2381            then do;
2382               req_chx = "m";
2383               req_str = req_str || "m";
2384               rl_i = rl_i + 1;
2385            end;
2386 status:
2387       call ignore_both;
2388       if com_blank then call ck_blank;
2389       if (req_chx = " ")
2390       then call tedlist_buffers_ (dbase_p, select, "1"b, ln_sw);
2391       else do;
2392          call tedcheck_buffers_ (dbase_p, wct);
2393          if (wct = 0)
2394          then call ioa_ ("No modified buffers.");
2395       end;
2396       return (NX_REQ); %skip (2);
2397 /* . . . print current line number ("=") request  : prints out line # current line in buffer */
2398 
2399 cmd (061):                              /* = */
2400       if com_blank then call ck_blank;
2401       call ignore_1;
2402       call default$cur_line;
2403       call iso_line;                    /* set "." to addressed line         */
2404       msg = "";
2405       if string_sw
2406       then do;
2407          msg = msg || "0(";
2408          j = b.a_.l.re (1);
2409          if (b.a_.l.re (1) > b.b_.l.re)
2410          then j = j - (b.b_.r.le - b.b_.l.re - 1); /* subtract hole size    */
2411          msg = msg || ltrim (char (j));
2412          msg = msg || ")      ";
2413       end;
2414       call tedcount_lines_ (bp, b.b_.l.le, b.a_.l.re (1), j);
2415       msg = msg || ltrim (char (j));
2416       jb = b.a_.l.re (1) - b.a_.l.le (1) + 1;
2417       if (jb > 1)
2418       then do;
2419          msg = msg || "(";
2420          msg = msg || ltrim (char (jb));
2421          msg = msg || ")";
2422       end;
2423       if ln_sw
2424       then do;
2425          msg = msg || " <<";
2426          msg = msg || ltrim (char (b.a_.r.ln (2)));
2427       end;
2428       msg = msg || NL;
2429       call iox_$put_chars (iox_$user_output, msg_ptr, length (msg), 0);
2430       return (NX_REQ); %page;
2431 /* . . . global/exclude request       : repeat given request for lines       */
2432 /*                                      (not) containing) regfexp            */
2433 
2434 cmd (118):                              /* v */
2435       xsw = "1"b;                       /* exclude request                   */
2436       if ""b then do;
2437 
2438 cmd (103):                              /* g */
2439          xsw = "0"b;                    /* global request                    */
2440       end;
2441       Psw = "0"b;                       /* set to show not doing "P"         */
2442       call default$whole_buffer;        /* Default: global whole window      */
2443       if rl_i > rl_l
2444       then goto err_Sd1;                /* error if nothing follows g or v   */
2445                                         /*  request                          */
2446       b.a_.l.re (1) = b.a_.l.le (1);    /* force line orientation            */
2447       b.a_.r.le (2) = b.a_.r.re (2);
2448       req_chx = rl_c (rl_i);            /* get global sub-request            */
2449       req_str = req_str || req_chx;
2450       if (req_chx = "*")
2451       then do;
2452          if (gbp = null ())
2453          then do;
2454             argname = "((g*))";
2455             call tedget_buffer_ (dbase_p, addr (argname), length (argname),
2456                  gbp, msg);
2457          end;
2458          gbp -> b.noref = "1"b;         /* Mark buffer invisible to "x"      */
2459          rl_i = rl_i + 1;
2460          if (rl_i < rl_l)
2461          then do;
2462             call gv_compile;
2463          /*** NLlast has been set by gv_compile                    */
2464             NLlast = NLlast & gvNL;
2465             if (code ^= 0)
2466             then goto print_error;
2467          end;
2468       end;
2469       else if (req_chx = "h") | (req_chx = "H")
2470       then do;
2471          rl_i = rl_i + 1;
2472          msg = "ted_";
2473          msg = msg || req_ch;
2474          msg = msg || "tabout_";
2475          goto do_tabout;
2476       end;
2477       else do;
2478          if (substr (rl_s, rl_i, 2) = "!p")
2479          then do;
2480             req_not = req_ch;
2481             req_str = req_str || "p";
2482             req_ch = "!";
2483             req_chx = "p";
2484             alt_sw = "1"b;
2485             rl_i = rl_i + 1;
2486          end;
2487          else if (req_chx = ".")
2488          then do;
2489             req_chx = substr (nulreq, 1, 1);
2490             if (req_chx = "!")
2491             then req_chx = "P";
2492          end;
2493          else if (index ("p=Pd", req_chx) = 0)
2494          then goto invalid_request;
2495          if (index ("p=P", req_chx) = 0)
2496          then NLlast = ""b;
2497          else NLlast = "1"b;
2498          rl_i = rl_i + 1;
2499          call scan;
2500          if (expr_l > 0)
2501          then call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
2502                    addr (dbase.regexp), (string_sw), (dbase.lit_sw), msg, code);
2503 /****         if (req_chx = "h")                                             */
2504 /****         then do;                                                       */
2505 /****            call TABSCAN;                                               */
2506 /****         end;                                                           */
2507       end;
2508 dcl 1 the_line_no,
2509       2 l6          pic "zzzzz9",
2510       2 ch          char (1);
2511 /**** During global processing, data is kept like this:                      */
2512 /**** b.gb.l.le - current location                                           */
2513 /**** b.gb.l.re - last location to use in part                               */
2514 /**** b.gb.l.ln - line number of current line                                */
2515 /**** b.gb.r.re - last location to use in buffer                             */
2516 
2517       if com_blank then call ck_blank;
2518 gb3:
2519       b.gb.l.le = b.a_.l.re (1);        /* hide away the address range       */
2520       b.gb.l.ln = b.a_.l.ln (1);
2521       b.gb.r.re = b.a_.r.le (2);
2522       b.gb.r.ln = b.a_.r.ln (2);
2523       if (b.gb.r.re <= b.b_.l.re)       /* if ends in lower part             */
2524            | (b.gb.l.le >= b.b_.r.le)   /* ..or begins in upper part         */
2525       then b.gb.l.re = b.gb.r.re;       /* ..part limit is address limit     */
2526       else b.gb.l.re = b.b_.l.re;       /* otherwise part limit is l.re      */
2527       if (req_chx = "=")
2528            | (req_chx = "*")
2529            | ((req_chx = "p") & alt_sw)
2530            | (req_chx = "P")
2531       then do;
2532          call tedcount_lines_ (bp, b.b_.l.le, b.gb.l.le, b.gb.l.ln);
2533          pi_label = gb_quit;
2534          pi_sw = 1;
2535       end;
2536       else do;
2537          pi_sw = 2;
2538          b.gb.l.ln = 1;
2539       end;
2540       if db_ted
2541       then call ioa_$ioa_switch (db_output, "^2-gb:^i <<^i", b.gb.l.ln, b.a_.l.ln (1));
2542       b.a_.l.ln (1) = b.gb.l.ln;
2543       if (req_chx = "P") | ((req_chx = "p") | alt_sw)
2544       then the_line_no.ch = HT;
2545       if (req_chx = "=")
2546       then the_line_no.ch = NL;
2547 gb_loop:
2548       b.a_.l.le (1), b.a_.l.re (1) = b.gb.l.le; /* get begin of cur line   */
2549       b.a_.r.ln (2) = b.a_.l.ln (1);
2550       i = index (                       /* then find end of it               */
2551            substr (b_s, b.gb.l.le, b.gb.l.re - b.gb.l.le + 1), NL);
2552       if (i = 0)                        /* worry about no NL at EOB          */
2553       then b.a_.r.le (2) = b.gb.l.re;
2554       else b.a_.r.le (2) = b.gb.l.le + i - 1;
2555       b.a_.r.re (2) = b.a_.r.le (2);
2556       b.gb.l.le = b.a_.r.le (2);        /* get beginning of next line..      */
2557       if (b.gb.l.le <= b.gb.l.re)       /* ..if we can                       */
2558       then b.gb.l.le = b.gb.l.le + 1;
2559       if db_ted
2560       then call tedshow_ (bp, ". gv a1 a2 gb");
2561 
2562       if Psw                            /* it's P, don't bother searching    */
2563       then goto gb_p1;
2564       if (req_chx = "*")
2565       then do;
2566          call gv_srch;
2567          goto gb_end;
2568       end;
2569                                         /* search line for REGEXP            */
2570       call tedsrch_$search (addr (dbase.regexp), bp, b.a_.l.re (1),
2571            b.a_.r.le (2), mi, me, me2, msg, code);
2572       if (code = 2)
2573       then goto print_error;
2574       if xsw = (code ^= 0)              /* ^match w/ exclude request         */
2575       then do;                          /*  OR match w/ global request       */
2576                                         /* this line is to be processed      */
2577          if (req_chx = "p")             /* doing "p" request?                */
2578          then if alt_sw
2579               then goto gb_p1;
2580               else goto gb_p2; %skip (3);
2581          if (req_chx = "P")
2582          then do;
2583 gb_p1:
2584             the_line_no.l6 = b.gb.l.ln;
2585             call iox_$put_chars (iox_$user_output, addr (the_line_no), 7, 0);
2586 gb_p2:
2587             call iox_$put_chars (iox_$user_output, addr (b_c (b.a_.l.re (1))),
2588                  b.a_.r.le (2) - b.a_.l.re (1) + 1, 0);
2589             if intsw then goto gb_quit; /* abort request if PI has occurred  */
2590          end; %skip (3);
2591          else if (req_chx = "=")
2592          then call ioa_$nnl ("^i^a", b.gb.l.ln, the_line_no.ch);
2593          else do;
2594             if (req_chx = "d")
2595             then call delete;           /* iso_line not needed               */
2596          end;
2597       end;
2598 
2599 gb_end:
2600       if (b.gb.l.le <= b.gb.l.re)
2601       then do;
2602          b.gb.l.ln = b.gb.l.ln + 1;     /* increment line counter            */
2603          goto gb_loop;                  /* check for last line processed     */
2604       end;
2605       if (b.gb.l.re ^= b.gb.r.re)       /* if there is a split               */
2606       then do;                          /* ..move to upper part & continue   */
2607          b.gb.l.le = b.b_.r.le;
2608          b.gb.l.re = b.gb.r.re;
2609          goto gb_end;
2610       end;
2611 gb_quit:
2612       pi_sw = 0;
2613       b.gb = tedcommon_$no_data;
2614 /**** Don't leave unused buffer there.                                       */
2615       if (b.b_.l.le > b.b_.l.re) & (b.b_.r.le > b.b_.r.re)
2616       then call delete$all;             /* #142*/
2617       else if (b.a_ (2).r.le > b.b_.r.re) /* was last line deleted?          */
2618       then b.a_ (2).r.le = b.b_.l.re;   /* point to new last line.       #162*/
2619       call iso_line;                    /* when done, leave current line at  */
2620                                         /* ..last line processed             */
2621       if (req_chx = "*")                /* g* uses the rest of the line      */
2622       then rl_i = rl_l;
2623       if NLlast
2624       then call iox_$put_chars (iox_$user_output, addr (NL), 1, 0);
2625       return (NX_REQ); %page;
2626 /* . . . PRINT request        : print with line numbers . . . */
2627 
2628 cmd (080):                              /* P */
2629       if com_blank then call ck_blank;
2630       call default$cur_line;            /* default addr (.,.) if needed      */
2631 PRINTb:
2632       req_chx = req_ch;
2633       req_ch = " ";
2634       NLlast = ""b;
2635       Psw = "1"b;                       /* set sw to show PRINT */
2636       goto gb3;
2637 
2638 /* . . . tab-out request . . . */
2639 cmd (072):                              /* H */
2640 cmd (104):                              /* h */
2641 
2642       msg = "ted_tabout_";
2643 do_tabout:
2644       if (rl_c (rl_i) = " ")
2645       then goto err_Sd1;
2646                                         /* RW 88 */
2647       call default$cur_line;            /*#193*/
2648       goto do_call; %skip (3);
2649 /* . . . tab-in request  . . . */
2650 
2651 cmd (121):                              /* y */
2652 
2653       if com_blank then call ck_blank;
2654       b.a_.l.re (1) = b.a_.l.le (1);    /* line oriented only                */
2655       msg = "ted_tabin_";               /* simulate obsolete request         */
2656                                         /* RW 88 */
2657       call default$cur_line;            /*#193*/
2658       goto do_call; %page;
2659 /* . . . define label . . . */
2660 
2661 cmd (058):                              /* : */
2662       i = rl_i;
2663       if (rl_c (rl_i) = "(")
2664       then do;
2665          il = index (substr (rl_s, rl_i), ")");
2666          if (il = 0)
2667          then goto err_Smp;
2668          if (il > 16)
2669          then goto err_Slx;
2670       end;
2671       else il = 1;
2672       rl_i = rl_i + il;
2673       if com_blank then call ck_blank;
2674       if flow_sw
2675       then call ioa_ ("**FLOW **        ^a", substr (rl_s, i, il));
2676       return (NX_REQ); %skip (3);
2677 /* . . . nop request          : change value of "." and get next request from input line */
2678 
2679 cmd (110):                              /* n */
2680 nullrq:
2681       if com_blank then call ck_blank;
2682       if ^b.present (1)
2683       then return (NX_REQ);             /* ignore if no address given        */
2684       if alt_sw & b.present (2)
2685       then do;
2686          b.a_.l (0) = b.a_.l (1);
2687          b.a_.r (0) = b.a_.r (2);
2688          return (NX_REQ);
2689       end;
2690       if (b.a_.r.le (1) = 0)
2691       then do;
2692          b.a_.l.le (0), b.a_.l.re (0) = 1;
2693          b.a_.r.le (0), b.a_.r.re (0) = 0;
2694          return (NX_REQ);
2695       end;
2696       b.a_.r.le (2) = b.a_.r.le (1);
2697       call ignore_2;
2698       call iso_line;                    /* change "." to last line addressed */
2699       return (NX_REQ);
2700 %page;
2701 /* . . . goto label in this buffer . . . */
2702 
2703 cmd (062):                              /* > */
2704 ref_label:
2705       call ignore_all;
2706       tc = rl_c (rl_i);
2707       i = rl_i;
2708       if (tc = "(")
2709       then do;
2710          il = index (substr (rl_s, rl_i), ")");
2711          if (il = 0)
2712          then goto err_Smp;
2713          if (il > 16)
2714          then goto err_Slx;
2715       end;
2716       else if (tc = "+") then goto rel_go;
2717       else if (tc = "-")
2718       then do;
2719 rel_go:
2720          il = 2;
2721          if (index ("0123456789", rl_c (rl_i + 1)) = 0)
2722          then goto err_Sbd;
2723       end;
2724       else il = 1;
2725       if (tc ^= NL)
2726       then do;
2727          rl_i = rl_i + il;
2728          if (rl_c (rl_i) = ":")
2729          then do;
2730             rl_i = rl_i + 1;
2731             code = 1;
2732          end;
2733          else code = 0;
2734          if com_blank then call ck_blank;
2735       end;
2736       if not_sw
2737       then do;
2738          err_go = substr (rl_s, i, il);
2739          return (NX_REQ);
2740       end;
2741       call tedset_ptr_ (dbase_p, substr (rl_s, i, il), code);
2742       if (code = 0)
2743       then do;
2744          return (NX_LIN);
2745       end;
2746       if (code = 10)
2747       then goto rq_err;
2748       return (NX_REQ); %skip (4);
2749 /* . . . return from current buffer . . */
2750 
2751 cmd (126):                              /* ~ */
2752 
2753       call tedend_buffer_ (dbase_p, code);
2754       return (NX_LIN); %page;
2755 /* . . . comment delimiter (") found    : change value of "." to last line addressed and ignore rest of line */
2756 
2757 cmd (034):                              /* " */
2758 comment:
2759       if ^b.present (1)                 /* if no address given..             */
2760       then return (NX_LIN);             /* ..ignore completely               */
2761       call ignore_2;
2762       b.a_.r.le (2) = b.a_.r.le (1);
2763       call iso_line;                    /* change "." to last line addressed */
2764       return (NX_LIN);                  /* ignore remainder of request line  */
2765 %skip (3);
2766 /* . . . if-line request      : test if current line is a specific one . . . */
2767 
2768 cmd (035):                              /* # */
2769 if_line:
2770       if com_blank then call ck_blank;
2771       if (b.cur.sn = 0) then            /* defined to fail if buffer empty */
2772            goto if_line_f;
2773       if ^b.present (1)                 /* if no addr supplied,              */
2774       then goto if_line_t;              /*    then buffer-empty test         */
2775       call default$cur_line;
2776       if b.present (2)
2777       then do;
2778          if (b.a_.l.re (0) < b.a_.l.re (1))
2779          then goto if_line_f;
2780          if (b.a_.r.le (0) > b.a_.r.le (2))
2781          then goto if_line_f;
2782          goto if_line_t;
2783       end;
2784       else do;
2785          if (b.a_.l.re (0) = b.a_.l.re (1))
2786          then goto if_line_t;
2787       end;
2788 if_line_f:                              /* if_line_false */
2789       return (^not_sw);
2790 if_line_t:                              /* if_line_true */
2791       return (not_sw);
2792 
2793 %page;
2794 /* . . . z-subsystem request . . . */
2795 
2796 cmd (122):                              /* z */
2797       i = index (substr (rl_s, rl_i), " ");
2798       if (i = 0)
2799       then i = rl_l - rl_i;
2800       else i = i - 1;
2801       req_str = req_str || substr (rl_s, rl_i, i);
2802       if (substr (rl_s, rl_i, i) ^= "if")
2803       then do;
2804          if (b.cur.sn = 0)
2805          then do;
2806             msg = "Abe) Buffer empty.";
2807             goto print_error;
2808          end;
2809          call default$line_eval;
2810          if (substr (rl_s, rl_i, i) = "dump")
2811          then do;
2812             rl_i = rl_i + i;
2813             msg = "ted_dump_";
2814             goto do_call;
2815          end;
2816          if (substr (rl_s, rl_i, i) = ".fi.na")
2817          then do;
2818             rl_i = rl_i + i;
2819             msg = "ted_fina_";
2820             goto do_call;
2821          end;
2822          if (substr (rl_s, rl_i, i) = ".fi.ad")
2823          then do;
2824             rl_i = rl_i + i;
2825             msg = "ted_fiad_";
2826             goto do_call;
2827          end;
2828       end;
2829       rl_i = rl_i + i;
2830       rl_i = rl_i + verify (substr (rl_s, rl_i), " ");
2831 
2832 /**** "zif" falls into "{" routine, after having adjusted rl_i properly      */
2833 
2834 /* . . . evaluate request "{" . . . */
2835 cmd (123):                              /* { */
2836 
2837       rl_i = rl_i - 1;
2838       if b.present (1)
2839       then call default$line_eval;
2840       used = rl_l - rl_i + 1;
2841       call tedeval_ (dbase_p, addr (rl_c (rl_i)), used,
2842            bp, null (), 0, result, msg, code);
2843       rl_i = rl_i + used;
2844       if (code ^= 0)
2845       then do;
2846 eval_err:
2847          if (code < 100)
2848          then goto print_error;
2849          goto print_error_rc;
2850       end;
2851       if (req_str = "zif")
2852       then do;
2853          if (result = "0") | (result = "false")
2854          then return (NX_LIN);
2855          else return (NX_REQ);
2856       end;
2857       if (length (result) ^= 0)
2858       then do;
2859          msg = "{ has result """;
2860          msg = msg || result;
2861          msg = msg || """.
2862 ";
2863          call iox_$put_chars (iox_$error_output, msg_ptr, length (msg), 0);
2864       end;
2865       return (NX_REQ); %page;
2866 /* . . . file-output request  : direct "user_output" to a buffer . . */
2867 
2868 cmd (102):                              /* f */
2869       if fo_sw
2870       then do;                          /* #147*/
2871 fo_err:
2872          if go_sw then msg = "EFo) F";  /* #147*/
2873          else msg = "Efo) f";           /* #147*/
2874          msg = msg || " already active";/* #147*/
2875          goto print_error;              /* #147*/
2876       end;                              /* #147*/
2877       go_sw = "0"b;
2878       if alt_sw
2879       then do;
2880 cmd (070):                              /* F */
2881          if (rl_c (rl_i) = NL)
2882          then do;
2883             go_sw = "0"b;
2884             return (NX_LIN);
2885          end;
2886          if fo_sw
2887          then goto fo_err;              /* #147*/
2888          go_sw = "1"b;
2889       end;
2890       call ignore_all;
2891       used = rl_l - rl_i + 1;
2892       call tedget_buffer_ (dbase_p, addr (rl_c (rl_i)), used, fop, msg);
2893       rl_i = rl_i + used;
2894       if (fop = null)
2895       then goto rq_err_msg;
2896       if com_blank then call ck_blank;
2897       if (pdname = " ")
2898       then pdname = get_pdir_ ();
2899       begin;
2900          fo_name = "ted_."; dcl pic2 pic "99";
2901          substr (fo_name, 6, 2) = convert (pic2, dbase.recurs);
2902          got_quit = "0"b;               /* We can't be interrupted while we  */
2903          on quit got_quit = "1"b;       /* ..are messing with switches       */
2904          call iox_$attach_name (fo_name, fcbp, "vfile_ " || pdname
2905               || ">" || "ted_." || dbase.rq_id, null (), code);
2906          if (code ^= 0)
2907          then do;
2908             call com_err_ (code, DBA, "attach ted_fo");
2909             signal condition (ted_fo_err);
2910          end;
2911          call iox_$open (fcbp, 2, "0"b, code);
2912          if (code ^= 0)
2913          then do;
2914             call com_err_ (code, DBA, "open ted_fo");
2915             signal condition (ted_fo_err);
2916          end;
2917          call iox_$find_iocb (fo_name || "save", fcbsp, code);
2918          if (code ^= 0)
2919          then call com_err_ (code, DBA, "find ^asave", fo_name);
2920          call iox_$move_attach (iox_$user_output, fcbsp, code);
2921          if code ^= 0
2922          then call com_err_ (code, DBA, "move attach user_output");
2923          code = iox_$attach_iocb (iox_$user_output, "syn_ " || fo_name);
2924          if (code ^= 0)
2925          then do;
2926             call com_err_ (code, DBA, "attach user_output");
2927          end;
2928          fo_sw = "1"b;
2929          revert quit;
2930       end;
2931       if got_quit
2932       then signal quit;
2933       return (NX_REQ);
2934 
2935    end do_req; %page;
2936 upper_lower: proc (expr_p, upper);
2937 
2938 dcl expr_p          ptr,                /* -> compiled expression area       */
2939     upper           bit (1);            /* 1-to upper       0-to lower       */
2940 
2941 Uu_loop:
2942       call tedsrch_$search (expr_p, bp,
2943            b.a_.l.re (1), b.a_.r.le (2), mi, me, me2, msg, code);
2944       if (code = 0)
2945       then do;
2946          b.mod_sw = "1"b;
2947          ml = me - mi + 1;
2948          if (ml = 0)
2949          then b.a_.l.re (1) = mi + 1;
2950          else do;
2951             b.a_.l.re (1) = me + 1;
2952             if upper
2953             then substr (b.cur.sp -> b_s, mi, ml)
2954                       = translate (substr (b.cur.sp -> b_s, mi, ml), AZ, az);
2955             else substr (b.cur.sp -> b_s, mi, ml)
2956                       = translate (substr (b.cur.sp -> b_s, mi, ml), az, AZ);
2957          end;
2958          if (b.a_.l.re (1) <= b.a_.r.le (2))
2959          then goto Uu_loop;
2960       end;
2961       if (code = 2)
2962       then goto print_error;
2963       call iso_line;
2964 
2965    end upper_lower; %page;
2966 substitute: proc (axp);
2967 
2968 dcl axp             ptr;                /* -> compiled search expression     */
2969 /****comptr                             ** -> compiled replace expression    */
2970 dcl IC              fixed bin;
2971 
2972       IC = gvx.ic;
2973 sub_loop:
2974       call tedsrch_$search (axp, bp,
2975            b.a_.l.re (1), b.a_.r.le (2), mi, me, me2, msg, code);
2976       if code = 0
2977       then do;
2978          dbase.S_count = dbase.S_count + 1;
2979          subsw = "1"b;                  /* indicate something found          */
2980          gvx.ic = IC;
2981          cfp = addr (gvx.word (gvx.ic));
2982          call replace (mi, me, me2);
2983          if b.a_.l.re (1) <= b.a_.r.le (2)
2984          then goto sub_loop;            /* until end of addressed portion    */
2985                                         /* of buffer reached                 */
2986       end;
2987       call iso_line;                    /* set cur line to last line srched  */
2988 
2989    end substitute; %skip (4);
2990 replace: proc (ami, ame, ame2);
2991 
2992 dcl (
2993     ami             fixed bin (21),     /* beginning of match                */
2994     ame             fixed bin (21),     /* end of match                      */
2995     ame2            fixed bin (21));    /* last char searched                */
2996 /**** cfp points to next compiled expression entry                           */
2997 
2998 dcl ml              fixed bin (21);     /* length of string matched          */
2999 dcl i               fixed bin;
3000 dcl rep_p           ptr;                /* ->matched string                  */
3001 dcl temp_p          ptr;                /* ->temp seg for matched string     */
3002 dcl temp_sn         fixed bin;          /* # of temp seg if it was needed    */
3003 
3004       b.a_.r.le (1) = ame;              /* save match end for relocation     */
3005       b.a_.r.re (1) = ame2;             /* save search end for relocation    */
3006       b.a_.l.re (1) = ami;              /* set location for openup           */
3007       call openup;
3008       rep_p = addr (b_c (b.a_.l.re (1)));
3009       temp_sn = 0;
3010       ml = ame - ami + 1;               /* find out how long the match was   */
3011       do cfp = cfp repeat (addr (gvx.word (gvx.ic)));
3012          if db_srch
3013          then call tedshow_ (comptr, "cf");
3014          if (cf.op >= seval_op) & (cf.op <= srepl_op)
3015          then goto repop (cf.op);
3016                                         /*  not a replace operation, quit    */
3017          if ml = 0                      /* if matched string was null        */
3018          then do;                       /* insure we find a different        */
3019                                         /*  null string next time            */
3020             b.a_.l.re (1) = b.a_.l.re (1) + 1;
3021          end;
3022          else do;                       /* matched str not null              */
3023             i = index (substr (b_s, b.a_.l.re (1), ml), NL);
3024             if (i > 0)                  /* NL in old string?                 */
3025             then do;
3026                if (i = ml)              /* The NL is at the end, therefore   */
3027                then do;                 /* ..it must be the only one.        */
3028                   if (b.maxln > 1)      /* If line count is known, decrement */
3029                   then b.maxln = b.maxln - 1;
3030                   else b.maxln = -1;
3031                end;
3032                else do;
3033                                         /* (could see if there are no more)  */
3034                   b.maxln = -1;         /* forget the count                  */
3035                end;
3036                b.b_.l.ln, b.b_.r.ln = -1; /* forget the rest                 */
3037             end;
3038             b.mod_sw = "1"b;
3039             if (temp_sn ^= 0)           /* if we had to copy match, clean up */
3040             then call tedfree_segment_ (dbase_p, temp_sn);
3041             else b.b_.r.le = b.a_.r.le (1) + 1; /* throw away old string     */
3042             b.a_.l.re (1) = b.a_.r.re (1) + 1; /* resume at me2 + 1          */
3043          end;
3044          if db_ted
3045          then call tedshow_ (bp, ". rep b_ a1");
3046          return;
3047 
3048 repop (-1):                             /* literal insert                    */
3049          call add_rep (addr (cf.da), (cf.len), NLct_check);
3050          goto end_rep;
3051 
3052 repop (-2):                             /* (replace with matched string)     */
3053          if (ml > 0)                    /* .. skip if null string found      */
3054          then do i = 1 to cf.len;
3055             call add_rep (rep_p, ml, NLct_check);
3056          end;
3057          goto end_rep;
3058 
3059 repop (-3):                             /* "equal" convention: x\= gives     */
3060                                         /*  x repeated matchlength times     */
3061          if (ml > 0)
3062          then begin;
3063 dcl str             char (ml);
3064                str = copy (cf.da, ml);
3065                call add_rep (addr (str), ml, ml * fixed (cf.da = NL));
3066             end;
3067          goto end_rep;
3068 
3069 repop (-4):                             /* evaluation                        */
3070          call tedeval_ (dbase_p, addr (cf.da), (cf.len),
3071               bp, addr (b_c (b.a_.l.re (1))), ml, result, msg, code);
3072          if (code ^= 0)
3073          then goto print_error;
3074          if (length (result) > 0)
3075          then call add_rep (addrel (addr (result), 1), length (result),
3076                    NLct_check);
3077 end_rep:
3078          gvx.ic = gvx.ic + cf.siz;
3079       end;
3080 add_rep: proc (r_p, r_l, NLcheck);
3081 
3082 dcl r_p             ptr,                /* ->replacement string              */
3083     r_l             fixed bin (21),     /* length of it                      */
3084     NLcheck         fixed bin (21);     /* NL check flag                     */
3085 dcl space           fixed bin (21);
3086 dcl m               char (ml) based;
3087 
3088       if (b.cur.ast = 1)                /* if the buffer is full size        */
3089            & (temp_sn = 0)              /* ..& match string is still in      */
3090       then do;                          /* ..the buffer, do the check        */
3091          space = b.b_.r.le - b.b_.l.re - 1; /* how much room left            */
3092          space = space - r_l;           /* how much left after adding        */
3093          if (space < 0)                 /* if not enough room left           */
3094               & ((space + ml) >= 0)     /* ..but removing match would help   */
3095          then do;                       /* move the match string elsewhere   */
3096             call tedget_segment_ (dbase_p, temp_p, temp_sn);
3097             temp_p -> m = rep_p -> m;   /* copy match out of buffer          */
3098             b.b_.r.le = b.a_.r.le (1) + 1; /* remove from buffer             */
3099             rep_p = temp_p;             /* point to new location             */
3100          end;
3101       end;                              /* we have done the best we could    */
3102       call add_2l (ted_safe, r_p, r_l, NLcheck);
3103 
3104    end add_rep;
3105 
3106 
3107 /* never gets here */ %page;
3108 replace$compile: entry;
3109 
3110       concealsw = "0"b;                 /* initialize concealed-char. switch */
3111       cf.op = -255;
3112       cf.len = 0;
3113       do rl_i = j to rl_l;              /* compile char's from str2 */
3114          ch = rl_c (rl_i);
3115          if concealsw                   /* check for concealed char.         */
3116          then do;
3117             concealsw = "0"b;           /* reset concealed-char. switch      */
3118             call make_rp (srepl_op, ch);
3119          end;
3120          else if (ch = delim)
3121          then do;
3122             cf.siz = size (cf);
3123             call end_cf;
3124             rl_i = rl_i + 1;
3125             return;
3126          end;
3127          else if ch = BS_C              /* check for concealment char. BS_C  */
3128          then concealsw = "1"b;         /* set switch to conceal next char.  */
3129          else if (ch = "\")
3130          then do;
3131             if (index ("cC", rl_c (rl_i + 1)) > 0)
3132             then do;
3133                rl_i = rl_i + 1;
3134                concealsw = "1"b;
3135             end;
3136             else if (index ("gG", rl_c (rl_i + 1)) > 0)
3137             then do;
3138 /**** really need to look for quoted strings in the process...               */
3139                i = index (substr (rl_s, rl_i + 1), "}");
3140                if (i = 0)
3141                then do;
3142                   msg = "Gvd) Missing } on \g{.";
3143                   goto gv_msg_com;
3144                end;
3145                call make_rp (seval_op, substr (rl_s, rl_i + 2, i - 1));
3146                rl_i = rl_i + cf.len + 1;
3147 
3148             end;
3149             else if (ch = "=")
3150             then do;
3151                rl_i = rl_i + 1;
3152                if (cf.len = 0)
3153                then goto err_Sne;
3154                ch = substr (cf.da, cf.len, 1);
3155                cf.len = cf.len - 1;
3156                call make_rp (sdup_op, ch);
3157 
3158             end;
3159             else call make_rp (srepl_op, ch);
3160          end;
3161          else if ch = "&"               /* (replace with matched string)     */
3162          then do;
3163             call make_rp (sself_op, "&");
3164 
3165          end;
3166          else call make_rp (srepl_op, ch);
3167       end;
3168       goto err_Sd3;                     /* shouldn't reach here              */
3169 
3170 make_rp: proc (op1, ch);
3171 dcl op1             fixed bin,
3172     ch              char (*);
3173 
3174       if (cf.op ^= op1)                 /* is element different than new one */
3175       then do;
3176          cf.siz = size (cf);
3177          call end_cf;
3178          cf.op = op1;
3179          if (op1 = 0)
3180          then return;
3181       end;
3182 (nostringrange): substr (cf.da, cf.len + 1, length (ch)) = ch;
3183       cf.len = cf.len + length (ch);    /* add char to element               */
3184       cf.siz = size (cf);
3185    end make_rp; %skip;
3186    end replace; %page;
3187 print: proc;
3188 
3189       pi_label = end_pr;                /* allow printing to be aborted      */
3190       pi_sw = 1;                        /*  by means of a PI                 */
3191       call addr_status (b.b_.l.le, b.b_.r.re);
3192       if (b_stat = B_LO_HI)             /* range is split,                   */
3193       then do;                          /*   print left part                 */
3194          call iox_$put_chars (iox_$user_output,
3195               addr (b_c (b.a_.l.re (1))),
3196               b.b_.l.re - b.a_.l.re (1) + 1, 0); /* (ignoring return code)   */
3197          b.a_.l.re (1) = b.b_.r.le;     /* adjust to look unsplit            */
3198          if db_ted
3199          then call ioa_$ioa_switch (db_output, "---- hole ----");
3200       end;
3201                                         /* here always looks like unsplit    */
3202       call iox_$put_chars (iox_$user_output,
3203            addr (b_c (b.a_.l.re (1))),
3204            b.a_.r.le (2) - b.a_.l.re (1) + 1, 0);
3205 end_pr:
3206       pi_sw = 0;                        /* turn off PI handling              */
3207 
3208    end print; %page;
3209 dcl fcbsp           ptr;
3210 dcl fo_name         char (7);
3211 dcl fop             ptr;                /* -> destination of file_out        */
3212 detach: proc (finish);
3213 
3214 dcl finish          bit (1);
3215 
3216       fo_sw = "0"b;
3217       begin;
3218          got_quit = "0"b;               /* We can't be interrupted while we  */
3219          on quit got_quit = "1"b;       /* ..are messing with switches       */
3220          call iox_$detach_iocb (iox_$user_output, code);
3221          if (code ^= 0)
3222          then do;
3223             call com_err_ (code, DBA, "detach user_output");
3224          end;
3225          call iox_$move_attach (fcbsp, iox_$user_output, code);
3226          if (code ^= 0)
3227          then do;
3228             call com_err_ (code, DBA, "move attach ^asave", fo_name);
3229          end;
3230          call iox_$close (fcbp, code);
3231          call iox_$detach_iocb (fcbp, code);
3232          if (code ^= 0)
3233          then do;
3234             call com_err_ (code, DBA, "detach ted_fo");
3235          end;
3236          revert quit;                   /* Now we can be interrupted again   */
3237       end;
3238       if got_quit                       /* If he tried to get thru earlier,  */
3239       then signal quit;                 /* ..give it to him now.             */
3240       if finish
3241       then return;
3242       old_bp = bp;
3243       bp = fop;
3244       call hcs_$initiate_count (pdname, "ted_." || dbase.rq_id, "", bc, 0,
3245            tbp, code);
3246       if (tbp = null)
3247       then do;
3248          call com_err_ (code, "ted", "output_file (^a>ted_.^a)", pdname,
3249               dbase.rq_id);
3250       end;
3251       else do;
3252          call delete$all;               /* iso_line not needed               */
3253          call add_2l (ted_safe, tbp, divide (bc, 9, 21, 0), NLct_unknown);
3254          call hcs_$truncate_seg (tbp, 0, 0);
3255          call hcs_$terminate_noname (tbp, 0);
3256       end;
3257       if ^b.force_name
3258       then do;
3259          b.file_sw = "0"b;
3260          b.dname = "";
3261       end;
3262       b.a_.l.le (0), b.a_.l.re (0) = 1;
3263       b.a_.r.le (0), b.a_.r.re (0) = addr_undef;
3264       b.get_bit_count = "0"b;
3265       bp = old_bp;
3266 dcl old_bp          ptr;
3267 
3268    end detach; %page;
3269 
3270 
3271 
3272 dcl superfile       char (196) int static init (
3273                     "l t|               CONTENTS|
3274 b(arg1) ?1,1n t| (match ""| p t|"")| S|/|\c\c/| >s
3275 a ^\F
3276 :s b(exec) l l
3277 >a \B(exec)
3278 l l Q
3279 :a /^^L             / s/// +3*/^""/ s/$/                                 / (33),+3(1)d
3280 */\B(arg1)/ p
3281 >a
3282 
3283 "); %skip (4);
3284 /* . . . MSG_PATH . . */
3285 
3286 msg_path: proc (mark1);
3287 
3288 dcl mark1           char (*);
3289 
3290 /* RW 88 */
3291       msg = rtrim (msg) || " " || ltrim (rtrim (fd.dname)); /*#197*/
3292       if (msg ^= ">")
3293       then msg = msg || ">";
3294       msg = msg || rtrim (fd.ename);
3295       if (mark1 = " ")
3296       then return;
3297       msg = msg || mark1;
3298       if (mark1 = ":")
3299       then msg = msg || ":";
3300       msg = msg || rtrim (fd.cname);
3301 
3302    end msg_path; %skip (2);
3303 ck_blank: proc;
3304 
3305       if (ted_mode ^= COM)
3306       then if (index ("
3307            ", rl_c (rl_i)) = 0)
3308            then goto err_Snb;
3309 
3310    end ck_blank;
3311 %page;
3312 ignore_1: proc;
3313 
3314 /**** tell user that 1st addr will be ignored if present (in qedx mode)      */
3315       if ^b.present (2)                 /* if there isn't any 2nd addr..     */
3316       then return;                      /*  ..AOK                            */
3317       if ^qedx_mode                     /* This warning only occurs in       */
3318       then goto not_2;                  /* ..qedx mode.                      */
3319       b21 = "1st";
3320       goto common;
3321 
3322 ignore_2: entry;
3323 
3324 /**** tell user that 2nd addr will be ignored if present (in qedx mode)      */
3325       if ^b.present (2)                 /* if there isn't any 2nd addr..     */
3326       then return;                      /*   ..no sweat                      */
3327       if ^qedx_mode                     /* if not in qedx mode               */
3328       then do;                          /* ..jump on him about it            */
3329 not_2:
3330          msg = "Sn2) 2 addrs not allowed.";
3331          goto add_request;
3332       end;
3333       b21 = "2nd";
3334       goto common;
3335 
3336 ignore_all: entry;                      /* ignore buffer change & addr's     */
3337 
3338 dcl b21             char (4);
3339 
3340       bp = ptr (dbase_p, dbase.cb_c_r);
3341       cb_w_r = rel (bp);
3342 
3343 ignore_both: entry;                     /* keep buffer change, ignore addr's */
3344 
3345 /**** tell user that both addr will be ignored if present (in qedx mode)     */
3346       if ^b.present (1)                 /* if no addr..                      */
3347       then return;                      /*   ..all is well                   */
3348       if ^qedx_mode                     /* if not in qedx mode               */
3349       then do;                          /* ..complain                        */
3350          msg = "Sn1) No addrs allowed.";
3351          goto add_request;
3352       end;
3353       b21 = "both";
3354 common:
3355       call ioa_ ("Warning: ^a ignores ^a addr.", req_str, b21);
3356 
3357    end ignore_1; %page;
3358 scan: proc;
3359 
3360 dcl ch              char (1);
3361 
3362       delim = rl_c (rl_i);              /* pick up str delimiter             */
3363       if (delim = " ")
3364            | (delim = NL)
3365       then goto err_Sd1;
3366       expr_b = rl_i + 1;
3367       concealsw = "0"b;
3368       do rl_i = rl_i + 1 to rl_l;       /* try to find end of str1      */
3369          if ^concealsw
3370          then do;
3371             ch = rl_c (rl_i);
3372             if (ch = delim)
3373             then goto sub1;
3374             if (ch = BS_C)
3375             then concealsw = "1"b;
3376             if (ch = "\")
3377             then do;
3378                if (rl_c (rl_i + 1) = "c")
3379                then goto bs_c;
3380                if (rl_c (rl_i + 1) = "C")
3381                then do;
3382 bs_c:
3383                   rl_i = rl_i + 1;
3384                   concealsw = "1"b;
3385                end;
3386             end;
3387          end;
3388          else concealsw = "0"b;
3389       end;
3390 
3391       goto err_Sd2;                     /*  no end of str1                   */
3392 
3393 sub1:
3394       expr_l = rl_i - expr_b;
3395       j, rl_i = rl_i + 1;               /*  first char of str2               */
3396 
3397    end scan; %page;
3398 dcl (
3399     B_MT            init (0),           /* buffer empty                      */
3400     B_LO_LO         init (1),           /* range is in low part              */
3401     B_LO_HI         init (2),           /* range spans the hole              */
3402     B_HI_HI         init (3)            /* range is in high part             */
3403     )               fixed bin int static options (constant);
3404 
3405 dcl b_stat          fixed bin;
3406 dcl b_lhe           fixed bin (21);
3407 dcl b_rhe           fixed bin (21);
3408 
3409 addr_status_ends_set: proc (lhe, rhe);  /* set address and then...           */
3410       b.a_.l.re (1) = lhe;
3411       b.a_.r.le (2) = rhe;
3412 
3413 addr_status_ends: entry (lhe, rhe);     /* give status & left/right ends     */
3414 
3415 dcl (lhe, rhe)      fixed bin (21);     /* left-hand/right-hand ends to use  */
3416 
3417 /**** The A's represent the addressed range.                                 */
3418 /**** ................     buffer empty   --> b_stat = B_MT    (0)           */
3419 /**** xxAAAAxx...xxxxx - al=low   ar=low  --> b_stat = B_LO_LO (1)           */
3420 /**** xxxxxAAA...AAxxx - al=low   ar=high --> b_stat = B_LO_HI (2)           */
3421 /**** xxxx.....xAAAxxx - al=high  ar=high --> b_stat = B_HI_HI (3)           */
3422 /****     Any other conditions will cause an error message to be printed.    */
3423 /**** b_lhe, b_rhe contain actual left and right data locations in buffer.   */
3424 
3425       if (b.cur.sn = 0)
3426       then do;
3427          b_stat = B_MT;
3428          goto finis;
3429       end;
3430       b_lhe = lhe;                      /* find lefthand end                 */
3431       if (b.b_.l.re < b_lhe)            /* is lower part empty?              */
3432       then b_lhe = b.b_.r.le;           /* ..switch to upper                 */
3433       b_rhe = rhe;                      /* find righthand end                */
3434       if (b.b_.r.le > b_rhe)            /* is upper part empty?              */
3435       then b_rhe = b.b_.l.re;           /* ..switch to lower                 */
3436       if db_ted
3437       then call ioa_$ioa_switch (db_output, ".   :ends=^i,^i", b_lhe, b_rhe);
3438 
3439 addr_status: entry (lhe, rhe);          /* give status only                  */
3440       if (b.cur.sn = 0)
3441       then do;
3442          b_stat = B_MT;
3443          goto finis;
3444       end;
3445 /**** If there is an upper part & addr-left is just after lower part         */
3446       if (b.b_.r.re >= b.b_.r.le) & (b.a_.l.re (1) = b.b_.l.re + 1)
3447       then b.a_.l.re (1) = b.b_.r.le;   /* switch to upper part              */
3448 /**** If there is a lower part & addr-right is just before upper part        */
3449       else if (b.b_.l.re >= b.b_.l.le) & (b.a_.r.le (2) = b.b_.r.le - 1)
3450       then b.a_.r.le (2) = b.b_.l.re;   /* switch to lower part              */
3451       if (b.b_.l.re + 1 >= b.a_.l.re (1))
3452       then do;
3453          if (b.b_.l.re + 1 >= b.a_.r.le (2))
3454          then do;
3455             b_stat = B_LO_LO;
3456             goto finis;
3457          end;
3458          if (b.b_.r.le <= b.a_.r.le (2))
3459          then do;
3460             b_stat = B_LO_HI;
3461             goto finis;
3462          end;
3463       end;
3464       else if (b.b_.r.le <= b.a_.l.re (1))
3465            & (b.b_.r.le <= b.a_.r.le (2))
3466       then do;
3467          b_stat = B_HI_HI;
3468 finis:
3469          if db_ted
3470          then call ioa_$ioa_switch (db_output, ".   :stat=^a",
3471                    substr ("MTLLLHHH", b_stat * 2 + 1, 2));
3472          return;
3473       end;
3474       call ioa_ ("Error: b=^i,^i,^i,^i a=^i,^i", lhe, b.b_.l.re, b.b_.r.le,
3475            rhe, b.a_.l.re (1), b.a_.r.le (2));
3476       msg = "Aae) Addressing error occurred.";
3477       goto print_error;
3478 
3479    end addr_status_ends_set; %page;
3480 buffer_buffer_copy: proc (asbp, adbp, add_right);
3481 
3482 dcl asbp            ptr,                /* source buffer control block       */
3483                                         /* range to copy is-                 */
3484                                         /*    b.cd.l.re : b.cd.r.le          */
3485     adbp            ptr,                /* destination buffer control block  */
3486                                         /* data is INSERTed at-              */
3487                                         /*    b.cd.r.re                      */
3488     add_right       bit (1);            /* 0- data is added to left of hole  */
3489                                         /* 1- data is added right            */
3490 
3491 dcl old_bp          ptr;
3492 dcl (sbp, dbp)      ptr;                /* -> source, destination ctl block  */
3493 dcl tbp             ptr;
3494 dcl lndx            fixed bin (21) based; /* left index for cpy_2 call      */
3495 dcl (l, tl, tr)     fixed bin (21);
3496 
3497 /**** Care must be taken to avoid being wiped out when source = destination. */
3498 /**** These are various conditions which can happen when they are.           */
3499 /****   The "A"s represent the address range.                                */
3500 /****   The "I"s represent the inserted data.                                */
3501 /****   The "x"s represent the uninvolved data                               */
3502 /****   The "."s represent the gap                Col 2 only happens with K. */
3503 /**** Line 1  points to the destination.                                     */
3504 /**** Line 2  is the initial buffer state.                                   */
3505 /**** Line 3  is the state after openup.                                     */
3506 /**** Line 4  is the state after moving left part of range, if any.          */
3507 /**** Line 5  is the state after moving right part, if any.                  */
3508 /**** Line 6  is the state after deletion (M only).                          */
3509 
3510 /**** Inserting in ?, ? addressed data.           ?, ? pairs shown below     */
3511 /****                                                                        */
3512 /**** ?,? |    upper, above    |   upper, within    |   upper, below     |   */
3513 /**** 1)  |  ..........v.....  |  ..........v.....  |  ..........v.....  |   */
3514 /**** 2)  |  AAAxx....xxxxxxx  |  xxx......AAAAxxx  |  xx....xxxxxxAAAx  |   */
3515 /**** 3)  |  AAAxxx....xxxxxx  |  xxxA......AAAxxx  |  xxxxxx....xxAAAx  |   */
3516 /**** 4)  |  AAAxxxMMM.xxxxxx  |  xxxAM.....AAAxxx  |                    |   */
3517 /**** 5)  |                    |  xxxAMNNN..AAAxxx  |  xxxxxxNNN.xxAAAx  |   */
3518 /**** 6)  |  ....xxxMMMxxxxxx  |                    |  xxxxxxNNNxx....x  |   */
3519 
3520 /**** ?,? |    lower, above    |   lower, within    |   lower, below     |   */
3521 /**** 1)  |  ...v............  |  ....v...........  |  ...v............  |   */
3522 /**** 2)  |  AAAxx....xxxxxxx  |  xxxAAAA......xxx  |  xxxxxxx....xAAAx  |   */
3523 /**** 3)  |  AAA....xxxxxxxxx  |  xxxA......AAAxxx  |  xxx....xxxxxAAAx  |   */
3524 /**** 4)  |  AAAMMM.xxxxxxxxx  |  xxxAM.....AAAxxx  |                    |   */
3525 /**** 5)  |                    |  xxxAMNNN..AAAxxx  |  xxxNNN.xxxxxAAAx  |   */
3526 /**** 6)  |  ....xxxMMMxxxxxx  |                    |  xxxxxxNNNxx....x  |   */
3527 
3528       sbp = asbp;                       /* save parameter values, they get   */
3529       dbp = adbp;                       /* ..clobbered sometimes             */
3530       old_bp = bp;                      /* keep current bp value             */
3531 
3532       if db_ted
3533       then do;
3534          call ioa_$ioa_switch (db_output, ">bbc: b(^a,^i,^i)->b(^a,^i)^[right^;left^]",
3535               sbp -> b.name, sbp -> b.cd.l.re, sbp -> b.cd.r.le,
3536               dbp -> b.name, dbp -> b.cd.r.re, add_right);
3537          if (sbp = dbp)
3538          then call tedshow_ (sbp, ". s=d cd adr");
3539          else do;
3540             call tedshow_ (sbp, ". sb cd adr");
3541             call tedshow_ (dbp, ". db cd adr");
3542          end;
3543       end;
3544 
3545       if (sbp -> b.cur.sn = 0)
3546       then do;                          /* The source is empty               */
3547          msg = "b(";
3548          msg = msg || rtrim (sbp -> b.name);
3549          msg = msg || ")";
3550          call tederror_rc_ (dbase_p, msg,
3551               (tederror_table_$zero_length_buffer));
3552       end;
3553 
3554 /***** DESTINATION buffer  * * * * * * * * * * * * * * * * * * * * * * * * * */
3555       bp = dbp;
3556       b.a_.l.re (1), b.a_.r.le (2) = b.cd.r.re; /* set openup point          */
3557       call openup;                      /* move hole to where data is to go  */
3558       if (b.b_.r.re = 0)
3559       then b.a_.r.le (1) = 0;           /* note buffer was empty             */
3560       else b.a_.r.le (1) = b.b_.r.le;   /* keep rle before data moved in     */
3561       if db_ted then call tedshow_ (bp, "a1");
3562 
3563 /***** SOURCE buffer * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
3564       bp = sbp;
3565       call addr_status_ends (1, b.maxl);
3566 
3567       b.cd.l.re = max (b.cd.l.re, b_lhe);
3568       b.cd.r.le = min (b.cd.r.le, b_rhe);
3569       if (b_lhe = b.cd.l.re) & (b_rhe = b.cd.r.le) /* taking all there is?   */
3570       then b.not_pasted = "0"b;         /* no longer worry                   */
3571 
3572 /**** When doing a move request within a buffer, the buffer will never be    */
3573 /**** ..split at this point because openup has already been done at the      */
3574 /**** ..destination. The destination may not be within the source.           */
3575       if (b_stat = B_LO_HI)             /* range being read is split         */
3576       then do;
3577          tr = b.cd.r.le - b.b_.r.le + 1;/* calc right length             #1xx*/
3578          tl = b.b_.l.re - b.cd.l.re + 1;/* calc left  length             #1xx*/
3579          if add_right
3580          then do;
3581             tbp = addr (b.b_.r.le);     /* -> index of left of right part    */
3582             l = tr;                     /* #1xx*/
3583          end;
3584          else do;
3585             tbp = addr (b.cd.l.re);     /* -> index of right of left part#1xx*/
3586             l = tl;                     /* #1xx*/
3587          end;
3588 /*****              DESTINATION buffer * * * * * * * * * * * * * * * * * * * */
3589          bp = dbp;                      /* switch to destination             */
3590          call cpy_2 (ted_safe, sbp -> b.cur.sp, l, NLct_unknown, tbp -> lndx,
3591               add_right);               /* #1xx*/
3592 /*****              SOURCE buffer  * * * * * * * * * * * * * * * * * * * * * */
3593          bp = sbp;                      /* switch to source again            */
3594          if add_right
3595          then do;                       /* #1xx*/
3596             tbp = addr (b.cd.l.re);     /* -> index of right of left part#1xx*/
3597             l = tl;                     /* #1xx*/
3598          end;                           /* #1xx*/
3599          else do;                       /* #1xx*/
3600             tbp = addr (b.b_.r.le);     /* -> index of left of right part#1xx*/
3601             l = tr;                     /* #1xx*/
3602          end;                           /* #1xx*/
3603       end;
3604       else do;                          /* #1xx*/
3605          tbp = addr (b.cd.l.re);        /* -> index of left of string    #1xx*/
3606          l = b.cd.r.le - b.cd.l.re + 1; /* calc length to move           #1xx*/
3607       end;                              /* #1xx*/
3608 /***** DESTINATION buffer  * * * * * * * * * * * * * * * * * * * * * * * * * */
3609       bp = dbp;
3610       call cpy_2 (ted_safe, sbp -> b.cur.sp, l, NLct_unknown, tbp -> lndx,
3611            add_right);
3612       if db_ted
3613       then do;
3614          call tedshow_ (dbp, ". db b_ a1");
3615          call ioa_$ioa_switch (db_output, "<bbc");
3616       end;
3617       bp = old_bp;                      /* restore old bp value              */
3618       asbp = sbp;                       /* restore the parameters            */
3619       adbp = dbp;
3620 
3621    end buffer_buffer_copy; %page;
3622 mov_2l:                                 /* move buffer data to the left      */
3623    proc (safe_mode, Aastr_p, astr_l, NLct);
3624 dcl (
3625     safe_mode       bit (1) aligned,    /* 1- ensure strings don't overlay   */
3626                                         /* 0- don't worry about it           */
3627     Aastr_p         ptr,                /* -> string to add (^cpy_2)         */
3628                                         /* -> base of string to add (cpy_2)  */
3629     astr_l          fixed bin (21),     /*   length thereof                  */
3630     NLct            fixed bin (21)      /*  -1 - don't know                  */
3631                                         /*  -2 - find out now many           */
3632                                         /* >=0 - number present              */
3633     )               parm;
3634 
3635 dcl add_right       bit (1);            /* 0- add to left end of hole        */
3636                                         /* 1- add to right end of hole       */
3637 dcl make_room       bit (1);            /* 0- just moving the hole           */
3638                                         /* 1- adding to buffer, make sure    */
3639                                         /*    there is enough room           */
3640 dcl adj             fixed bin (21);
3641 dcl id              char (3);
3642 
3643       id = "m2l";
3644       add_right = "0"b;
3645       make_room = "0"b;
3646       goto start;
3647 
3648 mov_2r:                                 /* move buffer data to the right     */
3649    entry (safe_mode, Aastr_p, astr_l, NLct);
3650       id = "m2r";
3651       add_right = "1"b;
3652       make_room = "0"b;
3653       goto start;
3654 
3655 add_2l:                                 /* add data to the left of hole      */
3656    entry (safe_mode, Aastr_p, astr_l, NLct);
3657       id = "a2l";
3658       add_right = "0"b;
3659       make_room = "1"b;
3660       goto start;
3661 
3662 add_2r:                                 /* add data to the right of hole     */
3663    entry (safe_mode, Aastr_p, astr_l, NLct);
3664       id = "a2r";
3665       add_right = "1"b;
3666       make_room = "1"b;
3667       goto start;
3668 
3669 cpy_2:                                  /* add data where specified          */
3670    entry (safe_mode, Aastr_p, astr_l, NLct, lindex, which_side);
3671 /****Aastr_p -> -> BASE of string                                            */
3672 dcl lindex          fixed bin (21);     /* index of left end of string       */
3673 dcl which_side      bit (1);
3674 /**** buffer_buffer_copy calls this entry.  One of the circumstances which   */
3675 /****  can occur is 1) source-buffer=destination-buffer 2) promotion occurs. */
3676 /**** Thus this entry points to the pointer and points to the left index so  */
3677 /****  that if the source string gets moved, the reference to it will keep   */
3678 /****  up with it.                                                           */
3679       add_right = which_side;
3680       if add_right
3681       then id = "c2r";
3682       else id = "c2l";
3683       make_room = "1"b;
3684       astr_p = addcharno (Aastr_p, lindex - 1);
3685       if ""b
3686       then do;
3687 start:
3688          astr_p = Aastr_p;
3689       end;
3690       if (astr_l = 0)
3691       then return;
3692       adj = NLct;
3693       if (adj = -2)
3694       then do;
3695          j = index (astr, NL);
3696          if (j = 0)
3697          then do;                       /* contains NO new-line              */
3698             if (b.b_.r.le > b.b_.r.re)  /* if upper part empty               */
3699             then adj = -1;              /* can't tell what change it makes   */
3700             else adj = 0;               /* makes no change in linecount      */
3701          end;
3702          else if (j = astr_l)
3703          then adj = 1;                  /* contains ONE new-line             */
3704          else adj = -1;                 /* >1 new-lines                      */
3705       end;
3706       if db_ted
3707       then do;
3708          call tedshow_ (bp, ">", id, "b_");
3709          call ioa_$ioa_switch (db_output, " ^a:    ^[SAFE ^]l=^i adj=^i",
3710               id, safe_mode, astr_l, adj);
3711       end;
3712       if (adj = NLct_unknown)
3713       then do;
3714          if ^add_right
3715          then b.b_.l.ln = NLct_unknown;
3716          b.maxln, b.b_.r.ln = NLct_unknown;
3717       end;
3718       else do;
3719          if (b.maxln ^= -1)
3720          then b.maxln = b.maxln + adj;
3721          if (b.b_.l.ln ^= -1) & ^add_right
3722          then b.b_.l.ln = b.b_.l.ln + adj;
3723          if (b.b_.r.ln ^= -1)
3724          then b.b_.r.ln = b.b_.r.ln + adj;
3725       end;
3726 
3727       if make_room                      /* adding new data to buffer         */
3728       then do;
3729          b.mod_sw = "1"b;               /* buffer is modified                */
3730          hole = b.b_.r.le - b.b_.l.re - 1; /* how much room left             */
3731          hole = hole - astr_l;          /* how much left after adding        */
3732          if (hole < 0)                  /* is enough room left?              */
3733          then call promote (-hole);     /* no, must try to get more          */
3734          if (substr (id, 1, 2) = "c2")
3735          then do;
3736 /**** This chases the source string which may have been moved by promotion.  */
3737             astr_p = addcharno (Aastr_p, lindex - 1);
3738          end;
3739       end;
3740       b.newb = b.b_;
3741       if ^make_room
3742       then b.newb.l.ln = NLct_unknown;
3743       if db_ted & lg_ted
3744       then if (astr_l > 100)
3745            then call ioa_$ioa_switch (db_output, "astr=""^50a^/<^i chars>^/^50a""^[-->@^i^;<--@^s^i^]",
3746                      substr (astr, 1, 50), astr_l - 100, substr (astr, astr_l - 49, 50),
3747                      add_right, b.b_.r.le - 1, b.b_.l.re + 1);
3748            else call ioa_$ioa_switch (db_output, "astr=""^va""^[-->@^i^;<--@^s^i^]", astr_l, astr,
3749                      add_right, b.b_.r.le - 1, b.b_.l.re + 1);
3750       if (chars_moved >= 0)
3751       then chars_moved = chars_moved + astr_l;
3752       if add_right
3753       then do;                          /* put the data on right via MRL     */
3754          b.new.re = b.b_.r.le - 1;
3755          b.new.le = b.b_.r.le - astr_l;
3756          b.newb.r.le = b.new.le;
3757          if ^make_room                  /* moving data within the buffer?    */
3758          then do;
3759             b.old.re, b.test.re = b.b_.l.re;
3760             b.old.le, b.test.le = b.old.re - astr_l + 1;
3761             b.test.re = b.test.re + 1;  /* allow l.re+1 to relocate          */
3762             if (b.test.le = 1)          /* if at beginning of buffer         */
3763             then b.test.le = b.test.le - 1; /* ..allow l.le-1 also           */
3764             b.newb.l.re = b.old.le - 1;
3765          end;
3766          call mrl_ (astr_p, astr_l, addr (b_c (b.new.le)), astr_l);
3767       end;
3768       else do;                          /* put the data on left via MLR      */
3769          b.new.le = b.b_.l.re + 1;      /* figure where its going to         */
3770          b.new.re = b.new.le + astr_l - 1;
3771          b.newb.l.re = b.new.re;
3772          if ^make_room                  /* moving data within buffer?        */
3773          then do;                       /* figure where its coming from      */
3774             b.old.le, b.test.le = b.b_.r.le;
3775             b.old.re, b.test.re = b.old.le + astr_l - 1;
3776             b.test.le = b.test.le - 1;  /* allow r.le-1 to relocate          */
3777             if (b.test.re = b.maxl)     /* if at end of buffer               */
3778             then b.test.re = b.test.re + 1; /* ..allow r.re+1 also           */
3779             b.newb.r.le = b.old.re + 1;
3780          end;
3781          substr (b_s, b.new.le, astr_l) = astr;
3782          if db_ted then call ioa_$ioa_switch (db_output,
3783 /****              1                 2  3   4            5                   */
3784                    "a2*: (^p->b_s,b.new.le(^i),^i)=^p->astr,len=^i",
3785                    b.cur.sp, b.new.le, astr_l, astr_p, b.new.le + astr_l - 1);
3786       end;
3787       if make_room
3788       then call update;
3789       else call relocate;
3790       if db_ted
3791       then call tedshow_ (bp, "< b_"); %skip;
3792 dcl astr            char (astr_l) based (astr_p);
3793 dcl astr_p          ptr;
3794 dcl hole            fixed bin (21);     /* size of hole                      */
3795 
3796    end mov_2l; %page;
3797 delete:                                 /* delete a string from a buffer     */
3798    proc;
3799 
3800 /**** The string to remove is defined by:   b.a_.l.re (1) : b.a_.r.le (2)  */
3801 /**** Upon exit, l.re (1), r.le (2) = r.le (2) + 1;                          */
3802 
3803       if db_ted
3804       then call tedshow_ (bp, "> del max adr");
3805       call addr_status_ends (1, b.maxl);
3806       if (b_lhe = b.a_.l.re (1)) & (b_rhe = b.a_.r.le (2))
3807       then do;                          /* deleting whole thing              */
3808 dcl which           char (1);
3809          if ""b
3810          then do;
3811 delete$all: entry;
3812             which = ".";
3813          end;
3814          else which = "<";
3815          if db_ted
3816          then call tedshow_ (bp, which, "[all b(" || rtrim (b.name) || ")");
3817          call demote (0);               /* get rid of buffer space           */
3818          b.a_ (1) = tedcommon_$no_data;
3819          b.a_ (2) = tedcommon_$no_data;
3820          b.ex = tedcommon_$no_data;
3821          b.mod_sw = "1"b;
3822          return;
3823       end;
3824 
3825       if b.pseudo                       /* if ^read file..                   */
3826       then do;
3827          call promote (b.maxl);         /* ..then get it read                */
3828          call addr_status (b.b_.l.le, b.b_.r.re);
3829       end;
3830 
3831 /**** select action based on where left and right ends of range are          */
3832 
3833       if (b_stat = B_LO_LO)
3834       then do; %skip (2);
3835 /****     Before:  xxxxxxAAAAyyyyyy............zzzzzzzzzz   al=low           */
3836 /****     openup:  xxxxxxAAAA............yyyyyyzzzzzzzzzz   ar=low           */
3837 /****      After:  xxxxxx................yyyyyyzzzzzzzzzz                    */
3838 /****        ".":                        |                                   */
3839 /**** When AAAA is addressed, usually characters AAAAyyyyyy will be moved    */
3840 /****  before the work begins. However, when deleting, only characters       */
3841 /****  yyyyyy need to be moved before doing the adjust. The rest are going   */
3842 /****  to be thrown away. We don't even care if zzzzzzzzzz is null.          */
3843 
3844          b.a_.r.re (1) = b.a_.l.re (1); /* save beginning of range where it  */
3845                                         /*  will be relocated                */
3846          b.a_.l.re (1) = min (b.a_.r.le (2) + 1, b.b_.r.re + 1);
3847                                         /* set left of moved data      */
3848          call openup;
3849          b.newb = b.b_;
3850          b.newb.l.re = b.a_.r.re (1) - 1; /* set new buffer left end from   */
3851                                         /*  saved data                       */
3852       end; %skip (3);
3853       else if (b_stat = B_LO_HI)
3854       then do;
3855 /**** Before: zzzzzzzAAA............AAAAAyyyyyyyyyyy        al=low           */
3856 /****  After: zzzzzzz....................yyyyyyyyyyy        ar=high          */
3857 /****    ".":                            |                                   */
3858 /**** When the address spans the hole, adjusting does all                    */
3859 
3860          b.newb = b.b_;
3861          b.newb.l.re = b.a_.l.re (1) - 1; /* set buffer left end             */
3862          b.newb.r.le = b.a_.r.le (2) + 1; /* set buffer right end            */
3863       end;
3864       else do;
3865 /**** Before: zzzzzzzzzz............xxxxxxAAAAyyyyyy        al=high          */
3866 /**** openup: zzzzzzzzzzxxxxxx............AAAAyyyyyy        ar=high          */
3867 /****  After: zzzzzzzzzzxxxxxx................yyyyyy                         */
3868 /****    ".":                                 |                              */
3869 /**** When AAAA is addressed, characters xxxxxx are moved. Then the data is  */
3870 /****  removed by adjusting.                                                 */
3871 
3872          call openup;
3873          b.newb = b.b_;
3874          if (b.b_.r.le <= b.b_.r.re)    /* if right part not empty           */
3875          then                           /* ..set buffer right end            */
3876               b.newb.r.le = min (b.b_.r.re + 1, b.a_.r.le (2) + 1);
3877       end; %skip (3);
3878 /**** must get smarter about line number handling                            */
3879       b.newb.l.ln, b.newb.r.ln, b.maxln = NLct_unknown;
3880       b.mod_sw = "1"b;
3881                                         /* set "." to first char after       */
3882       call update;
3883       b.a_.r.le (2) = b.b_.r.le;        /* fall off end?                     */
3884       if db_ted
3885       then call tedshow_ (bp, "< adr");
3886                                         /* ?should check for refs to data?   */
3887       return;
3888 
3889    end delete; %page;
3890 /**** open up the hole at designated location in current window of           */
3891 /****  designated buffer                                                     */
3892 /****  ASSUMPTION: the hole is always within this window                     */
3893 openup: proc;
3894 
3895       if db_ted
3896       then call tedshow_ (bp, "> opn b_");
3897       if b.invoking
3898       then do;                          /* #156*/
3899          msg = "Bnm) Attempting to modify a buffer while it is being invoked.";
3900          goto print_error;              /* #156*/
3901       end;                              /* #156*/
3902       if b.pseudo                       /* if ^read file then get it read    */
3903       then call promote (b.maxl);       /*   first                           */
3904       at = b.a_.l.re (1);
3905 
3906 /*common:*/
3907       if db_ted
3908       then call ioa_$ioa_switch (db_output, "    : b(^a)@^i", b.name, at);
3909       action = "no seg";
3910       if (b.cur.sn = 0)                 /* if no segment, then there is...   */
3911       then goto finis;                  /*   ...only hole: you're in it.     */
3912 
3913       action = "already";
3914       if (at = b.b_.r.le) | (at = b.b_.l.re + 1)
3915       then goto finis;                  /* already there                     */
3916 
3917 /**** If running in SAFE mode, the move must be done ensuring that the       */
3918 /****  source and destination strings never overlap. If they did and a crash */
3919 /****  occurred in the middle, there would be no way to restart the          */
3920 /****  operation. If not safe, then we don't care because we will never have */
3921 /****  to try to restart. add takes this into account.                       */
3922 
3923       if (at > b.b_.l.re)               /* not in left part?                 */
3924       then do;
3925          if (at < b.b_.r.le)            /* in the hole?                      */
3926          then do;
3927             if (at = b.maxl)            /* right part empty?                 */
3928             then goto finis;
3929             signal condition (at_in_gap); dcl at_in_gap condition;
3930          end;
3931                                         /* move left end of right part down  */
3932          len = min (at, b.maxl + 1) - b.b_.r.le;
3933          call mov_2l (ted_safe, addr (b_c (b.b_.r.le)), len, 0);
3934       end;
3935       else do;                          /* move right end of left part down  */
3936          len = b.b_.l.re - at + 1;
3937          call mov_2r (ted_safe, addr (b_c (at)), len, 0);
3938       end;
3939       action = "";
3940 finis:
3941       if db_ted
3942       then call tedshow_ (bp, "< [" || action);
3943       return; %skip;
3944 dcl action          char (8);
3945 dcl len             fixed bin (21);
3946 dcl at              fixed bin (21);
3947 
3948    end openup; %page;
3949 promote: proc (alen);
3950       seg_sw = "pro";
3951       if db_ted
3952       then call tedshow_ (bp, "> pro max [" || ltrim (char (alen)));
3953       dbase_p = ptr (bp, 0);            /* manufacture database ptr          */
3954 
3955       len = alen + buf_max (b.cur.ast); /* how much total space needed    */
3956       if (len > buf_max (1))
3957       then do;
3958          msg = "Xde) Data exceeds ";
3959          msg = msg || ltrim (char (buf_max (1)));
3960          msg = msg || " characters; request aborted.";
3961          goto print_error;
3962       end;
3963       goto common;
3964 
3965 dcl seg_sw          char (3);
3966 promote$seg: entry;
3967       seg_sw = "p$s";
3968       len = (b.b_.l.re - b.b_.l.le + 1) + (b.b_.r.re - b.b_.r.le + 1);
3969       if db_ted
3970       then call tedshow_ (bp, "> p$s max [" || ltrim (char (len)));
3971 dcl (
3972     alen            fixed bin (21)      /* amount of data which does not...  */
3973     )               parm;               /*   ...fit in the current buffer    */
3974 
3975 /* this routine is called under these circumstances:                         */
3976 /*  1) openup/delete in a ^read file; the file is "materialized".            */
3977 /*  2) add doesn't have a hole big enough for the data                       */
3978 /*  3) buffer needs its own segment ([ted_buffer] or qhold use)              */
3979 
3980 /* These are the various states of b.* (known as of 80-11-15)                */
3981 /*   name       sp       sn,pn,ast lle:lre       rle:rre                     */
3982 /* b((ted))  234|32174   -1, 0, 0    1:67         69:68     -req data        */
3983 /* b((val))  77777|1      0, 1, 0    1:0           1:0      EMPTY            */
3984 /* b(args)   537|4000     1, 3, 0    1:13       4097:4096   PSEUDO (real)    */
3985 /* b(arg1)   537|4000     1, 0, 0    1:5           7:6      PSEUDO (refer)   */
3986 /* b(arg2)   537|4001(18) 1, 0, 0    1:6           8:7      PSEUDO (refer)   */
3987 /* b(0)      622|0       -1, 0, 0    1:265894 265896:265894 ^read file       */
3988 /* b(1)      537|6000     1, 4, 5    1:0        1478:4097   read file        */
3989 /* b(2)      541|0        4, 1, 5    1:2620     4097:4096   [ted_buffered]   */
3990 
3991 common:
3992 /**** Find buffer size which will hold the required amount.        */
3993       b.pend = tedcommon_$no_seg;
3994       do b.pend.ast = 1 to hbound (buf_max, 1) - 1
3995            while (buf_max (b.pend.ast + 1) >= len);
3996       end;
3997 
3998       if (b.cur.ast <= b.pend.ast) & (b.cur.ast ^= 0) & (seg_sw = "pro")
3999       then do;                          /* are they trying to demote?        */
4000          msg = buf_size (b.cur.ast);
4001          msg = msg || "K->";
4002          msg = msg || buf_size (b.pend.ast);
4003          msg = msg || "K logic error";
4004          goto print_error;
4005       end;
4006 
4007       b.newb = b.b_;
4008       b.old.le, b.test.le = b.b_.r.le;
4009       b.old.re, b.test.re = b.b_.r.re;
4010       b.test.re = b.test.re + 1;        /* moving the data upward, so allow  */
4011                                         /*  1 more on high end since many    */
4012                                         /*  requests go until "this">"last". */
4013                                         /*  "this" can be outside of the     */
4014                                         /*  range and would not then get     */
4015                                         /*  relocated.                       */
4016 /**** For right now r.le-1 is left stranded in gap. Can it happen?           */
4017       len = b.old.re - b.old.le + 1;    /* calc how much is being moved      */
4018       b.new.re, b.newb.r.re = buf_max (b.pend.ast);
4019       b.new.le, b.newb.r.le = b.new.re - len + 1;
4020       if (b.cur.sn > 2) & ^b.pseudo     /* already have its own segment?     */
4021       then do;
4022          b.pend.sp = b.cur.sp;
4023          b.pend.sn = b.cur.sn;
4024          if (seg_sw = "pro")
4025          then goto do_move;             /* we will just expand in place      */
4026          b.new.le = b.b_.l.re + 1;
4027          b.new.re = b.new.le + len - 1;
4028          b.newb.r.le = buf_max (b.pend.ast) + 1;
4029          b.newb.l.le = 1;
4030          b.newb.l.re = b.new.re;
4031          substr (b_s, b.new.le, len) = substr (b_s, b.old.le, len);
4032          if db_ted then call ioa_$ioa_switch (db_output,
4033 /****        1   2                3   4    5                6   7       8    */
4034                    "^a:(^p->b_s,b.new.le(^i),^i)=(^p->b_s,b.old.le(^i),^i),len=^i",
4035                    seg_sw, b.cur.sp, b.new.le, len, b.cur.sp, b.old.le, len,
4036                    b.new.le + len - 1);
4037                                         /* compressing the segment           */
4038          goto no_move;
4039       end;
4040       if (seg_sw = "pro")
4041       then do;
4042          if (b.pend.ast = 5)            /* smallest size                     */
4043          then do;
4044             i = index (dbase.inuse_1K, "0"b); /* any room in 1K pool?        */
4045             if (i = 0)
4046             then do;                    /* no, have to try next larger       */
4047                b.pend.ast = 4;
4048                b.new.re, b.newb.r.re = buf_max (b.pend.ast);
4049                b.new.le, b.newb.r.le = b.new.re - len + 1;
4050             end;
4051             else do;                    /* yes, we'll take one               */
4052                if (dbase.seg_p (1) = null ()) /* is there a 1/4K pool?       */
4053                then call tedget_segment_ (dbase_p, dbase.seg_p (1), 1);
4054                b.pend.sp = addr (seg_1K (i));
4055                b.pend.sn = 1;
4056                b.pend.pn = i;
4057                substr (dbase.inuse_1K, i, 1) = "1"b; /* flag it used       */
4058                if db_ted
4059                then call ioa_$ioa_switch (db_output, "    : inuse_1K=^b", dbase.inuse_1K);
4060                if ^b.pseudo
4061                then goto no_move;
4062             end;
4063          end;
4064 
4065          if (b.pend.ast = 4)            /* next smallest size                */
4066          then do;
4067             i = index (dbase.inuse_4K, "0"b); /* any room in 4K pool?        */
4068             if (i = 0)
4069             then do;                    /* no, have to try next larger       */
4070                b.pend.ast = 3;
4071                b.new.re, b.newb.r.re = buf_max (b.pend.ast);
4072                b.new.le, b.newb.r.le = b.new.re - len + 1;
4073             end;
4074             else do;                    /* yes, we'll take one               */
4075                if (dbase.seg_p (1) = null ()) /* is there a 1/4K pool?       */
4076                then call tedget_segment_ (dbase_p, dbase.seg_p (1), 1);
4077                b.pend.sp = addr (seg_4K (i));
4078                b.pend.sn = 1;
4079                b.pend.pn = i + 16;
4080                substr (dbase.inuse_4K, i, 1) = "1"b;
4081                if db_ted
4082                then call ioa_$ioa_switch (db_output, "    : inuse_4K=^b", dbase.inuse_4K);
4083                if (b.cur.ast = 0) & ^b.pseudo
4084                then goto no_move;
4085             end;
4086          end;
4087 
4088          if (b.pend.ast = 3)
4089          then do;
4090             i = index (dbase.inuse_16K, "0"b); /* any room in 16K pool?    */
4091             if (i = 0)
4092             then do;                    /* no, have to get full segment      */
4093                b.pend.ast = 2;
4094                b.new.re, b.newb.r.re = buf_max (b.pend.ast);
4095                b.new.le, b.newb.r.le = b.new.re - len + 1;
4096             end;
4097             else do;                    /* yes, we'll take one               */
4098                if (dbase.seg_p (2) = null ()) /* is there a 16K pool?        */
4099                then call tedget_segment_ (dbase_p, dbase.seg_p (2), 2);
4100                b.pend.sp = addr (seg_16K (i));
4101                b.pend.sn = 2;
4102                b.pend.pn = i;
4103                substr (dbase.inuse_16K, i, 1) = "1"b; /* flag it used       */
4104                if db_ted
4105                then call ioa_$ioa_switch (db_output, "    : inuse_16K=^b", dbase.inuse_16K);
4106                if (b.cur.ast = 0) & ^b.pseudo
4107                then goto no_move;
4108             end;
4109          end;
4110       end;
4111 
4112       if (b.pend.sp = null ())          /* no current buffer space           */
4113       then do;
4114          b.pend.pn = 1;
4115          call tedget_segment_ (dbase_p, b.pend.sp, b.pend.sn);
4116       end;
4117 
4118       if (b.cur.ast > 2) & ((b.cur.sn = 1) | (b.cur.sn = 2))
4119                                         /* got a 1K, 4K, or 16K already      */
4120            | b.pseudo                   /* ..or a fake one?                  */
4121       then do;                          /* copy left-hand data into new one  */
4122          if (b.b_.l.re > 0)
4123          then substr (b.pend.sp -> b_s, 1, b.b_.l.re)
4124                    = substr (b_s, 1, b.b_.l.re);
4125       end;
4126       if (seg_sw = "p$s")
4127       then do;
4128          b.new.le = b.b_.l.re + 1;
4129          b.new.re = b.new.le + len - 1;
4130          b.newb.l.re = b.newb.l.re + len;
4131          b.newb.r.le = b.b_.r.re + 1;
4132       end;
4133 do_move:
4134       if (len > 0)                      /* if anything to move...            */
4135       then do;                          /*   do it                           */
4136 /**** During this move, the strings can never overlay, but MRL is being used */
4137 /****  to get the maximum bounds fault out of the way immediately.           */
4138          call mrl_ (addr (b_c (b.old.le)), len,
4139               addr (b.pend.sp -> b_c (b.new.le)), len);
4140       end;
4141 no_move:
4142       call relocate;                    /* 1) relocate refs to moved data    */
4143                                         /* 1a)(terminate ^read segment)      */
4144                                         /* 2) update b.maxl, b.cur           */
4145                                         /* 3) update b.b_                    */
4146       if (seg_sw = "p$s")
4147       then call hcs_$truncate_seg
4148                 (b.cur.sp, divide (b.b_.l.re + 3, 4, 21, 0), 0);
4149       b.pseudo = ""b;                   /* buffer is now for real            */
4150       if db_ted
4151       then call tedshow_ (bp, "max cur < b_");
4152       return; %skip (2);
4153 free_buffer: entry;
4154       if (b.cur.sn = 1) & (b.cur.ast = 5) /* free up old 1K buffer           */
4155       then do;
4156          substr (dbase.inuse_1K, b.cur.pn, 1) = "0"b;
4157          seg_1K (b.cur.pn) = low (buf_max (5));
4158          if db_ted
4159          then call ioa_$ioa_switch (db_output, "inuse_1K=^b ^i=0", dbase.inuse_1K, b.cur.pn);
4160       end;
4161       else if (b.cur.sn = 1) & (b.cur.ast = 4) /* free up old 4K buffer    */
4162       then do;
4163          substr (dbase.inuse_4K, b.cur.pn, 1) = "0"b;
4164          seg_4K (b.cur.pn) = low (buf_max (4));
4165          if db_ted
4166          then call ioa_$ioa_switch (db_output, "inuse_4K=^b ^i=0", dbase.inuse_4K, b.cur.pn);
4167       end;
4168       else if (b.cur.sn = 2) & (b.cur.ast = 3) /* free up old 16K buffer   */
4169       then do;
4170          substr (dbase.inuse_16K, b.cur.pn, 1) = "0"b;
4171          seg_16K (b.cur.pn) = low (buf_max (3));
4172          if db_ted
4173          then call ioa_$ioa_switch (db_output, "inuse_16K=^b ^i=0", dbase.inuse_16K, b.cur.pn);
4174       end;
4175       else if (b.cur.sn > 2)
4176       then call tedfree_segment_ (dbase_p, b.cur.sn);
4177       return;
4178 
4179 dcl i               fixed bin (21);
4180 dcl len             fixed bin (21);
4181 
4182 
4183 dcl buf_size        (0:5) char (6) var int static options (constant)
4184                     init ("0", "255", "64", "16", "4", "1");
4185 dcl 1 seg__         based (dbase.seg_p (1)),
4186       2 seg_1K      (16),
4187         3 xxx       char (4096),        /* 1K words                          */
4188       2 seg_4K      (12),
4189         3 xxx       char (16384);       /* 4K words                          */
4190 dcl 1 seg_16K       (4) based (dbase.seg_p (2)),
4191       2 xxx         char (66536);       /* 16K words                         */
4192 
4193    end promote;
4194 dcl buf_max         (0:5) fixed bin (21) int static options (constant)
4195                     init (0, 1044480, 0262144, 0065536, 0016384, 0004096);
4196 /****                     0        1        2        3        4        5     */ %page;
4197 make_consistent: proc;
4198 
4199 dcl (
4200 /****are            fixed bin (21),     /*  right string offset              */
4201     ale             fixed bin (21)      /*  left string offset               */
4202     )               parm;
4203 
4204 
4205       if db_ted
4206       then call ioa_$ioa_switch (db_output, "make_consistent b(^a) ^i", b.name, b.state_b);
4207       goto rtn (b.state_b);             /* go finish what was interrupted    */
4208 
4209 clean__up:
4210 rtn (-2): b.state_b = -2;               /* clean up the temporaries          */
4211       b.newb = tedcommon_$no_data;
4212       b.state_b = 0;
4213       return;
4214 
4215 
4216 rtn (-1):                               /* in the middle of tedget_buffer_   */
4217       b.b_ = b.newb;
4218       b.a_ = b.temp;
4219       goto clean__up;
4220 
4221 rtn (0):
4222       return;                           /* nothing interrupted               */
4223 
4224 /* Notes on how to sequence the lines
4225 rtn (x):     b.state_b = x;
4226    setq jaf 0
4227    setq jaf (+ jaf 1)
4228    insert-string (decimal-rep jaf)
4229 */ %page;
4230 relocate: entry;
4231       if (b.old.re ^= 0)                /* if there is an "old" location...  */
4232       then do;                          /*   ...then must relocate           */
4233 
4234 /****     b.old.(l r)e        is where the old data was                      */
4235 /****     b.new.(l r)e        is where it now is                             */
4236 /**** All references within the old range are updated to to the new range    */
4237 /**** If b.terminate then clean up a ^read segment.                          */
4238 
4239          b.N1 = reloc_first;            /* init the reloc loop index         */
4240          b.N3 = b.new.le - b.old.le;    /* calc the adjustment needed        */
4241 next:
4242 rtn (1): b.state_b = 1;
4243          b.N2 = b.N1 + 1;               /* increment this index (safely)     */
4244          if (b.N2 <= reloc_last)        /* still more to process?            */
4245          then do;
4246 rtn (2):    b.state_b = 2;
4247             b.N1 = b.N2;                /* update the loop index             */
4248 rtn (3):    b.state_b = 3;
4249             if adjust (buf_des (b.N1), bd_name (b.N1))
4250             then goto next;
4251 rtn (4):    b.state_b = 4;
4252             buf_des (b.N1) = b.rel_temp;
4253             goto next;
4254          end;
4255 rtn (5): b.state_b = 5;
4256          if (b.stackl ^= ""b)
4257          then do;
4258             b.stack_o = b.stackl;
4259 rel_svex:
4260 rtn (6):    b.state_b = 6;
4261             if adjust (ptr (dbase.seg_p (3), b.stack_o) -> sv.ex, "so.ex")
4262             then goto no_svex;
4263 rtn (7):    b.state_b = 7;
4264             ptr (dbase.seg_p (3), b.stack_o) -> sv.ex = b.rel_temp;
4265 no_svex:
4266 rtn (8):    b.state_b = 8;
4267             if adjust (ptr (dbase.seg_p (3), b.stack_o) -> sv.a0, "so.a0")
4268             then goto no_sva0;
4269 rtn (9):    b.state_b = 9;
4270             ptr (dbase.seg_p (3), b.stack_o) -> sv.a0 = b.rel_temp;
4271 no_sva0:
4272 rtn (10):   b.state_b = 10;
4273             b.stack_o = ptr (dbase.seg_p (3), b.stack_o) -> sv.stackl;
4274 rtn (11):   b.state_b = 11;
4275             if (b.stack_o ^= ""b)
4276             then goto rel_svex;
4277          end;
4278 rtn (12): b.state_b = 12;
4279          b.rel_temp = tedcommon_$no_data;
4280          if b.pseudo                    /* if read-only data or ^read file   */
4281          then do;
4282             if b.terminate
4283             then do;
4284 rtn (13):      b.state_b = 13;
4285                dbase_p = ptr (bp, 0);   /* manufacture -> database           */
4286                call hcs_$terminate_noname (b.cur.sp, 0); /* ignore code */
4287                dbase.not_read_ct = max (0, dbase.not_read_ct - 1);
4288                b.terminate = "0"b;
4289                b.initiate = "0"b;
4290             end;
4291          end;
4292       end;
4293 update: entry;
4294       if (b.cur.ast ^= b.pend.ast)      /* are we changing segments with...  */
4295            & (b.cur.sn ^= b.pend.sn)
4296       then do;                          /*   ...this action?                 */
4297 /**** free up old 4/16K buffer if there was one                              */
4298 /**** set new value for b.maxl                                               */
4299 /**** b.pend --> b.cur                                                       */
4300 rtn (14): b.state_b = 14;
4301          if ^b.pseudo
4302          then call free_buffer;
4303       end;
4304       b.pseudo = ""b;
4305 rtn (15): b.state_b = 15;
4306       b.maxl = buf_max (b.pend.ast);
4307       b.cur = b.pend;
4308       b.b_ = b.newb;
4309       goto clean__up; %skip (2);
4310 new_cur: entry;                         /* used by tedpseudo_                */
4311 rtn (16): b.state_b = 16;
4312       b.maxl = b.newb.l.re;
4313       b.cur = b.pend;
4314       b.b_ = b.newb;
4315       b.ex = b.newb;
4316       goto clean__up;
4317 adjust: proc (what, which) returns (bit (1));
4318 dcl 1 what          like buf_des,
4319     which           char (*);
4320 
4321       b.rel_temp = what;                /* begin a new buf_des               */
4322       if (unspec (b.rel_temp) = unspec (tedcommon_$no_data))
4323       then return ("1"b);
4324 
4325       if (b.test.le <= b.rel_temp.l.le)
4326            & (b.rel_temp.l.le <= b.test.re)
4327       then b.rel_temp.l.le = b.rel_temp.l.le + b.N3;
4328 
4329       if (b.test.le <= b.rel_temp.l.re)
4330            & (b.rel_temp.l.re <= b.test.re)
4331       then b.rel_temp.l.re = b.rel_temp.l.re + b.N3;
4332 
4333       if (b.test.le <= b.rel_temp.r.le)
4334            & (b.rel_temp.r.le <= b.test.re)
4335       then b.rel_temp.r.le = b.rel_temp.r.le + b.N3;
4336 
4337       if (b.test.le <= b.rel_temp.r.re)
4338            & (b.rel_temp.r.re <= b.test.re)
4339       then b.rel_temp.r.re = b.rel_temp.r.re + b.N3;
4340 
4341       if (unspec (buf_des (b.N1)) = unspec (b.rel_temp))
4342       then return ("1"b);
4343 
4344       if db_ted
4345       then call tedshow_ (bp, which, "rt");
4346       return ("0"b);
4347 
4348    end adjust;
4349 dcl bd_name         (13) char (2) int static init (
4350                     "b_", "nb", "ex", "a0", "a1", "a2", "cd", "gb", "na",
4351                     "rt", "t0", "t1", "t2");
4352 demote: entry (ale);
4353 
4354       if (b.cur.sn = 0)                 /* if buffer already empty..         */
4355       then return;                      /* ..don't need to do anything.      */
4356       if b.pseudo                       /* if read-only data or ^read file   */
4357       then do;
4358          if b.terminate
4359          then do;
4360 rtn (17):   b.state_b = 17;
4361             call hcs_$terminate_noname (b.cur.sp, 0); /* ignore code */
4362             dbase.not_read_ct = max (0, dbase.not_read_ct - 1);
4363             b.terminate = "0"b;
4364             b.initiate = "0"b;
4365          end;
4366       end;
4367       else do;
4368 rtn (18): b.state_b = 18;
4369          call free_buffer;
4370       end;
4371 rtn (19): b.state_b = 19;
4372       b.pseudo = ""b;
4373       b.uid = ""b;
4374       b.maxl, b.maxln = 0;
4375       b.cur = tedcommon_$no_seg;
4376       b.b_ = tedcommon_$no_data;
4377       b.a_ (0) = tedcommon_$no_data;
4378       goto clean__up;
4379 
4380 
4381 new_dot: entry;
4382 
4383 rtn (20): b.state_b = 20;
4384       b.a_ (0) = b.newa;
4385       b.newa = tedcommon_$no_data;
4386       goto clean__up;
4387 
4388    end make_consistent; %page;
4389 /**** This routine isolates the line boundaries of the last byte used and    */
4390 /****  makes these be the current location.                                  */
4391 
4392 iso_line: proc;                         /* isolate the line defined by       */
4393                                         /*    b.a_.r.le (2)                  */
4394 
4395 dcl (sb, se)        fixed bin (21);
4396 
4397       se = b.a_.r.le (2);               /* Take the end of range value.      */
4398       if (se = b.b_.l.re + 1)           /* value just after lower part       */
4399            | (se = b.b_.l.le - 1)       /* ..or lower part empty             */
4400       then se = b.b_.r.le;              /* ..move to upper.                  */
4401       if (se = b.b_.r.le - 1)           /* value just before upper part      */
4402 /****    | (se = b.b_.r.re + 1)         /* ..or upper part empty             */
4403       then se = b.b_.l.re;              /* ..move to lower.                  */
4404       b.a_.r.le (2) = se;               /* Take the end of range value.      */
4405       if db_ted
4406       then do;
4407          call tedshow_ (bp, "> iso a2 b_");
4408          call ioa_$ioa_switch (db_output, " iso: se=^i ", se);
4409       end;
4410       if (b.b_.l.re >= b.b_.l.le)       /* is there a lower part?            */
4411       then do;
4412          if (b_c (b.b_.l.re) ^= NL)     /* does lower part not end in NL...  */
4413               & (b.b_.r.re >= b.b_.r.le)/* ..and is there an upper part?     */
4414          then do;
4415 /**** The hole gets moved to a line boundary. Data is moved upward.          */
4416 /****  N.B.: A file which does not end with NL could be all in lower part.   */
4417 /****        such as after doing "$($)d"                                     */
4418             i = index (reverse (
4419                  substr (b_s, b.b_.l.le, b.b_.l.re - b.b_.l.le + 1)), NL);
4420             if (i = 0)
4421             then b.a_.l.re (1) = b.b_.l.le;
4422             else b.a_.l.re (1) = b.b_.l.re - i + 2; /* adjust to just after  */
4423                                         /* ..the NL                          */
4424             call openup;
4425             se = b.a_.r.le (2);         /* reclaim working location          */
4426          end;
4427       end;
4428       b.newa.l.re, b.newa.r.le = se;
4429       b.newa.l.ln, b.newa.r.ln = b.a_.r.ln (2);
4430       if (se < b.b_.l.le) | (b.b_.r.re < se)
4431            | (b.b_.l.re < se) & (se < b.b_.r.le)
4432       then do;                          /* If not within buffer limits..     */
4433          b.newa.l.re = b.b_.l.le;       /* ..set it undefined                */
4434          b.newa.r.le = addr_undef;
4435       end;
4436 
4437       sb = b.newa.l.re;                 /* set tentative limits              */
4438       se = b.newa.r.le;
4439       if (se ^= addr_undef)
4440       then do;
4441          if (b_c (se) ^= NL)            /* If string-end not on a NL..       */
4442          then do;                       /* ..get it there (if possible).     */
4443             i = b.b_.l.re;
4444             if (se > i)
4445             then i = b.b_.r.re;
4446             j = index (substr (b_s, se, i - se + 1), NL);
4447             if (j = 0)                  /* no NL found                       */
4448             then if (b.b_.r.re >= b.b_.r.le) /* set to EOB                   */
4449                  then se = b.b_.r.re;   /* (upper part exists)               */
4450                  else se = b.b_.l.re;   /* (no upper part)                   */
4451             else se = se - 1 + j;       /* otherwise set to that NL          */
4452          end;
4453          i = b.b_.l.le;                 /* start at lower part               */
4454          if (sb > b.b_.l.re)            /* If point is in upper part..       */
4455          then i = b.b_.r.le;            /* ..shift up there.                 */
4456          if (sb > i)
4457          then if (b_c (sb - 1) ^= NL)   /* If not at BOL, get there          */
4458               then do;
4459                  j = index (reverse (substr (b_s, i, sb - i)), NL);
4460                  if (j = 0)
4461                  then sb = i;
4462                  else sb = sb - j + 1;
4463               end;
4464       end;
4465       b.newa.l.le = sb;
4466       b.newa.r.re = se;
4467       call new_dot;
4468       if db_ted
4469       then call tedshow_ (bp, "< a0");
4470 
4471       return;
4472 
4473    end iso_line; %page;
4474 default$line_eval: proc;
4475       who = "le-"; bias = 1; extend = "0"b; cur_line = "1"b; goto work;
4476 
4477 default$cur_line_extend: entry;
4478       who = "cle"; bias = 0; extend = "1"b; cur_line = "1"b; goto work;
4479 
4480 default$cur_line: entry;
4481       who = "cl-"; bias = 0; extend = "0"b; cur_line = "1"b; goto work;
4482 
4483 default$whole_buffer: entry;
4484       who = "wb-"; bias = 0; extend = "0"b; cur_line = ""b;
4485 
4486 work:
4487       if ^b.present (1)                 /* if no addresses provided          */
4488       then do;
4489          if cur_line
4490          then b.a_ (1), b.a_ (2) = b.a_ (0);
4491          else do;
4492             b.a_.l.ln (1) = 1;
4493             b.a_.r.ln (2) = b.b_.r.ln;
4494             if (b.b_.l.le > b.b_.l.re)  /* lower part empty                  */
4495             then b.a_.l.le (1), b.a_.l.re (1) = b.b_.r.le;
4496             else b.a_.l.le (1), b.a_.l.re (1) = b.b_.l.le;
4497             if (b.b_.r.re < b.b_.r.le)
4498             then b.a_.r.le (2), b.a_.r.re (2) = b.b_.l.re;
4499             else b.a_.r.le (2), b.a_.r.re (2) = b.b_.r.re;
4500          end;
4501       end;
4502       else if ^b.present (2)            /* if only one addr,                 */
4503       then do;                          /*  make second addr same as first   */
4504          b.a_ (2) = b.a_ (1);
4505       end;
4506       if db_addr
4507       then call tedshow_ (bp, ".", who, "adr");
4508       if (b.cur.sn = 0)
4509       then do;
4510          msg = "Abe) Buffer empty.";
4511          goto print_error;
4512       end;
4513       if (b.a_.r.re (2) = addr_undef)
4514       then do;
4515          msg = "A.u) ""."" undefined.";
4516          goto print_error;
4517       end;
4518       if (b.a_.l.le (1) = 0)
4519       then do;
4520          msg = "Abb) Addr- before buffer.";
4521          goto print_error;
4522       end;
4523       if (b.a_.l.le (1) > b.b_.r.re) | ^extend & (b.a_.r.le (2) > b.b_.r.re)
4524       then do;
4525          msg = "Aab) Addr- after buffer.";
4526          goto print_error;
4527       end;
4528       if (b.a_.l.re (1) > b.a_.r.le (2) + bias)
4529       then do;
4530          msg = "Awa) Addr- wrap-around.";
4531          goto print_error;
4532       end;
4533       return;
4534 
4535 dcl cur_line        bit (1);
4536 dcl bias            fixed bin;
4537 dcl extend          bit (1);
4538 dcl who             char (3);
4539 
4540    end default$line_eval; %page;
4541 %include tedgvd;
4542 dcl gv_work         char (2048);        /* memory for compilation result     */
4543 %skip (3);
4544 gv_msg_com:
4545       if (vgch ^= "")
4546       then do;
4547          req_str = req_str || "(sub-request ";
4548          req_str = req_str || vgds;
4549          req_str = req_str || ")";
4550       end;
4551       if (rl_c (rl_i) = NL)
4552       then rl_i = rl_i - 1;
4553       if (rl_i < rl_b)
4554       then rl_b = rl_i + 1;
4555       goto add_request; %skip (2);
4556 end_cf: proc;
4557 
4558       if (cf.op ^= -255)
4559       then do;
4560          gvx.tot_len = gvx.tot_len + cf.siz;
4561          if db_gv | db_srch
4562          then do;
4563             call tedshow_ (comptr, "cf");
4564          end;
4565       end;
4566 start_cf: entry;
4567       gvx.ic = gvx.tot_len + 1;
4568       cfp = addr (gvx.word (gvx.ic));
4569       cf.op = -255;
4570       cf.len = 0;
4571       cf.siz = 5;
4572 
4573    end end_cf;
4574 init_cfp: proc (area_p, space);
4575 
4576 dcl area_p          ptr,                /* base of area being setup          */
4577     space           char (*);           /* place for data to go              */
4578 
4579       if (area_p = null ())
4580       then do;
4581          area_p, comptr = addr (space);
4582          gvx.max_len = size (space) - 5;
4583          gvx.tot_len, gvx.srch_len = 0;
4584       end;
4585       comptr = area_p;
4586       gvx.ic = 1;
4587       cfp = addr (gvx.word (1));
4588       if db_gv | db_srch
4589       then call ioa_$ioa_switch (db_output, "cfp=^p", cfp);
4590 
4591    end init_cfp; %page;
4592 /****                                           00000000011111111112222      */
4593 /****                                           12345678901234567890123      */
4594 dcl op_mnem         char (22) int static init ("(pPKMkmsd=tTlLuU{aci >");
4595 
4596 gv_compile: proc;                       /* compile a g* request              */
4597       call init_cfp (gvx_p, gv_work);
4598 tedgv_: begin;
4599 dcl it              fixed bin (21);
4600 dcl (n1_sw, n2_sw)  bit (1);
4601 dcl i               fixed bin (21);
4602 dcl ch              char (1);
4603 dcl n1              fixed bin (21);
4604 dcl n2              fixed bin (21);
4605 dcl adr_sw          bit (1);
4606 
4607          code = 0;
4608          rl_b = rl_i - 2;
4609          req_ch = rl_c (rl_b);
4610          vgch, vgds = "";
4611          NLlast = gvx.printing;
4612          if (substr (rl_s, rl_i, 2) = "==")
4613          then do;                       /* wants to re-use it all            */
4614             rl_i = rl_l;
4615             goto get_ready;
4616          end;
4617          else if (substr (rl_s, rl_i, 2) = "//")
4618          then do;                       /* wants to re-use search            */
4619             if (substr (rl_s, rl_i + 2, 1) ^= " ")
4620             then do;                    /* But, he must give something to do */
4621                msg = "Xse) Bad syntax for ";
4622                goto gv_msg_com;
4623             end;
4624             if (gvx.tot_len = 0)        /* There must also be something      */
4625             then do;                    /*  remembered.                      */
4626                rl_i = rl_l;             /* (will give the error at           */
4627                return;                  /*  execution time)                  */
4628             end;
4629             gvx.tot_len = gvx.srch_len;
4630             call start_cf;
4631                                         /* going to re-use search part       */
4632             rl_i = rl_i + 3;
4633          end;
4634          else do;                       /* completely new request            */
4635             gvx.tot_len,
4636                  gvx.srch_len = 0;      /* wipe out the remembered stuff     */
4637             cf.op = -255;
4638             cf.len = 0;
4639             cf.siz = 5;
4640             call ted_gv_p_;
4641             gvx.srch_len = gvx.tot_len;
4642          end;
4643          if (rl_i >= rl_l)
4644          then do;
4645             msg = "Gne) No execution part for";
4646             rl_i = rl_l - 1;
4647             goto gv_msg_com;
4648          end; %page;
4649 /*                 . . . INSTRUCTION COMPILATION LOOP . . .                  */
4650 /*                               for g* / v*                                 */
4651 
4652          gvx.printing = ""b;
4653          gvx.mk_list = 0;
4654          do while (rl_i < rl_l);
4655             vgch, vgds = rl_c (rl_i);
4656             if ^caps
4657             then if (vgch >= "A") & (vgch <= "Z")
4658                  then goto inv_req;
4659             if (vgch = "!")
4660             then do;
4661                vgds = vgds || rl_c (rl_i + 1);
4662                it = index ("pkmtlu", rl_c (rl_i + 1));
4663                if (it = 0)
4664                then goto inv_req;
4665                rl_i = rl_i + 1;
4666                                         /* make char UPPER CASE              */
4667                unspec (vgch) = unspec (rl_c (rl_i)) & "111011111"b;
4668             end;
4669             it = index (op_mnem, vgch);
4670             if (it = 0)
4671             then do;
4672                if vgch = """"           /* allow a comment on the end        */
4673                then do;
4674                   rl_i = rl_l;
4675                   goto compiled;
4676                end;
4677 inv_req:
4678                msg = "Grq) Unknown sub-request for";
4679                vgch = "";
4680                goto gv_msg_com;
4681             end;
4682             rl_i = rl_i + 1;
4683 re_com:
4684 /**** Need to continually check for gvx overflow!!                           */
4685 
4686             if (gvx.max_len < gvx.tot_len)
4687             then do;
4688             end;
4689             call end_cf;
4690             cf.op = it;
4691             goto com (it); %page;
4692 com (06):                               /* k - kopy                          */
4693 com (07):                               /* m - move                          */
4694             cfmk.link = gvx.mk_list;    /* buffer needs to be cleaned out    */
4695             gvx.mk_list = gvx.tot_len + 1; /* ..before execution begins      */
4696 
4697 com (04):                               /* K - kopyappend                    */
4698 com (05):                               /* M - moveappend                    */
4699             used = rl_l - rl_i + 1;
4700             call tedget_buffer_ (dbase_p, addr (rl_c (rl_i)), used, tbp, msg);
4701             rl_i = rl_i + used;
4702             if (tbp = null ())
4703             then goto rq_err_msg;
4704             if tbp -> b.present (1)
4705             then do;
4706                msg = "Gma) No addrs allowed on destination.";
4707                goto gv_msg_com;
4708             end;
4709             cfmk.cb_r = rel (tbp);
4710             cfmk.siz = size (cfmk);
4711             goto comdone; %skip (3);
4712 com (08):                               /* s -  substitute                   */
4713 com (15):                               /* u - lowercase translate           */
4714 com (16):                               /* U - uppercase translate           */
4715             call scan;
4716             cfx.cexpml = 100;           /* DO IT RIGHT!                      */
4717             cfx.cexpl = 0;              /* zero length of remembered regexp  */
4718             call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
4719                  addr (cfx.cexpml), "0"b, (dbase.lit_sw), msg, code);
4720             if (code ^= 0)
4721             then do;
4722                rl_i = expr_b + expr_l;
4723                goto print_error_rc;
4724             end;
4725 
4726             cfx.cexpml = cfx.cexpl + 12;
4727             call add_length ((cfx.cexpml));
4728             if (it = 8)
4729             then do;
4730                cf.siz = size (cf);
4731                call end_cf;
4732                call replace$compile;
4733             end;
4734             cf.siz = size (cf);
4735             goto comdone; %skip (3);
4736 com (13):                               /* l - linefeed to user_output       */
4737 com (14):                               /* L - linefeed to error_output      */
4738             call add_length (1);
4739             cf.da = NL;
4740             cf.siz = size (cf);
4741             goto comdone_NL; %skip (2);
4742 com (11):                               /* t - type to user_output           */
4743 com (12):                               /* T - type to error_output          */
4744             call scan;
4745             call add_length ((expr_l));
4746             cf.da = substr (rl_s, expr_b, expr_l);
4747             cf.siz = size (cf);
4748             goto comdone_NL; %page;
4749 com (01):                               /* ( - byte address                  */
4750             n1, n2 = 0;
4751             n1_sw, n2_sw = "0"b;
4752             adr_sw = "1"b;
4753             do rl_i = rl_i to rl_l;
4754                ch = rl_c (rl_i);
4755                if (ch = ",")            /* means end of 1st addr             */
4756                then do;
4757                   if n1_sw | ^n2_sw
4758                   then do;
4759 misplaced:
4760                      msg = "Gmc) Misplaced ";
4761                      msg = msg || ch;
4762                      msg = msg || ".";
4763                      vgch = "";
4764                      goto gv_msg_com;
4765                   end;
4766                   n1 = n2;
4767                   n1_sw = "1"b;
4768                   n2 = 0;
4769                   n2_sw = "0"b;
4770                end;
4771                else if (ch = "/")       /* expression (NOT YET)              */
4772                then do;
4773                   if n2_sw
4774                   then goto misplaced;
4775                   n2_sw = "1"b;
4776                   goto gv_nosrch;
4777                end;
4778                else if (ch = ")")
4779                then do;
4780                   if ^n2_sw
4781                   then goto misplaced;
4782                   if ^n1_sw
4783                   then n1 = n2;
4784                                         /* if (sign (n1) = sign (n2))        */
4785                                         /* then if (n2 < n1)                 */
4786                                         /* then goto gv_wrap;                */
4787                   rl_i = rl_i + 1;
4788                                         /* if (rl_c (rl_i) = "(")            */
4789                                         /* then goto misplaced;              */
4790                   cfa.ad1 = n1;
4791                   cfa.ad2 = n2;
4792                   cfa.siz = size (cfa);
4793                   goto comdone;
4794                end;
4795                else do;
4796                   n2 = 0;
4797                   if (ch = "$")         /* means END-OF-LINE (where NL is)   */
4798                   then do;
4799                      if n2_sw
4800                      then goto misplaced;
4801                      n2_sw = "1"b;
4802                      if (rl_c (rl_i + 1) = "-")
4803                      then do;
4804                         rl_i = rl_i + 1;
4805                         i = verify (substr (rl_s, rl_i), "-0123456789");
4806                         goto gv_adrnum;
4807                      end;
4808                   end;
4809                   else do;
4810                      i = verify (substr (rl_s, rl_i), "0123456789");
4811 gv_adrnum:
4812                      if (i = 0)         /* EVERYTHING is digits (no request) */
4813                           | (i = 1)     /* no digits                         */
4814                      then do;
4815                         msg = "Gia) Invalid addr char.";
4816                         vgch = "";
4817                         goto gv_msg_com;
4818                      end;
4819                      i = i - 1;
4820                      n2 = fixed (substr (rl_s, rl_i, i));
4821                      rl_i = rl_i + i - 1;
4822                   end;
4823                   n2_sw = "1"b;
4824                end;
4825             end;                        /* control can never get here        */
4826             signal condition (cant_get_here);
4827 dcl cant_get_here   condition; %skip (4);
4828 com (17):                               /* { - evaluation                    */
4829             rl_i = rl_i - 1;
4830             i = index (substr (rl_s, rl_i), "}");
4831             if (i = 0)
4832             then do;
4833                msg = "Gvd) Missing }.";
4834                goto gv_msg_com;
4835             end;
4836             call add_length ((i));
4837             cf.da = substr (rl_s, rl_i, i);
4838             rl_i = rl_i + i;
4839             cf.siz = size (cf);
4840             goto comdone;
4841 com (18):                               /* a - append                        */
4842 com (20):                               /* i - insert                        */
4843 com (19):                               /* c - change                        */
4844             if (rl_c (rl_i) ^= " ")
4845             then goto gv_blank;
4846             i = index (substr (rl_s, rl_i), "\f");
4847             if (i = 0)
4848             then i = index (substr (rl_s, rl_i), "\F");
4849             if (i = 0)
4850             then do;
4851                msg = "Gei) Missing \F.";
4852                goto gv_msg_com;
4853             end;
4854             i = i - 2;
4855             call add_length ((i));
4856             cf.da = substr (rl_s, rl_i + 1, i);
4857             rl_i = rl_i + i + 3;
4858             cf.siz = size (cf);
4859             goto comdone;
4860 com (22):                               /* > */
4861             if (rl_c (rl_i) = "(")
4862             then do;
4863                i = index (substr (rl_s, rl_i), ")");
4864                if (i = 0)
4865                then do;
4866                   msg = "Ggo) Missing ).";
4867                   goto gv_msg_com;
4868                end;
4869             end;
4870             else if (rl_c (rl_i) = "-") | (rl_c (rl_i) = "+")
4871             then i = 2;
4872             else i = 1;
4873             call add_length ((i));
4874             cf.da = substr (rl_s, rl_i, i);
4875             rl_i = rl_i + i;
4876             cf.siz = size (cf);
4877             goto comdone;
4878 com (21):                               /* SP                                */
4879             cf.op = -255;
4880             goto comdone;
4881 com (10):                               /* = - linenumber                    */
4882 com (03):                               /* P - print w/ linenumber           */
4883 com (02):                               /* p - print                         */
4884             cf.siz = size (cf);
4885 comdone_NL:
4886             gvx.printing = "1"b;
4887 com (09):                               /* d - delete                        */
4888 comdone:
4889             call end_cf;
4890          end;
4891 compiled:
4892          cf.op, cf.len = 0;
4893          cf.siz = 3;
4894          call end_cf;
4895 get_ready: begin;
4896 dcl tbp             ptr;
4897 
4898             tbp = bp;
4899             i = gvx.mk_list;            /* clean out all m/k buffers         */
4900             do cfp = addr (gvx.word (i))
4901                  repeat (addr (gvx.word (i))) while (i > 0);
4902                bp = ptr (dbase_p, cfmk.cb_r);
4903                call delete$all;         /* iso_line ^needed                  */
4904                i = cfmk.link;
4905             end;
4906             bp = tbp;
4907          end;
4908          return;
4909 
4910 gv_1addr:
4911          msg = "G1a) Only 1 addr allowed.";
4912          goto gv_msg_com;
4913 gv_wrap:
4914          msg = "Gwa) Addr wrap-around.";
4915          goto gv_msg_com;
4916 gv_nosrch:
4917          msg = "Gxx) Search addr not supported.";
4918          goto gv_msg_com;
4919 gv_blank:
4920          msg = "Gnb) No blank after ";
4921          goto gv_msg_com;
4922 no_2nd_delim:
4923          msg = "Gd2) No 2nd delimiter.";
4924          rl_i = rl_i - 1;
4925          goto gv_msg_com; %page;
4926 /* . . . PARSE . . . */
4927 
4928 
4929 %include ted_gv_p_;
4930 %include ted_gv_t_;
4931 
4932 dcl tbp             ptr;
4933 /****dcl req_ch     char (1);                                                */
4934 
4935 add_length: proc (incr);
4936 
4937 dcl incr            fixed bin (21);
4938 
4939       cf.len = cf.len + incr;
4940       if (gvx.max_len < gvx.tot_len + divide (cf.len + 3, 4, 24, 0))
4941       then do;
4942          msg = "Gxx) Global statement too long.";
4943          goto add_request;
4944       end;
4945 
4946    end add_length;
4947       end tedgv_;
4948 
4949 
4950 dcl gme2            fixed bin (21);
4951 
4952 
4953 gv_dump: entry;
4954       call tedshow_ (comptr, "gvx");
4955       return;
4956 
4957 
4958 gv_srch: entry;
4959 
4960 dcl 1 gb            like b based (gbp);
4961 dcl g_s             char (gb.b_.r.re) based (gb.cur.sp);
4962 dcl g_c             (gb.b_.r.re) char (1) based (gb.cur.sp);
4963 
4964 dcl gsb             fixed bin (21) defined (gb.a_.l.re (1));
4965 dcl gse             fixed bin (21) defined (gb.a_.r.le (2));
4966 
4967 common:
4968       call init_cfp (gvx_p, gv_work);
4969       if (gvx.tot_len = 0)
4970       then do;
4971          msg = "Gcu) No prior execution of";
4972          goto add_request;
4973       end;
4974       NLlast = gvx.printing & gvNL;
4975       if (db_gv & (b.a_.l.re (1) = 1))
4976       then call tedshow_ (comptr, "gvx");
4977 
4978 dcl last_op         fixed bin;
4979 dcl adr_sw          bit (1);
4980       last_op = 0;
4981       gvx.ic = 1;
4982       b.present (1), b.present (2) = "1"b;
4983       do while ("1"b);
4984          cfp = addr (gvx.word (gvx.ic));
4985          if (last_op ^= adr_op)
4986          then do;
4987             gsb = 1;
4988             gse = 0;
4989             adr_sw = "1"b;
4990          end;
4991          if fix_addr (gsb) & fix_addr (gse)
4992          then do;
4993             if (gsb > gse)              /* can't wrap-around, either         */
4994             then adr_sw = ""b;
4995          end;
4996          else adr_sw = ""b;
4997          if ^adr_sw                     /* address does not exist,           */
4998          then gse = 0;                  /* ..skip next operation             */
4999 
5000          last_op = cf.op;
5001          if db_gv then do;
5002             call tedshow_ (comptr, "cf");
5003             call ioa_$ioa_switch (db_output, "sw=^b ^i:^i", adr_sw, gsb, gse);
5004          end;
5005 (subscriptrange): goto srch (cf.op);
5006 
5007 srch (01):                              /* ( address processing              */
5008          gsb = cfa.ad1;
5009          gse = cfa.ad2;
5010          adr_sw = "1"b;
5011          goto srchdone_inc;
5012 
5013 srch (-5):                              /* evaluation test                   */
5014          call tedeval_ (dbase_p, addr (cft.da), (cft.len), bp, null (), 0,
5015               result, msg, code);
5016          if (code ^= 0)
5017          then goto print_error;
5018          if (result = "0") | (result = "false")
5019          then gvx.ic = cft.f;
5020          else gvx.ic = cft.t;
5021          goto testdone;
5022 
5023 srch (-6):                              /* search test                       */
5024          call tedsrch_$search (addr (cft.cexpml), bp, b.a_.l.le (1),
5025               b.a_.r.re (2), b.a_.l.re (1), b.a_.r.le (2), gme2, msg, code);
5026          if (code = 0)
5027          then gvx.ic = cft.t;
5028          else if (code = 1)
5029          then gvx.ic = cft.f;
5030          else goto print_error;
5031 testdone:
5032          if (gvx.ic = 0)
5033          then return;
5034          goto srchdone; %skip (3);
5035 srch (-7):                              /* test done, was success            */
5036                                         /* let's make the data available     */
5037          cllen = b.a_.r.re (2) - b.a_.l.le (1) + 1;
5038          clloc = b.a_.l.le (1);
5039          call tedpseudo_ (gbp, b.cur.sn, addr (b_c (clloc)), cllen);
5040          gbp -> b.gb.l.ln = b.gb.l.ln;
5041          old_bp = bp;
5042          bp = gbp;
5043          b.a_.l.le (1), b.a_.l.re (1) = b.b_.l.le;
5044          b.a_.r.le (2), b.a_.r.re (2) = b.b_.l.re;
5045          goto srchdone_inc; %skip (3);
5046 fix_addr: proc (val) returns (bit (1)); /* 1-result exists  0-doesn't        */
5047 
5048 dcl val             fixed bin (21);     /* value to be adjusted              */
5049 
5050 dcl tv              fixed bin (21);     /* temp value                        */
5051 
5052       if (val < 1)                      /* this means $ or $-N               */
5053       then do;
5054          val = -val;                    /* (I think better positive)         */
5055                                         /* window never in effect here       */
5056          tv = b.b_.r.re - b.b_.r.le + 1;/* how big upper part?               */
5057          if (val < tv)
5058          then do;
5059             val = b.b_.r.re - val;
5060             return ("1"b);              /* it is:  r.le <= val <= r.re       */
5061          end;
5062          val = val - tv;                /* how much "hangs over"?            */
5063          val = b.b_.l.re - val;         /* go that far in lower part         */
5064          return (val > 0);
5065       end;
5066       if (val <= b.b_.l.re)             /* assumes b.b_.l.le=1 ALWAYS        */
5067       then return ("1"b);               /* it is: l.le <= val <= l.re        */
5068       val = val - b.b_.l.re;            /* how much "hangs over"?            */
5069       val = b.b_.r.le + val - 1;        /* go that far in upper part         */
5070       return (val <= b.b_.r.re);
5071 
5072    end fix_addr; %skip (3);
5073 dcl 1 ln_           int static,
5074       2 dec6        pic "zzzzz9",
5075       2 tab         char (1) init ("    "); %skip;
5076 srch (10):                              /* = - linenumber */
5077          if ^adr_sw
5078          then goto srchdone_inc;
5079          dec6 = b.gb.l.ln;
5080          call iox_$put_chars (iox_$user_output, addr (dec6), 6, 0);
5081          goto srchdone_inc; %skip (4);
5082 srch (03):                              /* P - print w/ linenumber           */
5083          if ^adr_sw
5084          then goto srchdone_inc;
5085          dec6 = b.gb.l.ln;
5086          call iox_$put_chars (iox_$user_output, addr (dec6), 7, 0);
5087 
5088 srch (02):                              /* p - print */
5089          if adr_sw
5090          then call print;
5091          goto srchdone_inc; %skip (4);
5092 /**** M and K (m and k) also are the same. Deleting the destination buffer   */
5093 /****  was done before the request processing began.                         */
5094 srch (04):                              /* K - kopy-append */
5095 srch (05):                              /* M - move-append */
5096 srch (06):                              /* k - kopy */
5097 srch (07):                              /* m - move */
5098          if ^adr_sw
5099          then goto srchdone_inc;
5100          b.cd.l.re = gsb;               /* set source                        */
5101          b.cd.r.le = gse;
5102          tbp = ptr (dbase_p, cfmk.cb_r);
5103          tbp -> b.cd.r.re = tbp -> b.b_.r.re + 1; /* set destination       */
5104          call buffer_buffer_copy (gbp, tbp, "0"b);
5105          if (cf.op = 4) | (cf.op = 6)
5106          then goto srchdone_inc;
5107 
5108 srch (09):                              /* d - delete */
5109          if ^adr_sw
5110          then goto srchdone_inc;
5111          call delete;
5112          call iso_line;
5113          goto srchdone_inc; %skip (4);
5114 /*-*/
5115 srch (19):                              /* c - change */
5116          if ^adr_sw
5117          then goto srchdone_inc;
5118          call delete;
5119          goto aci_com;
5120 srch (18):                              /* a - append */
5121          gsb = gse + 1;
5122 srch (20):                              /* i - insert */
5123          if ^adr_sw
5124          then goto srchdone_inc;
5125          call openup;
5126 aci_com:
5127          call add_2l (""b, addr (cf.da), (cf.len), NLct_check);
5128          goto srchdone_inc; %skip (3);
5129 dcl tp              ptr;
5130 srch (08):                              /* s -  substitute */
5131          tp = addr (cfx.cexpml);
5132          gvx.ic = gvx.ic + cfx.siz;     /* move past the search part         */
5133          cfp = addr (gvx.word (gvx.ic));
5134          if adr_sw
5135          then call substitute (tp);
5136          do while (cf.op < 0);          /* skip any unused "replace" parts   */
5137             gvx.ic = gvx.ic + cfx.siz;
5138             cfp = addr (gvx.word (gvx.ic));
5139          end;
5140          goto srchdone; %skip (3);
5141 srch (15):                              /* u - lowercase translate */
5142          if ^adr_sw
5143          then goto srchdone_inc;
5144          call upper_lower (addr (cfx.cexpml), "0"b);
5145          goto srchdone_inc;
5146 srch (16):                              /* U - uppercase translate */
5147          if ^adr_sw
5148          then goto srchdone_inc;
5149          call upper_lower (addr (cfx.cexpml), "1"b);
5150          goto srchdone_inc; %skip (4);
5151 srch (13):                              /* l - linefeed to user_output */
5152 srch (11):                              /* t - type to user_output */
5153          tbp = iox_$user_output;
5154          goto gv_tT;
5155 
5156 srch (14):                              /* L - linefeed to error_output */
5157 srch (12):                              /* T - type to error_output */
5158          tbp = iox_$error_output;
5159 gv_tT:
5160          if ^adr_sw
5161          then goto srchdone_inc;
5162          call iox_$put_chars (tbp, addr (cf.da), (cf.len), 0);
5163          goto srchdone_inc;
5164 
5165 srch (17):                              /* { - evaluation */
5166          if ^adr_sw
5167          then goto srchdone_inc;
5168          gb.present (1), gb.present (2) = "1"b;
5169 /****               tedeval_ modifies 3rd arg, so (cf.len) is used.          */
5170          call tedeval_ (dbase_p, addr (cf.da), (cf.len), gbp, null (), 0,
5171               result, msg, code);
5172          if (code ^= 0)
5173          then goto print_error;
5174          if (result ^= "")
5175          then call ioa_ ("g* {...} has unexpected result of ""^a"".", result);
5176          goto srchdone_inc; %skip (4);
5177 srch (22):                              /* > -stop global if, goto */
5178          if ^adr_sw
5179          then goto srchdone_inc;
5180          call tedset_ptr_ (dbase_p, cf.da, code);
5181          if (code = 10)
5182          then goto rq_err;              /*  return ("1"b); */
5183          old_bp -> b.gb.l.le, old_bp -> b.gb.l.re
5184               = old_bp -> b.gb.r.re;
5185          old_bp -> b.gb.l.le = old_bp -> b.gb.l.le + 1;
5186                                         /* STOP here                         */
5187          goto srch (0); %skip (3);
5188 dcl (cllen, clloc)  fixed bin (21);
5189 dcl old_bp          ptr;
5190 
5191 srch (21):                              /* \040 - never can happen           */
5192 srch (-1):                              /* literal replacement               */
5193 srch (-2):                              /* & replacement                     */
5194 srch (-3):                              /* x\= replacement                   */
5195 srch (-4):                              /* \g{...} replacement               */
5196          signal condition (should_not_be_here);
5197          goto nx_line;
5198 
5199 srchdone_inc:
5200          gvx.ic = gvx.ic + cf.siz;
5201 srchdone:
5202       end;
5203 srch (00):                              /* end of program                    */
5204       bp = old_bp;
5205       gb.noref = "1"b;
5206       if ^gb.mod_sw
5207       then return;                      /* no change made                    */
5208       llen = gb.b_.l.re - gb.b_.l.le + 1; /* how long is left part           */
5209       rlen = gb.b_.r.re - gb.b_.r.le + 1; /* how long is right part          */
5210       if (rlen + llen ^= cllen)
5211       then goto srch_mod;
5212       if (llen > 0)                     /* is left part different than it    */
5213       then do;                          /* ..was when we started?            */
5214          if substr (b_s, clloc, llen) ^= substr (g_s, gb.b_.l.le, llen)
5215          then goto srch_mod;
5216       end;
5217 dcl (llen, rlen)    fixed bin (21);
5218       if (rlen > 0)                     /* is right part different than it   */
5219       then do;                          /* ..was when we started?            */
5220          if substr (b_s, clloc + llen, rlen) ^= substr (g_s, gb.b_.r.le, rlen)
5221          then goto srch_mod;
5222       end;
5223       return;                           /* no effective change made          */
5224 srch_mod:
5225       b.mod_sw = "1"b;                  /* make sure modification is known   */
5226                                         /* ..(add_2l might not get done)     */
5227       b.a_.l.re (1) = b.a_.l.le (1);
5228       call openup;                      /* insert "post" data                */
5229       if (b.maxln > -1)
5230       then b.maxln = b.maxln - 1;       /* taking a line out                 */
5231       if (llen > 0)
5232       then call add_2l (ted_safe, addr (g_c (gb.b_.l.le)), llen, NLct_check);
5233       if (rlen > 0)
5234       then call add_2l (ted_safe, addr (g_c (gb.b_.r.le)), rlen, NLct_check);
5235       b.b_.r.le = b.b_.r.le + cllen;    /* get rid of "pre" data             */
5236       b.a_.r.le (2) = b.b_.l.re;        /* ..get rid of dangling addr        */
5237       return;
5238    end gv_compile; %page;
5239 /* . . . EXTERNAL ENTRIES . . . */
5240 
5241 dcl (addcharno, addr, addrel, byte, char, codeptr, convert, copy, divide,
5242     fixed, hbound, index, length, lbound, low, ltrim, max, min, null, ptr,
5243     rank, rel, reverse, rtrim, search, size, string, substr, translate,
5244     unspec, verify
5245     )               builtin;
5246 
5247 /**** <<<<----- dcl_tedpromote_.incl.pl1 tedpromote_                         */
5248 tedpromote_:                            /* get a larger data buffer          */
5249    entry (abp, al);
5250 /****dcl (
5251 /****abp            ptr,                /* -> buffer to promote              */
5252 /****al             fixed bin (21)      /* amount not fitting                */
5253 /****)              parm;               /* ----->>>>                         */
5254 
5255       bp = abp;
5256       dbase_p = ptr (bp, 0);
5257       call promote (al);
5258       return;
5259 
5260 /**** <<<<----- dcl_tedcloseup_.incl.pl1 tedcloseup_                         */
5261 tedcloseup_:                            /* move all buffer data to lower     */
5262    entry (abp);
5263 /****dcl (
5264 /****abp            ptr                 /* -> to buffer to convert           */
5265 /****)              parm;               /* ----->>>>                         */
5266 
5267       dbase_p = ptr (abp, 0);
5268       bp = abp;
5269       call promote$seg;
5270       return;
5271 
5272 
5273 /**** <<<<----- dcl_tedpseudo_.incl.pl1 tedpseudo_                           */
5274 tedpseudo_:                             /* make a pseudo (read-only) buffer  */
5275    entry (abp, asn, asp, al);
5276 dcl (
5277     abp             ptr,                /* -> to buffer to convert           */
5278     asn             fixed bin,          /* segno of data (-1 if ^read)       */
5279     asp             ptr,                /* -> the data                       */
5280     al              fixed bin (21)      /* the length of it                  */
5281     )               parm;               /* ----->>>>                         */
5282 
5283       bp = abp;
5284       dbase_p = ptr (bp, 0);
5285       if db_ted
5286       then call ioa_$ioa_switch (db_output, "pseudo b(^a) ^i)^p ^i", b.name, asn, asp, al);
5287       if (b.cur.sn ^= 0)                /* if something here, scrap it       */
5288       then call delete$all;             /* iso_line not needed               */
5289       b.maxln = NLct_unknown;
5290       b.pend.sp = asp;
5291       b.pend.sn = asn;
5292       b.pend.pn, b.pend.ast, b.pend.mbz = 0;
5293       b.newb = tedcommon_$no_data;
5294       b.newb.l.le = 1;
5295       b.newb.l.re, b.newb.r.re = al;
5296       b.newb.r.le = al + 1;             /* upper part is empty               */
5297       b.pseudo = "1"b;
5298       call new_cur;                     /* set new values for bl/br/al/ar    */
5299       if db_ted
5300       then call tedshow_ (bp, "bcb");
5301 
5302       return;                           /* pseudo_buf */ %page;
5303 act: entry;                             /* handle the old form of active     */
5304                                         /*  function accessing.              */
5305 
5306 dcl act_name        char (5) int static init ("(act)");
5307 dcl marker          char (1);
5308 dcl arg_max         fixed bin;
5309 dcl arg_l           fixed bin (21);
5310 
5311       marker = byte (11);               /* VT - not likely in argument data  */
5312 
5313       call tedget_buffer_ (null (), addr (act_name), length (act_name), bp,
5314            msg);
5315       if (bp = null ())
5316       then do;
5317          call ioa_ ("Not in ted");
5318          return;
5319       end;
5320       dbase_p = ptr (bp, 0);
5321       call delete$all;                  /* iso_line not needed               */
5322       call cu_$arg_count (arg_max, code);
5323       j = 1;
5324       do argno = 1 to arg_max;
5325          call cu_$arg_ptr (argno, ttp, arg_l, code);
5326          if (argno ^= 1)                /* place marker between args         */
5327          then call add_2l ("0"b, addr (marker), 1, 0);
5328          call add_2l ("0"b, ttp, arg_l, 0);
5329       end;
5330 
5331       return /* ted_act */; %page;
5332 blank:                                  /* set blank mode                    */
5333    entry;
5334                                         /* +++++ <<>> */
5335       com_blank = "1"b;
5336       com1_blank = "1"b;
5337       return;
5338 
5339 noblank:                                /* set ^blank mode                   */
5340    entry;
5341                                         /* +++++ <<>> */
5342       com_blank = "0"b;
5343       com1_blank = "0"b;
5344       return;
5345 
5346 partblank:                              /* set partblank mode                */
5347    entry;
5348                                         /* +++++ <<>> */
5349       com_blank = "0"b;
5350       com1_blank = "1"b;
5351       return;
5352 
5353 passthru:                               /* disable PI then signal it         */
5354    entry;
5355                                         /* +++++ <<>> */
5356       pi_passthru = "1"b;
5357       signal condition (program_interrupt);
5358       return;
5359 
5360 clear_chars_moved: entry (clear_name);
5361 dcl clear_name      char (*);
5362       cm_val = -1;
5363 dcl cm_val          fixed bin (30) init (0);
5364 
5365 show_chars_moved: entry;
5366 
5367 show_again:
5368       hold_db_output = db_output;
5369       if (db_output = null ())          /* make sure there is a switch for   */
5370       then db_output = iox_$user_output;/* ..debugging output                */
5371       if (chars_moved >= 0)
5372       then do;
5373          char_pic = chars_moved;
5374          call ioa_$ioa_switch (db_output, "^a chars moved", char_pic);
5375          total_chars_moved = total_chars_moved + chars_moved;
5376       end;
5377       chars_moved = cm_val;
5378       if (cm_val = 0)
5379       then return;
5380       if (total_chars_moved >= 0)
5381       then do;
5382          char_pic = total_chars_moved;
5383          call ioa_$ioa_switch (db_output, "^10a^a chars moved", clear_name, char_pic);
5384       end;
5385       chars_moved = -1;
5386       total_chars_moved = 0;
5387       db_output = hold_db_output;       /* put back old value                */
5388       return;
5389 dcl char_pic        pic "zzz,zzz,zzz,zz9";
5390 dcl (chars_moved    init (-1),
5391     total_chars_moved init (0)
5392     )               fixed bin (30) int static;
5393 
5394 lnn: entry; ln_sw = "1"b; return;
5395 lnf: entry; ln_sw = ""b; return;
5396 dcl ln_sw           bit (1) int static init (""b);
5397 
5398 lgn: entry;                             /* turn on long switches             */
5399       dbs = "1"b;
5400       i = 2;
5401       goto set_db;
5402 
5403 lgf: entry;                             /* turn off long switchs             */
5404       dbs = "0"b;
5405       i = 2;
5406       goto set_db;
5407 
5408 dbn: entry;                             /* turn on debugging switches        */
5409 
5410 dcl dbs             bit (1);
5411       dbs = "1"b;
5412       i = 1;
5413       goto set_db;
5414 dbf: entry;                             /* turn off debugging switchs        */
5415       dbs = "0"b;
5416       i = 1;
5417 dcl dim             builtin;
5418 dcl arg             char (arg_l) based (ttp);
5419 set_db:
5420       call cu_$arg_ptr (1, ttp, arg_l, code);
5421       if (code ^= 0)
5422       then dbsw (*, i) = dbs;
5423       else do;
5424          do j = 1 to dim (swname, 1);
5425             if (swname (j) = arg)
5426             then do;
5427                dbsw (j, i) = dbs;
5428                return;
5429             end;
5430          end;
5431          if (arg = "*") | (arg = "**")
5432          then dbsw (*, i) = dbs;
5433          else begin;
5434                                         /* dcl string       builtin;                                                 */
5435                call com_err_ (0, "ted$db", "Valid args: ^a", string (swname));
5436             end;
5437       end;
5438       return;
5439 
5440 dcl 1 db_lg         (12) based (addr (tedcommon_$etc.sws)),
5441       2 dbsw        (2) bit (1) aligned;
5442 dcl swname          (13) char (5) unal int static init (
5443                     "ted  ", "addr ", "eval ", "sort ",
5444                     "gv   ", "util ", "srch ", "glob ",
5445                     "trac ", "Ed   ", "     ", "     ", "catch");
5446 
5447 dcl AZ              char (26) int static init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
5448 dcl BS_C            char (1) int static init ("^Y"); /* \c */
5449 dcl DBA             char (32) var;
5450 dcl HT              char (1) int static init ("   ");
5451 dcl NLct_check      fixed bin (21) int static init (-2);
5452 dcl NLct_unknown    fixed bin (21) int static init (-1);
5453 dcl NLlast          bit (1);
5454 dcl Psw             bit (1);
5455 dcl SP              char (1) int static init (" ");
5456 dcl SP_HT           char (2) int static init ("   "); /* #160*/
5457 dcl addr_undef      fixed bin int static options (constant) init (-1);
5458 dcl af_bp           ptr;
5459 dcl af_value        char (ted_data.return_string_l) var
5460                     based (ted_data.return_string_p);
5461 dcl after_l         fixed bin (21);
5462 dcl alt_sw          bit (1);
5463 dcl app_sw          bit (1);
5464 dcl archive_$get_component entry (ptr, fixed bin (24), char (*), ptr,
5465                     fixed bin (24), fixed bin (35));
5466 dcl argname         char (7);
5467 dcl argno           fixed bin;
5468 dcl az              char (26) int static init ("abcdefghijklmnopqrstuvwxyz");
5469 dcl b0_bp           ptr;
5470 dcl b_depth         fixed bin;          /* depth of buffer remember stack */
5471 dcl b_stack         (10) ptr;           /* buff remember stack (!b request)  */
5472 dcl bc              fixed bin (24);
5473 dcl ch              char (1);
5474 dcl cleanup         condition;
5475 dcl code            fixed bin (35);
5476 dcl concealsw       bit (1);
5477 dcl continue_to_signal_ entry (fixed bin (35));
5478 dcl delim           char (1);
5479 dcl enl             fixed bin (21);
5480 dcl err_req         char (16) var;
5481 dcl error_table_$inconsistent fixed bin (35) ext static;
5482 dcl error_table_$insufficient_access fixed bin (35) ext static;
5483 dcl error_table_$moderr external fixed bin (35);
5484 dcl error_table_$noentry fixed bin (35) ext static;
5485 dcl error_table_$no_component fixed bin (35) ext static;
5486 dcl error_table_$unsupported_operation fixed bin (35) ext static;
5487 dcl error_table_$zero_length_seg fixed bin (35) ext static;
5488 dcl expr_b          fixed bin (21);     /* beginning of expression           */
5489 dcl expr_l          fixed bin (21);     /* length of expression              */
5490 dcl fcbp            ptr;
5491 dcl file_c          (file_l) char (1) based (file_p);
5492 dcl file_l          fixed bin (21);
5493 dcl file_p          ptr;
5494 dcl file_s          char (file_l) based (file_p);
5495 dcl fo_sw           bit (1);
5496 dcl gbp             ptr;                /* -> g* pseudo buffer               */
5497 dcl go_sw           bit (1);
5498 dcl got_quit        bit (1);
5499 dcl gvx_p           ptr;
5500 dcl header_l        fixed bin (21);
5501 dcl hold_de         fixed bin;
5502 dcl i               fixed bin (21);
5503 dcl ii              fixed bin (21);
5504 dcl il              fixed bin (21);
5505 dcl intsw           bit (1);
5506 dcl iocb_ptr        ptr;
5507 dcl j               fixed bin (21);
5508 dcl jb              fixed bin (21);
5509 dcl k               fixed bin (21);
5510 dcl level           fixed bin (35) init (0);
5511 dcl maxseg          fixed bin (21);
5512 dcl me              fixed bin (21);
5513 dcl me2             fixed bin (21);
5514 dcl mi              fixed bin (21);
5515 dcl ml              fixed bin (21);
5516 dcl mrl_            entry (ptr, fixed bin (21), ptr, fixed bin (21));
5517 dcl mustreprotect   bit (1);
5518 dcl not_sw          bit (1);
5519 dcl on_quit         bit (1);
5520 dcl pdname          char (32) int static init (" ");
5521 dcl pi_label        label;
5522 dcl pi_passthru     bit (1) int static;
5523 dcl pi_sw           fixed bin;
5524 dcl program_interrupt condition;
5525 dcl qedx_mode       bit (1);
5526 dcl quit            condition;
5527 dcl req_ch          char (1);
5528 dcl req_chx         char (4) var;
5529 dcl req_not         char (1);
5530 dcl req_str         char (36) var;
5531 dcl result          char (500) var;
5532 dcl save_mod        bit (1);
5533 dcl select          char (16);
5534                                         /**/ dcl should_not_be_here condition;
5535 dcl sort_p          (3) ptr;            /* sorting work/work/output segs     */
5536 dcl sort_sn         (3) fixed bin;      /* sequence #'s of them              */
5537                                         /*dcl str           char (262143) based aligned;                             */
5538 dcl sub_type        char (12) var;
5539 dcl subf1           char (4);
5540 dcl subf2           char (3);
5541 dcl subfile_name    char (32) var;
5542 dcl sub_p           ptr;
5543 dcl subsw           bit (1);
5544 dcl svlen           fixed bin (21);
5545 dcl svpath          char (204);         /* temp storage of pathname          */
5546 dcl sys_info$max_seg_size fixed bin (35) ext static;
5547 dcl tbi             fixed bin;
5548 dcl tbp             ptr;
5549 dcl tc              char (1);
5550 dcl ted_fo_err      condition;
5551 dcl ted_mode        fixed bin;
5552 dcl ted_safe        bit (1) aligned;
5553 dcl tedcleanup_     entry (ptr);
5554 dcl tederror_table_$zero_length_buffer fixed bin (35) ext static;
5555 dcl trustsw         bit (1);
5556 dcl ttp             ptr;
5557 dcl used            fixed bin (21);
5558 dcl vgch            char (1);
5559 dcl vgds            char (2) var;
5560 dcl wct             fixed bin;
5561 dcl which_mode      char (5);
5562 dcl write_l         fixed bin (21);     /* length of file                    */
5563 dcl wsw             bit (1);            /* 0- reading, 1- writing            */
5564 dcl xfe             fixed bin (21);
5565 dcl xfi             fixed bin (21);
5566 dcl xsw             bit (1);
5567 dcl (sbp, dbp)      ptr;
5568 %skip (3);
5569 dcl command_query_  entry () options (variable);
5570 dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*),
5571                     fixed bin (35));
5572 dcl get_group_id_   entry () returns (char (32));
5573 dcl get_pdir_       entry () returns (char (168));
5574 dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24),
5575                     fixed bin (2), ptr, fixed bin (35));
5576 dcl hcs_$make_seg   entry (char (*), char (*), char (*), fixed bin (5), ptr,
5577                     fixed bin (35));
5578 dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin,
5579                     fixed bin (35));
5580 dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
5581 dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
5582 dcl terminate_file_ entry (ptr, fixed bin (21), bit (*), fixed bin (35));
5583 dcl hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin,
5584                     fixed bin (35));
5585 dcl cu_$cp          entry (ptr, fixed bin (21), fixed bin (35));
5586 dcl cu_$arg_count   entry (fixed bin, fixed bin (35));
5587 dcl cu_$arg_list_ptr entry (ptr);
5588 dcl cu_$arg_ptr     entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
5589 dcl ioa_            entry () options (variable);
5590 dcl ioa_$ioa_switch entry () options (variable);
5591 dcl ioa_$nnl        entry () options (variable);
5592 dcl com_err_        entry () options (variable);
5593 dcl NL              char (1) int static init ("
5594 ");
5595 
5596 
5597 dcl 1 seg_acl       aligned,            /* structure for adding one acl      */
5598       2 userid      char (32),
5599       2 access      bit (36),
5600       2 ex_access   bit (36),
5601       2 status      fixed bin (35);
5602 
5603 dcl 1 delete_acl    aligned,            /* structure for deleting one acl    */
5604       2 userid      char (32),
5605       2 status      fixed bin (35);
5606 
5607 dcl 1 fd            like b.file_d;
5608 dcl hold_db_output  ptr;
5609 dcl answer          char (10) var;
5610 
5611 dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*),
5612                     fixed bin (35));
5613 dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr,
5614                     fixed bin (35));
5615 dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1),
5616                     fixed bin (2), fixed bin (24), fixed bin (35));
5617 
5618 dcl iox_$attach_iocb entry (ptr, char (*)) returns (fixed bin (35));
5619 dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
5620 dcl iox_$close      entry (ptr, fixed bin (35));
5621 dcl iox_$control    entry (ptr, char (*), ptr, fixed bin (35));
5622 dcl iox_$detach_iocb entry (ptr, fixed bin (35));
5623 dcl iox_$error_output ptr ext static;
5624 dcl iox_$find_iocb  entry (char (*), ptr, fixed bin (35));
5625 dcl iox_$move_attach entry (ptr, ptr, fixed bin (35));
5626 dcl iox_$open       entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
5627 dcl iox_$put_chars  entry (ptr, ptr, fixed bin (21), fixed bin (35));
5628 dcl iox_$user_output ptr ext static;
5629 dcl string_sw       bit (1) defined (b.present (0));
5630 dcl hold_db_ted     bit (1) aligned;
5631 
5632 dcl 1 CB            (dbase.bufnum) like b based (dbase.cba_p); %page;
5633 
5634 %include ted_;
5635 %include ted_support;
5636 %include tedcommon_;
5637 %include tedbase;
5638 %include tedbcb;
5639 %include tedstk;
5640 %include tederror_;
5641 %include mc;
5642 %include query_info;
5643 %include terminate_file;
5644 %include branch_status;
5645 dcl tedaddr_        entry (             /* process request addresses         */
5646                     ptr,                /* -> database                       */
5647                     ptr,                /* -> string containing address      */
5648                     fixed bin (21),     /*   length of it               [IN] */
5649                                         /* If <0 then recursive call         */
5650                                         /*   how much was used up      [OUT] */
5651                     ptr,                /* -> buffer control block  [IN/OUT] */
5652                     char (168) var,     /* place to hold err message if any  */
5653                     fixed bin (35),     /* status code                       */
5654                                         /*   0- null address                 */
5655                                         /*   1- address found                */
5656                                         /*   8- error, msg tells what        */
5657                     );
5658 
5659 
5660 dcl tedcall_        entry (             /* call a buffer                     */
5661                     ptr,                /* -> database                       */
5662                     fixed bin (35)
5663                     );
5664 
5665 dcl tedcount_lines_ entry (             /* return # lines in string          */
5666                     ptr,                /* -> buffer in which to count       */
5667                     fixed bin (21),     /* where string begins in segment    */
5668                     fixed bin (21),     /* where string ends in segment      */
5669                     fixed bin (21)      /* # lines                     [OUT] */
5670                     );
5671 
5672 
5673 dcl tedcheck_buffer_state_ entry (
5674                     ptr,                /* -> database                       */
5675                     ptr,                /* -> buffer control block           */
5676                     char (168) var      /* error message, if any             */
5677                     );
5678 
5679 
5680 dcl tedcheck_buffers_ entry (           /* check for modified buffers        */
5681                     ptr,                /* -> database                       */
5682                     fixed bin           /* number of modified buffers found  */
5683                     );
5684 
5685 dcl tedcheck_entryname_ entry (char (*), fixed bin (35));
5686 dcl tedend_buffer_  entry (             /* pop buffer recursion 1 level      */
5687                     ptr,                /* -> database                       */
5688                     fixed bin (35)      /* 1- already at level 0, 0- ok      */
5689                     );
5690 
5691 dcl tedeval_        entry (             /* process evaluations               */
5692                     ptr,                /* -> database                       */
5693                     ptr,                /* -> evaluation string              */
5694                     fixed bin (21),     /*   length thereof             [IN] */
5695                                         /*   amount used up            [OUT] */
5696                     ptr,                /* -> buffer control block           */
5697                     ptr,                /* -> matched string in \g{...}      */
5698                                         /*    null otherwise                 */
5699                     fixed bin (21),     /*  length of string in \g{...}      */
5700                                         /* <0 in \{...}, 0 otherwise         */
5701                     char (500) var,     /* output string, if any             */
5702                     char (168) var,     /* error message, if any             */
5703                     fixed bin (35)      /* return code                       */
5704                     );
5705 
5706 
5707 dcl tedfree_segment_ entry (            /* give back a work segment          */
5708                     ptr,                /* -> database                       */
5709                     fixed bin           /* sequence # of segment to free     */
5710                     );
5711 
5712 dcl tedget_existing_buffer_ entry (     /* find a named buffer               */
5713                     ptr,                /* -> database                       */
5714                     ptr,                /* -> string containing buffer name  */
5715                     fixed bin (21),     /*   length of string           [IN] */
5716                                         /*   how much was used         [OUT] */
5717                     ptr,                /* buffer control block (OUT)        */
5718                     char (168) var      /* error message text                */
5719                     );
5720 
5721 dcl tedget_buffer_  entry (             /* find (or create) a buffer         */
5722                     ptr,                /* -> database                       */
5723                     ptr,                /* -> string containing buffer name  */
5724                     fixed bin (21),     /*   length of string           [IN] */
5725                                         /*   how much was used         [OUT] */
5726                     ptr,                /* buffer control block (OUT)        */
5727                     char (168) var      /* error message text                */
5728                     );
5729 
5730 
5731 dcl tedget_segment_ entry (             /* get a segment to work in          */
5732                     ptr,                /* -> database                       */
5733                     ptr,                /* -> gotten segment           [OUT] */
5734                     fixed bin,          /* sequence # of it         [IN/OUT] */
5735                                         /* if >0 upon entry, it will then    */
5736                                         /*  fill that entry in seg_p array   */
5737                                         /* otherwise it will take any one    */
5738                     );
5739 
5740 
5741 dcl tedhold_        entry (ptr);
5742 dcl tedinit_        entry (             /* create a ted environment          */
5743                     ptr,                /* -> ted_ input structure           */
5744                     ptr,                /* -> dbase                    (OUT) */
5745                     fixed bin (35)      /* status code                       */
5746                     );
5747 
5748 dcl tedlist_buffers_ entry (            /* show the status of buffers        */
5749                     ptr,                /* -> database                       */
5750                     char (16),          /* name of buffer to show            */
5751                     bit (1),            /* 0- listing inactive environment   */
5752                                         /* 1- listing active one             */
5753                     bit (1)             /* 1- validate b.maxln               */
5754                     );
5755 
5756 dcl tedpseudo_      entry (             /* make a pseudo (read-only) buffer  */
5757                     ptr,                /* -> to buffer to convert           */
5758                     fixed bin,          /* segno of data (-1 if ^read)       */
5759                     ptr,                /* -> the data                       */
5760                     fixed bin (21)      /* the length of it                  */
5761                     );
5762 
5763 
5764 dcl tedread_ptr_    entry (             /* read a line from input stream     */
5765                     ptr,                /* -> database                       */
5766                     ptr,                /* -> input buffer                   */
5767                     fixed bin (21),     /* last char in use in buffer        */
5768                     fixed bin (21),     /* last char useable in buffer       */
5769                     fixed bin (21),     /* last char filled in buffer  [OUT] */
5770                     char (5)            /* mode in which read is being done  */
5771                     );
5772 
5773 dcl tedresetread_   entry (ptr);
5774 dcl tedset_ck_ptr_  entry (ptr);
5775 dcl tedset_ptr_     entry (             /* find label in local buffer        */
5776                     ptr,                /* -> database                       */
5777                     char (*),           /* label to find                     */
5778                     fixed bin (35)      /* return code                       */
5779                     );
5780 
5781 dcl tedshow_        entry options (variable);
5782 dcl tedshow_$init   entry;
5783 dcl tedsort_        entry (             /* sort in a buffer                  */
5784                     ptr,                /* -> key specifications             */
5785                     fixed bin (21),     /*   length thereof                  */
5786                     ptr,                /* -> string to be sorted            */
5787                     fixed bin (21),     /*   length thereof                  */
5788                     (3) ptr,            /* working segments                  */
5789                                         /*  (1) temp seg                     */
5790                                         /*  (2) temp seg                     */
5791                                         /*  (3) output seg                   */
5792                     fixed bin (21),     /* length of result            [OUT] */
5793                     char (168) var,     /* error details                     */
5794                     fixed bin (35)      /* return code                 [OUT] */
5795                     );
5796 
5797 dcl tedsort_$show   entry (             /* print special collating sequence  */
5798                                         /* no arguments                      */
5799                     );
5800 
5801 dcl tedsort_$set    entry (             /* set special collating sequence    */
5802                     char (*)            /* user's specification              */
5803                     );
5804 
5805 /*dcl tedsort_$compare entry (          /* compare strings w/ spec collate  * /
5806                     ptr,                /* points to seg containin/g strings* /
5807                     ptr,                /* points to R array                * /
5808                     bit (3)             /* the 3 bits represent <=>         * /
5809                     );                                                       */
5810 
5811 dcl gvNL            bit (1);
5812    end ted_;