1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Bull Inc., 1988                *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   6         *                                                         *
   7         * Copyright (c) 1972 by Massachusetts Institute of        *
   8         * Technology and Honeywell Information Systems, Inc.      *
   9         *                                                         *
  10         *********************************************************** */
  11 
  12 
  13 
  14 /****^  HISTORY COMMENTS:
  15   1) change(88-08-03,RWaters), approve(88-08-03,MCR7950), audit(88-09-29,Huen),
  16      install(88-10-07,MR12.2-1146):
  17      Bug fixes for MR12.2.
  18                                                    END HISTORY COMMENTS */
  19 
  20 
  21 /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16            */
  22 /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
  23 /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
  24 /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
  25 
  26 /*                                              _                            */
  27 /*    _|_              |          _|_     o      |                           */
  28 /*     |      _      _ |           |     __      |                           */
  29 /*     |     / \    / \|  |   |    |      |      |                           */
  30 /*     |    (__/   (   |  |   |    |      |      |                           */
  31 /*     \_    \_/    \_/|   \_/|    \_    _|_    _|_                          */
  32 /*                                                    -----                  */
  33 /*                                                                           */
  34 
  35 /* Contains:        tedset_ptr_                                              */
  36 /*                  tedread_ptr_                                             */
  37 /*                  tederror_                                                */
  38 /*                  tedcall_                                                 */
  39 /*                  tedresetread_                                            */
  40 /*                  tedend_buffer_                                           */
  41 /*                  tedcount_lines_                                          */
  42 /*                  tedck_ptr_                                               */
  43 
  44 /* UPDATE HISTORY                                                            */
  45 /* EL#   date       TR        comments                                       */
  46 /* ---              added debug output switch                                */
  47 /* 136 84-10-08 phx16686 don't lose input typed up to \b(not-exist)          */
  48 /* 148 84-10-10 phx17488 "^>+1 r not-there" executes char after the NL       */
  49 /* 156 84-10-17 phx18195 prohibit 1) invoking buffer in INPUT mode           */
  50 /*                                2) modifying buffer being executed.        */
  51 /*                  (Also renamed execute parameters to make things a little */
  52 /*                   easier to read)                                         */
  53 /* 193 88-07-08 phx19382 RW "loc" may be zero & b_c(0) is a subscript error  */
  54 
  55 tedutil_:                               /* just a pretty face                */
  56    proc;
  57       return;
  58 
  59 dcl (tp, new_bp)    ptr,                /* temporary storage                 */
  60     (ti, tti, te, i, j, k, escl, srchl) fixed bin (21);
  61 dcl ii              fixed bin (21);
  62 dcl i21             fixed bin (21);
  63 dcl j24             fixed bin (21);
  64 dcl jj              fixed bin (21);
  65 dcl used            fixed bin (21);
  66 
  67 dcl concealsw       bit (1);
  68 dcl cu_$arg_ptr     entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
  69 dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (21),
  70                     fixed bin (2), ptr, fixed bin (35));
  71 dcl com_err_        entry () options (variable);
  72 dcl ioa_            entry () options (variable);
  73 dcl cu_$af_arg_count entry (fixed bin, fixed bin (35));
  74 dcl cu_$cp          entry (ptr, fixed bin (21), fixed bin (35));
  75 dcl ioa_$nnl        entry () options (variable);
  76 dcl ioa_$ioa_switch entry () options (variable);
  77 dcl hcs_$get_uid_seg entry (ptr, bit (36), fixed bin (35));
  78 
  79 
  80 dcl NL              char (1) int static init ("
  81 ");
  82 
  83 
  84 dcl str             char (262144) based aligned;
  85                                         /* for use w/substr&index functions  */
  86 dcl iox_$get_line   entry (ptr, ptr, fixed bin (21), fixed bin (21),
  87                     fixed bin (35));
  88 dcl iox_$user_input ptr ext static;
  89 dcl iox_$error_output ptr ext static;
  90 dcl iox_$control    entry (ptr, char (*), ptr, fixed bin (35));
  91 
  92 /* dcl 1 DATABASE   based (dbase_p),
  93       2 zzzzzz      like dbase,
  94       2 cb          (DATABASE.bufnum) like b; /* expands to arbitrary size   */
  95 %page;
  96 /**** <<<<----- dcl_tedset_ptr_.incl.pl1 tedset_ptr_                         */
  97 tedset_ptr_:                            /* find label in local buffer        */
  98    entry (adb_p, kharv, kode);
  99 dcl (
 100     adb_p           ptr,                /* -> database                       */
 101     kharv           char (*),           /* label to find                     */
 102     kode            fixed bin (35)      /* return code                       */
 103     )               parm;               /* ----->>>>                         */
 104 
 105 dcl lab             char (20);
 106 dcl labl            fixed bin (21);
 107 
 108       dbase_p = adb_p;
 109       if (kharv = "BREAK")
 110       then do;
 111          kode = 0;
 112          return;
 113       end;
 114       if (dbase.at_break = 2)
 115       then do;
 116          dbase.at_break = 0;
 117          kode = 0;
 118          return;
 119       end;
 120       labl = 2 + length (kharv);
 121       substr (lab, 3) = kharv;
 122       substr (lab, 1, 1) = NL;
 123       substr (lab, 2, 1) = ":";
 124       bp = dbase.stk_info.curp;         /* current buffer control block      */
 125       if ^b.tw_sw
 126       then do;                                                        /* #148*/
 127          if (ex_EOD = ex_last)          /* make whole buffer available       */
 128          then ex_EOD = b.b_.r.re;
 129          ex_last = b.b_.r.re;
 130       end;                                                            /* #148*/
 131       if (substr (lab, 3, 2) = "+0")
 132       then substr (lab, 3, 1) = "-";
 133       if (substr (lab, 3, 1) = NL)      /* >\012 means last char of buffer   */
 134       then do;                          /*  this may or may not be a NL      */
 135          if (ex_last = b.b_.r.re)       /* if end-range is end-buffer        */
 136             & (b.b_.r.re < b.b_.r.le)   /* ..& right part is empty           */
 137          then call set_exec (b.b_.l.re);/* ..set to end of left part         */
 138          else call set_exec (ex_last);  /* ..otherwise use end-range         */
 139          kode = 0;
 140          return;
 141       end;
 142       else if (substr (lab, 3, 1) = "+")
 143       then do;
 144          do i = 2 to index ("123456789", substr (lab, 4, 1));
 145             if (ex_next > ex_EOD)
 146             then j = 0;                                               /* #148*/
 147             else                                                      /* #148*/
 148                j = index (substr (ex_s, ex_next), NL);
 149             if (j = 0)                  /* didn't find it                    */
 150                & (ex_EOD ^= ex_last)    /* ..but range is split, look again  */
 151             then j = index (substr (b_s, b.b_.r.le, ex_last - b.b_.r.le + 1), NL);
 152             if (j = 0)
 153             then goto label_not_found;
 154             call set_exec (ex_next + j);
 155          end;
 156          kode = 0;
 157          return;
 158       end;
 159       else if (substr (lab, 3, 1) = "-")
 160       then do;
 161          jj = b.b_.r.le;                /* reference upper part              */
 162          if (ex_next < jj)              /* if not executing there            */
 163          then jj = 1;                   /* ..then reference lower part       */
 164          do i = index ("0123456789", substr (lab, 4, 1)) to 0 by -1;
 165             j = index (reverse (substr (b_s, jj, ex_next - jj)), NL);
 166             if (j > 0)
 167             then call set_exec (ex_next - j);
 168             else do;
 169                if (i = 0)
 170                then do;
 171                   ex_next = jj;
 172                   kode = 1;
 173                   return;
 174                end;
 175                if (ex_EOD = ex_last)    /* if in upper part                  */
 176                then do;                 /* ..move to lower part              */
 177                   jj = 1;
 178                   call set_exec (b.b_.l.re);
 179                end;
 180                else goto label_not_found;
 181             end;
 182          end;
 183          call set_exec (ex_next + 1);
 184          kode = 0;
 185          return;
 186       end;
 187       else do;
 188          j = 0;
 189          if (labl <= b.b_.l.re)
 190          then do;
 191             if (substr (b_s, 1, labl - 1) = substr (lab, 2, labl - 1))
 192             then do;                    /* label at front of buffer,         */
 193                call set_exec (1);       /*  then set to there.               */
 194                kode = 0;
 195                return;
 196             end;
 197                                         /* find label, (at begin of a line)  */
 198             j = index (substr (b_s, 1, b.b_.l.re), substr (lab, 1, labl));
 199          end;
 200          if (j = 0)
 201          then if (labl <= b.maxl - b.b_.r.le + 1)
 202               then do;
 203                  if (substr (b_s, b.b_.r.le, labl - 1) = substr (lab, 2, labl - 1))
 204                  then do;               /* label at front of part 2,         */
 205                     call set_exec (b.b_.r.le); /*  then set to there.        */
 206                     kode = 0;
 207                     return;
 208                  end;
 209                                         /* find label, (at begin of a line)  */
 210                  j = index (substr (b_s, b.b_.r.le), substr (lab, 1, labl));
 211                  if (j > 0)
 212                  then j = j + b.b_.r.le - 1;
 213               end;
 214       end;
 215       if (j ^= 0)
 216       then do;
 217          call set_exec (j + 1);
 218          kode = 0;
 219          return;
 220       end;
 221       if (kode = 0)
 222       then do;
 223 label_not_found:
 224          msg = "Bgo) ";                 /* :*** not defined in b(***).       */
 225          msg = msg || substr (lab, 2, labl - 1);
 226          msg = msg || " not defined in b(";
 227          msg = msg || substr (b.name, 1, index (char (b.name, 17), " ") - 1);
 228          msg = msg || ").";
 229          call tederror_ (dbase_p, msg);
 230          kode = 10;
 231       end;
 232       return; %skip (4);
 233 /**** Rewrote this routine to try to make things work, then           /* #156*/
 234 /**** found that it couldn't be done.  So other places prohibit       /* #156*/
 235 /**** the attempt entirely.                                           /* #156*/
 236 
 237 init_exec: proc (left, right);                                        /* #156*/
 238 
 239 dcl (left, right)   fixed bin (21);                                   /* #156*/
 240 
 241       if  db_util & lg_util & ^b.tw_sw
 242       then call tedshow_ (bp, "> exI b_ ex");                         /* #156*/
 243       ex_last = right;                                                /* #156*/
 244       ex_lre = min (b.b_.l.re, right);                                /* #156*/
 245       if (left > ex_lre)
 246       then ex_EOD = ex_last;                                          /* #156*/
 247       else ex_EOD = ex_lre;                                           /* #156*/
 248       goto common;                                                    /* #156*/
 249 
 250 set_exec: entry (left);                                               /* #156*/
 251 
 252       if  db_util & lg_util & ^b.tw_sw
 253       then call tedshow_ (bp, "> exS b_ ex");                         /* #156*/
 254 common:
 255       ex_next = left;                                                 /* #156*/
 256       if (ex_next <= b.b_.l.re)         /* if next is in lower part,         */
 257       then ex_EOD =                     /* ..then EOD must be also           */
 258          min (b.b_.l.re, ex_last);      /* ..but only what's available   #156*/
 259       else do;
 260          ex_EOD = ex_last;              /* ..else EOD is up top          #156*/
 261          if (ex_next = b.b_.l.re + 1)   /* if next just dropped out of       */
 262          then ex_next = b.b_.r.le;      /* ..of lower, move up top.      #156*/
 263          if (ex_next < b.b_.r.le)       /* if next is below upper, current   */
 264          then do;                       /* ...is within gap - tsk,tsk    #156*/
 265             signal condition (ex_next_in_gap);
 266 dcl ex_next_in_gap  condition;
 267             ex_next = b.b_.r.le;
 268          end;
 269       end;                                                            /* #148*/
 270       if  db_util & lg_util & ^b.tw_sw
 271       then call tedshow_ (bp, "< ex");                                /* #156*/
 272    end init_exec; %skip (4);
 273 tedwhere_: entry (adb_p);               /* +++ called by ted_eval_           */
 274       dbase_p = adb_p;
 275       bp = dbase.stk_info.curp;
 276       call tedcount_lines_ (b.cur.sp, 1, ex_next - 1, j);
 277       call ioa_ ("b(^a), line ^d, level ^d[^a]", b.name, j,
 278          dbase.stk_info.level, dbase.recurs);
 279       return; %page;
 280 no_input: proc;
 281 
 282 dcl error_table_$end_of_info fixed bin (35) ext static;
 283 dcl error_table_$io_no_permission fixed bin (35) ext static;
 284 dcl timer_manager_$sleep entry (fixed bin (71), bit (2));
 285 
 286       if (code = error_table_$end_of_info)
 287       then ;
 288       else if (code = error_table_$io_no_permission)
 289       then call timer_manager_$sleep (10, "11"b);
 290       else call com_err_ (code, dbase.tedname, "Reading user_input");
 291 
 292    end no_input; %page;
 293 break_input:
 294       if (dbase.at_break = 1)
 295       then do;
 296          if (mode = "INPUT") | (mode = "BREAK")
 297          then goto reloop;
 298 re_break:
 299          call ioa_ ("**BREAK** (level,line,buffer). [Recursion=^i]",
 300             dbase.recurs);
 301          call tedcount_lines_ (bp, 1, ex_next - 1, j);
 302          call ioa_ ("^-^3i ^4i b(^a)", dbase.stk_info.level, j, b.name);
 303          if (dbase.at_break = 2)
 304          then do;
 305             k = index (reverse (substr (b_s, 1, ex_next - 1)), NL);
 306             if (k = 0)
 307             then k = 1;
 308             else k = ex_next - k + 1;
 309 dcl dec6            pic "zzzzz9";
 310             dec6 = j;
 311             msg = dec6 || "   ";
 312             if (k < ex_next)
 313             then do;
 314                msg = msg || substr (b_s, k, ex_next - k + 1);
 315                msg = msg || " ";
 316             end;
 317             msg = msg || "<BREAK>
 318           ";
 319             k = index (substr (b_s, ex_next, 256), NL);
 320             msg = msg || substr (b_s, ex_next, k);
 321             call ioa_ ("^a", (msg));
 322          end;
 323          dbase.at_break = 2;
 324       end;
 325       dbase.err_go = "BREAK";
 326 /****    if (mode = "INPUT")
 327          then do;
 328             call ioa_ ("BREAK: not allowed. INPUT MODE");
 329             substr (red_line, 1, 2) = "\f";
 330             nelemt = 2;
 331             return;
 332          end;                                                                */
 333 bk_loop:
 334       call iox_$get_line (iox_$user_input, atp, ibe, nelemt, code);
 335       if (code ^= 0)
 336       then do;
 337          call no_input;
 338          goto bk_loop;
 339       end;
 340       if db_catch
 341       then call ioa_$ioa_switch_nnl (db_output,
 342          "====BRK^-^a", substr (red_line, 1, nelemt));
 343       if (nelemt = 3) & (substr (red_line, 1, 2) = "\?")
 344       then goto re_break;
 345       return;                           /* tedset_ptr_ */%page;
 346 /**** <<<<----- dcl_tedread_ptr_.incl.pl1 tedread_ptr_                       */
 347 tedread_ptr_:                           /* read a line from input stream     */
 348    entry (adb_p, atp, ibi, ibe, nelemt, mode);
 349 dcl (
 350 /****adb_p          ptr,                /* -> database                       */
 351     atp             ptr,                /* -> input buffer                   */
 352     ibi             fixed bin (21),     /* last char in use in buffer        */
 353     ibe             fixed bin (21),     /* last char useable in buffer       */
 354     nelemt          fixed bin (21),     /* last char filled in buffer  [OUT] */
 355     mode            char (5)            /* mode in which read is being done  */
 356     )               parm;               /* ----->>>>                         */
 357 dcl red_line        char (ibe) based (atp);
 358 dcl red_char        (ibe) char (1) based (atp);
 359 dcl tmode           char (5);
 360 dcl db_input        bit (1);
 361 
 362       tmode = mode;
 363       db_input = db_ted & ((tmode="INPUT")|(tmode="BULK"));
 364 reread:
 365       dbase_p = adb_p;
 366       concealsw = "0"b;
 367       bp = dbase.stk_info.curp;         /* get ptr to cur buffer ctl block   */
 368       nelemt = ibi;                     /* make sure old line is gone        */
 369       ti = ibi;
 370       te = ibe;
 371       if (dbase.at_break ^= 0)
 372       then goto break_input;
 373 reloop:
 374       if db_util & ^b.tw_sw
 375       then call tedshow_ (bp, "ex");
 376       tti = ti;
 377       do while (ti <= te);
 378 retry:
 379          if ex_next > ex_EOD            /* is part being read exhausted?     */
 380          then do;
 381             if b.tw_sw                  /* coming from user_input?           */
 382             then do;
 383                if (rdy.len > 0) & (ex_EOD ^= 1) & (tmode = "EDIT")
 384                then begin;
 385 dcl rdyline         char (rdy.len);
 386                   rdyline = rdy_line;
 387                   call cu_$cp (addr (rdyline), rdy.len, code);
 388                end;
 389 refresh:       begin;
 390 
 391                   if b.pseudo
 392                   then do;
 393                      b.b_.l.re = b.b_.l.le - 1;
 394                      b.b_.r.le = b.b_.r.re + 1;  /* make it look empty       */
 395                      call tedpromote_ (bp, 4069);
 396                                         /* dbase.rl.part1 = b.cur;           */
 397                   end;
 398 
 399                   b.b_.l.re = 0;
 400 loop:
 401                   call iox_$get_line (iox_$user_input, b.cur.sp, b.maxl,
 402                      b.b_.l.re, code);
 403                   if (code ^= 0)
 404                   then do;              /* not handling long records         */
 405                      call no_input;
 406                      goto loop;
 407                   end;
 408                   if db_catch
 409                   then call ioa_$ioa_switch_nnl (db_output,
 410                      "====^a^-^a", tmode, substr (b_s, 1, b.b_.l.re));
 411                   call init_exec (1, (b.b_.l.re));
 412                   if (ex_EOD = 3) & (substr (b_s, 1, 3) = "\?
 413 ")
 414                   then do;
 415                      call tell_where (tmode);
 416                      ex_EOD = 0;
 417                      goto loop;         /* try again to get data for caller  */
 418                   end;
 419 
 420                end refresh;
 421             end;
 422             else do;                    /* here on end of buffer             */
 423                call tedend_buffer_ (dbase_p, 0); /* pop level by 1           */
 424                bp = dbase.stk_info.curp;/* re-establish prev buff ctl block  */
 425             end;
 426             goto retry;
 427          end;
 428          if (tmode = "EDIT") & (ti = 0) & (ex_EOD > ex_next)
 429          then if (substr (b_s, ex_next, 2) = "..")
 430               then do;                  /* NEED TO HANDLE ARBITRARY LENGTH!  */
 431                  call set_exec (ex_next + 2);
 432                  tp = addr (ex_c (ex_next));
 433                  kk = ex_EOD - ex_next + 1;
 434                  i21 = index (substr (b_s, ex_next, kk), NL);
 435                  if (i21 = 0)
 436                  then do;
 437                     i21 = kk;
 438                     call set_exec (ex_next + i21);
 439                  end;
 440                  else call set_exec (ex_next + i21 - 1);
 441                  call tedset_ck_ptr_ (dbase_p);
 442                  call cu_$cp (tp, i21, code);
 443 dcl kk              fixed bin (21);
 444                  tp = atp;
 445                  substr (red_line, 1, 3) = "e";
 446                  ti = 3;
 447                  goto rdp (1);          /* add a NL                          */
 448               end;
 449          srchl = min (ex_EOD - ex_next + 1, te - ti + 1);
 450          if (tmode = "BULK")
 451          then do;
 452             if (substr (b_s, ex_next, 2) = ".
 453 ")          then do;
 454                call set_exec (ex_next + 2);
 455                mode = "EOF";
 456                goto end_read;
 457             end;
 458             k = index (substr (b_s, ex_next, srchl), NL);
 459                                         /* NEED to avoid line splitting?     */
 460          end;
 461                                         /* find a char needing attention     */
 462          else k = search (substr (b_s, ex_next, srchl), hot_chars);
 463 
 464 dcl hot_chars       char (7) int static options (constant) init ("
 465 \^_^Y^X^^^\");
 466 
 467          if (k = 0)
 468          then k = srchl;
 469          else k = k - 1;
 470          if (k > 0)                     /* move intervening chars, if any    */
 471          then do;
 472             substr (red_line, ti + 1, k) = substr (b_s, ex_next, k);
 473             if db_input then call ioa_$ioa_switch (db_output,
 474                "^a: (^p->red_line,ti+1(^i),^i)=^p->str,len=^i", tmode,
 475                addr(red_line), ti+1, k, addcharno (b.cur.sp, ex_next-1), ti+k);
 476             ti = ti + k;
 477             call set_exec (ex_next + k);
 478          end;
 479          if (ti > te)                   /* caller's buffer full?             */
 480          then goto end_read;            /*  YES                              */
 481          if (ex_next > ex_EOD)          /* source exhausted?                 */
 482          then goto retry;               /*  YES                              */
 483          k = index (hot_chars, substr (b_s, ex_next, 1));
 484          if (^dbase.old_style | b.tw_sw) & (k > 3)
 485          then do;
 486             if (tmode ^= "INPUT")
 487             then do;
 488                substr (red_line, ti + 1, 2) = "\c";
 489                ti = ti + 2;
 490             end;
 491             goto move_ch;
 492          end;
 493          goto rdp (k);
 494 
 495 rdp (1):                                /* NL */
 496          ti = ti + 1;
 497          red_char (ti) = NL;
 498          if db_input then call ioa_$ioa_switch (db_output,
 499             "^a: (^p->red_line,ti+1(^i),i)=NL,len=^i", tmode,
 500             addr(red_line), ti, ti);
 501          call set_exec (ex_next + 1);
 502          goto end_read; %skip (5);
 503 dcl old_msg         char (47) int static options (constant) init (
 504                     "^/^a: b(^a) contains a \03^a (old-style \^a).^/");
 505 
 506 rdp (4):                                /* \031 (old \c)                     */
 507          if b.tw_sw
 508          then goto move_ch;
 509          if ^b.bs.c
 510          then do;
 511             call ioa_ (old_msg, dbase.tedname, b.name, "1", "C");
 512             b.bs.c = "1"b;
 513          end;
 514          escl = 0;
 515 esc (1):                                /* "\c"                              */
 516          if (tmode = "INPUT")
 517          then goto always_conceal;
 518          k = index (hot_chars, substr (b_s, ex_next + escl + 1, 1));
 519          if (k = 2)                     /* "\"                               */
 520          then do;
 521             if (ex_next + escl < ex_EOD)          /* is there another char?      */
 522             then do;
 523                j = index (ESCAPES, substr (b_s, ex_next + escl + 2, 1));
 524                if (j > ESCmax)
 525                then j = j - ESCmax;
 526                k = j + 3;
 527             end;
 528             else k = 0;
 529          end;
 530          if (k = 0)                     /* not of interest                   */
 531             | (k = 4)                   /* \031 \c                           */
 532             | (k = 7)                   /* \034 \f                           */
 533          then do;
 534             substr (red_line, ti + 1, escl + 2)
 535                = substr (b_s, ex_next, escl + 2);
 536             if db_input then call ioa_$ioa_switch (db_output,
 537                "^a: (^p->red_line,ti+1(^i),^i)=^p->str,len=^i", tmode,
 538                addr(red_line), ti+1, escl + 2, addcharno (b.cur.sp, ex_next-1),
 539                ti + escl + 2);
 540             ti = ti + escl + 2;
 541          end;
 542          else do;
 543 always_conceal:
 544             if db_input then call ioa_$ioa_switch (db_output,
 545                "^a: (^p->red_line,ti+1(^i),1)=^p->str,len=^i", tmode,
 546                addr(red_line), ti+1, addcharno (b.cur.sp, ex_next + escl), ti+1);
 547             ti = ti + 1;
 548             red_char (ti) = substr (b_s, ex_next + escl + 1, 1);
 549          end;
 550          call set_exec (ex_next + escl + 2);
 551          goto end_loop; %skip (5);
 552 rdp (5):                                /* \030 (old \b)                     */
 553          if b.tw_sw
 554          then goto move_ch;
 555          if ^b.bs.b
 556          then do;
 557             call ioa_ (old_msg, dbase.tedname, b.name, "0", "B");
 558             b.bs.b = "1"b;
 559          end;
 560          escl = 0;
 561 esc (2):                                /* "\b"                              */
 562          call set_exec (ex_next + escl + 1);
 563 /**** Must the gap be accounted for here?                                    */
 564          used = ex_EOD - ex_next + 1;
 565          call tedget_existing_buffer_ (dbase_p, addr (b_c (ex_next)),
 566             used, new_bp, msg);         /* try to find named buffer          */
 567          call set_exec (ex_next + used);
 568          if (new_bp = null ())          /* error if named buffer does        */
 569          then do;                       /*   not already exist               */
 570 rd_err:
 571             if (tmode = "INPUT")
 572             then msg = msg || "
 573 INPUT mode terminated.";                                              /* #136*/
 574             call tederror_ (dbase_p, msg);
 575             call tedresetread_ (dbase_p); /* reset back to level 0           */
 576             if (tmode = "INPUT")
 577             then do;                                                  /* #136*/
 578                mode = "EOF";                                          /* #136*/
 579                goto end_read;                                         /* #136*/
 580             end;                                                      /* #136*/
 581             goto reread;                /* and reread this call from scratch */
 582          end;
 583          if new_bp -> b.INPUT
 584          then do;                                                     /* #156*/
 585             msg = "Bmi) Cannot invoke b(";                            /* #156*/
 586             msg = msg || rtrim (new_bp -> b.name);                    /* #156*/
 587             msg = msg || "), it is in INPUT mode.";                   /* #156*/
 588             goto rd_err;                                              /* #156*/
 589          end;                                                         /* #156*/
 590          if (dbase.stk_info.level > 500)
 591          then do;
 592             msg = "Brc) Level > 500.";
 593             goto rd_err;                /* check buffer recursion level      */
 594          end;
 595          call push_one (dbase.stk_info.next);
 596          if (ex_next = 1) & (ex_last = b.maxl)
 597          then b.not_pasted = "0"b;
 598          goto retry; %skip (5);
 599 rdp (6):                                /* \036 (old \r)                     */
 600          if b.tw_sw
 601          then goto move_ch;
 602          if ^b.bs.r
 603          then do;
 604             call ioa_ (old_msg, dbase.tedname, b.name, "6", "R");
 605             b.bs.r = "1"b;
 606          end;
 607          escl = 0;
 608 esc (3):                                /* "\r"                              */
 609          if (tmode = "INPUT")           /* in INPUT mode postpone the \r     */
 610          then do;                       /* ..if there isn't a fair amount of */
 611             if (te - ti < 256)          /* ..space left in the file to       */
 612             then do;                    /* ..receive it.                     */
 613                te = ti - 1;             /* force EOBuffer                    */
 614                goto end_read;
 615             end;
 616          end;
 617          call set_exec (ex_next + escl + 1);
 618 console_read:
 619          tp = addr (temp_fix);
 620 dcl temp_fix        char (512);
 621          call iox_$get_line (iox_$user_input, tp, length (temp_fix),
 622             j24, code);
 623          if (code ^= 0)
 624          then do;
 625             call no_input;
 626             goto console_read;
 627          end;
 628          if db_catch
 629          then call ioa_$ioa_switch_nnl (db_output,
 630             "====READ^-^a", substr (temp_fix, 1, j24));
 631          j24 = min (j24, te - ti);
 632          substr (red_line, ti + 1, j24) /* move line (as much as             */
 633             = substr (tp -> str, 1, j24); /*  will fit) to caller's buffer  */
 634             if db_input then call ioa_$ioa_switch (db_output,
 635                "^a: (^p->red_line,ti+1(^i),^i)=^p->str,len=^i", tmode,
 636                addr(red_line), ti+1, j24, tp, ti+j24);
 637          ti = ti + j24;
 638          if (dbase.tedname = "qedx")
 639          then goto end_read;            /* qedx quits right there            */
 640          else do;
 641             if (red_char (ti) = NL)
 642             then ti = ti - 1;           /* ted doesn't give up so easily     */
 643          end;
 644          if (j24 = 3) & (substr (tp -> str, 1, 1) = "\")
 645          then do;
 646             if (substr (tp -> str, 2, 1) = "?")
 647             then do;
 648                call tell_where ("READ");
 649                goto console_read;
 650             end;
 651             if (index ("fF", substr (tp -> str, 2, 1)) ^= 0)
 652             then do;
 653                mode = "\R\F";
 654                goto read_exit;
 655             end;
 656          end;
 657          goto retry; %skip (5);
 658 dcl ESCAPES         char (14) int static options (constant) init
 659                     ("cbrfvx{[CBRFVX");
 660 dcl ESCmax          fixed bin int static init (8) options (constant);
 661 rdp (2):                                /* "\"                               */
 662          j = index (ESCAPES, substr (b_s, ex_next + 1, 1));
 663          if (j = 0)
 664          then goto move_ch;
 665          if (j > ESCmax)
 666          then j = j - ESCmax;
 667          escl = 1;
 668          goto esc (j); %skip (5);
 669 esc (5):                                /* "\v"                              */
 670          if (substr (b_s, ex_next + 2, 1) = "{")
 671          then do;
 672             call set_exec (ex_next + 1);/* "\v{"                             */
 673 dcl 1 adr_hold      (0:2) like b.a_;
 674 esc (7):                                /* "\{"                              */
 675             call set_exec (ex_next + 1);
 676             adr_hold = b.a_;            /* keep what is there right now      */
 677             b.present (1), b.present (2) = "0"b;
 678             used = ex_EOD - ex_next + 1;
 679             call tedeval_ (dbase_p, addr (b_c (ex_next)), used,
 680                bp, null (), -1, result, msg, code);
 681             call set_exec (ex_next + used);
 682             b.a_ = adr_hold;            /* someone else might need it        */
 683             if (code ^= 0)
 684             then goto rd_err;
 685             j24 = min (length(result), te - ti);
 686             substr (red_line, ti + 1, j24) = result;
 687             if db_input then call ioa_$ioa_switch (db_output,
 688                "^a: (^p->red_line,ti+1(^i),^i)=^p->str,len=^i", tmode,
 689                addr(red_line), ti+1, j24, addr (result), ti+j24);
 690             ti = ti + j24;
 691             goto retry;
 692          end;
 693 esc (8):                                /* "\[" */
 694          j = verify (substr (b_s, ex_next + 2), "0123456789");
 695          if (substr (b_s, ex_next + 1 + j, 1) = "]")
 696          then do;                       /* convert \[n].   to \x[n.]         */
 697                                         /* *    or \[n]\cx to \x[n"x"]       */
 698                                         /* *    or \[n]x   to \x[n"x"]       */
 699             j24 = ti;
 700             substr (red_line, ti + 1, 3) = "\x[";
 701             ti = ti + 3;
 702             substr (red_line, ti + 1, j - 1) = substr (b_s, ex_next + 2, j - 1);
 703             ti = ti + j - 1;
 704             call set_exec (ex_next + j + 2);
 705             if (substr (b_s, ex_next, 1) = ".")
 706             then do;
 707                substr (red_line, ti + 1, 2) = ".]";
 708                ti = ti + 2;
 709             end;
 710             else do;
 711                if (substr (b_s, ex_next, 2) = "\c")
 712                   | (substr (b_s, ex_next, 2) = "\C")
 713                then call set_exec (ex_next + 2);
 714                substr (red_line, ti + 1, 4) = """?""]";
 715                substr (red_line, ti + 2, 1) = substr (b_s, ex_next, 1);
 716                ti = ti + 4;
 717             end;
 718             if db_input
 719             then do;
 720                k = ti - j24;
 721                call ioa_$ioa_switch (db_output,
 722                   "^a: (^p->red_line,ti+1(^i),^i)=""^a"",len=^i", tmode,
 723                addr(red_line), j24+1, k, substr (red_line, j24+1, k), ti+k);
 724             end;
 725             call set_exec (ex_next + 1);
 726          end;
 727          else call ioa_ ("\[active_function] not implemented.");
 728 esc (6):                                /* "\x[" (just passed thru)          */
 729          goto move_ch;
 730 dcl result          char (500) var;
 731 dcl code            fixed bin (35); %skip (5);
 732 rdp (3):                                /* "\037" BREAK                      */
 733          if (tmode = "INPUT")
 734             | dbase.tedname = "qedx"
 735          then goto move_ch;
 736          call set_exec (ex_next + 1);
 737          if ^dbase.break_sw
 738          then goto end_loop;
 739          dbase.at_break = 1;
 740          red_char (ti + 1) = NL;
 741          goto end_read; %skip (5);
 742 rdp (7):                                /* \034 (old \f)                     */
 743          if b.tw_sw
 744          then goto move_ch;
 745          if ^b.bs.f
 746          then do;
 747             call ioa_ (old_msg, dbase.tedname, b.name, "4", "F");
 748             b.bs.f = "1"b;
 749          end;
 750          escl = 0;
 751 esc (4):                                /* "\f"                              */
 752 rdp (0):
 753          if (tmode = "INPUT")
 754          then do;
 755             mode = "EOF";
 756             call set_exec (ex_next + 2);
 757             if (substr (b_s, ex_next, 1) = NL)
 758             then call set_exec (ex_next + 1);
 759             goto end_read;
 760          end;
 761 move_ch:
 762          ti = ti + 1;
 763          red_char (ti) = substr (b_s, ex_next, 1);
 764          call set_exec (ex_next + 1);
 765 end_loop:
 766       end;
 767 end_read:
 768 /**** INPUT/BULK modes will not return at EOline, they will return at EOinfo */
 769 /****  or EObuffer. Then last char used is updated for each line for -safe.  */
 770       nelemt = ti;                      /* return last char in use           */
 771 dcl EL_sw           bit(1);
 772 
 773       if (ti = 0)
 774       & (mode ^= "EOF")                 /* this happens when \037 is first   */
 775       then goto reloop;                 /* ..thing on a line.                */
 776       if (ti = 0)                       /* next statement will blow up if    */
 777       then EL_sw = "1"b;                /* ..ti=0, prevent that.             */
 778       else EL_sw = (substr (red_line, ti, 1) ^= NL) | (mode = "EOF");
 779       if (tmode = "EDIT") & dbase.edit_sw
 780          | (tmode = "INPUT") & dbase.input_sw
 781       then call ioa_$nnl ("**^a**       ^a^[^/^]", mode,
 782          substr (red_line, tti+1, ti-tti), EL_sw);
 783       if (osw_p ^= null())
 784       then if (tmode = osmode) | (osmode = "ALL")
 785       then call ioa_$ioa_switch_nnl (osw_p, "**^a**^-^a^[^/^]", mode,
 786          substr (red_line, tti+1, ti-tti), EL_sw);
 787       if (ti <= te)
 788       then if (mode = "INPUT") | (mode = "BULK")
 789       then goto reloop;
 790 read_exit:
 791       if db_ted
 792       then call ioa_$ioa_switch (db_output, "^a: ^i:^i:^i ^i", mode, ibi, ti, ibe, nelemt);
 793       return; %skip (4);
 794 dcl osmode          char (8) int static init ("");
 795 dcl osw_p           ptr int static init (null());
 796 dcl iox_$look_iocb entry (char(*), ptr, fixed bin(35));
 797 dcl ioa_$ioa_switch_nnl entry() options(variable);
 798 dcl iox_$open       entry (ptr, fixed bin, bit(1) aligned, fixed bin(35));
 799 dcl error_table_$not_closed fixed bin(35) ext static;
 800 
 801 osw: entry (p1, p2);
 802 dcl (p1,p2) char (*);
 803      call iox_$look_iocb (p1, osw_p, code);
 804      if (code ^= 0)
 805      then do;
 806         osw_p = null();
 807 osw_err:
 808         call com_err_ (code, "ted(osw)", "^a", p1);
 809         return;
 810      end;
 811      call iox_$open (osw_p, 2, ""b, code);
 812      if (code ^= 0)
 813      then do;
 814         if (code ^= error_table_$not_closed)
 815         then goto osw_err;
 816      end;
 817      osmode = p2;
 818      return; %skip(4);
 819 tell_where: proc (mode);
 820 
 821 dcl mode            char (5);
 822 
 823       call ioa_ ("^a^[(^a)^;^s^]: ^a MODE[^i]^[safe^]",
 824          dbase.tedname, (dbase.tedname = "ted"), ted_vers, mode,
 825          dbase.recurs, (dbase.dir_db ^= ""));
 826 
 827    end tell_where;%page;
 828 tederror_:                              /* save {& print} an error message   */
 829    entry (adb_p, a_msg);
 830 dcl (
 831 /****adb_p          ptr,                /* -> dabatase                       */
 832     a_msg           char (168) var      /* error message                     */
 833     )               parm;
 834 
 835       dbase_p = adb_p;
 836       if (length (a_msg) < 6)
 837       then dbase.err_msg = "???) " || a_msg;
 838       else dbase.err_msg = a_msg;
 839       if (dbase.err_go = " ") | (dbase.at_break ^= 0)
 840       then do;
 841          if db_util
 842          then call ioa_$ioa_switch_nnl (iox_$error_output, "^a",
 843                  substr (dbase.err_msg, 1, 5));
 844          call ioa_$ioa_switch_nnl (iox_$error_output, "^a^/",
 845             substr (dbase.err_msg, 6));
 846          if (osw_p ^= null())
 847          then call ioa_$ioa_switch_nnl (osw_p, "^a^/",
 848             substr (dbase.err_msg, 6));
 849       end;
 850       return;                           /* tedread_ptr_ */%skip (4);
 851 /**** <<<<----- dcl_tedcall_.incl.pl1 tedcall_                               */
 852 tedcall_:                               /* call a buffer                     */
 853    entry (adb_p, acode);
 854 dcl (
 855 /****adb_p          ptr,                /* -> database                       */
 856     acode           fixed bin (35)
 857     )               parm;               /* ----->>>>                         */
 858 
 859       acode = 0;
 860       dbase_p = adb_p;
 861       bp = dbase.stk_info.curp;
 862       used = rl_l - rl_i + 1;
 863       call tedget_existing_buffer_ (dbase_p, addr (rl_c (rl_i)),
 864          used, new_bp, msg);            /* try to find named buffer          */
 865       rl_i = rl_i + used;
 866       if (new_bp = null ())             /* error if does not already exist   */
 867       then do;
 868          call tederror_ (dbase_p, msg);
 869          acode = 1;
 870          return;
 871       end;
 872       if (dbase.stk_info.level > 500)
 873       then do;
 874          msg = "Brc) Level > 500.";
 875          call tederror_ (dbase_p, msg);
 876          acode = 1;
 877          return;
 878       end;
 879       if (dbase.seg_p (3) = null())
 880       then call tedget_segment_ (dbase_p, null(), 3);
 881 /**** make room for argument string                                          */
 882       pstrp = addr (call_stk.space (dbase.stk_info.next));
 883       pstrl = dbase.stk_info.next;
 884       i = rl_l - rl_i;
 885       dbase.stk_info.next = dbase.stk_info.next + divide (i + 7, 8, 24, 0);
 886       substr (pstrp -> str, 1, i) = substr (rl_s, rl_i, i);
 887       call push_one (pstrl);
 888       if (i > 0)                        /* if argstring is non-null          */
 889       then do;                          /*  parse the arguments              */
 890          sv.pp (0) = pstrp;
 891          sv.pl (0) = i;
 892          delim = pchar (1);
 893          sv.pn = 1;
 894          sv.pp (1) = addr (pchar (2));
 895          sv.pl (1) = 0;
 896          do ii = 2 to i;
 897             if (substr (pstrp -> str, ii, 2) = "\C")
 898                | (substr (pstrp -> str, ii, 2) = "\c")
 899             then do;
 900                if (pchar (ii + 2) = delim)
 901                then goto use_pch;
 902             end;
 903             if (pchar (ii) = delim)
 904             then do;
 905                sv.pn = sv.pn + 1;
 906                sv.pp (sv.pn) = addr (pchar (ii + 1));
 907                sv.pl (sv.pn) = 0;
 908             end;
 909             else do;
 910 use_pch:
 911                sv.pl (sv.pn) = sv.pl (sv.pn) + 1;
 912             end;
 913          end;
 914          dbase.stk_info.next = dbase.stk_info.next + sv.pn * 2 + 2;
 915       end;
 916       return /* tedcall_ */;
 917 dcl delim           char (1);
 918 dcl pstrp           ptr;
 919 dcl pchar           (1:2000) char (1) based (pstrp);
 920 dcl pstrl           fixed bin (21);%page;
 921 /**** <<<<----- dcl_tedend_buffer_.incl.pl1 tedend_buffer_                   */
 922 tedend_buffer_:                         /* pop buffer recursion 1 level      */
 923    entry (adb_p, ecode);
 924 dcl (
 925 /****adb_p          ptr,                /* -> database                       */
 926     ecode           fixed bin (35)      /* 1- already at level 0, 0- ok      */
 927     )               parm;               /* ----->>>>                         */
 928       i = ecode;
 929       dbase_p = adb_p;
 930       if (dbase.stk_info.level = 0)     /* check recursion level             */
 931       then do;
 932          ecode = 1;                     /* error if level already 0          */
 933          return;                        /* return error condition to caller  */
 934       end;
 935       call pop_one;
 936       if (i = COM) & (dbase.stk_info.level = 0)
 937       then ecode = 1;
 938       else ecode = 0;
 939       return;                           /* and return to caller              */
 940 %skip (4);
 941 pop_one: proc;
 942 
 943       if db_util
 944       then call tedshow_ (dbase_p, "stkall");
 945       bp = dbase.stk_info.curp;         /* current execution buffer          */
 946       b.invoking = ""b;                 /* clear execution range             */
 947       unspec (b.ex) = unspec (tedcommon_$no_data);
 948       sv_p = dbase.stk_info.top;        /* pop a stack frame and restore...  */
 949       dbase.stk_info.top = sv.prev;     /* ...top of stack                   */
 950       dbase.stk_info.next = sv.this;    /* ...free location                  */
 951       dbase.stk_info.curp, bp = sv.bp;  /* ...buffer control block           */
 952       b.ex = sv.ex;                     /* ...read limits                    */
 953       b.invoking = (unspec (b.ex) ^= unspec (tedcommon_$no_data));
 954       b.a_ (0) = sv.a0;
 955       b.stackl = sv.stackl;
 956       dbase.stk_info.level = dbase.stk_info.level - 1;
 957 
 958    end pop_one; %page;
 959 push_one: proc (this);
 960 
 961 dcl this            fixed bin (21);
 962 
 963       dbase.stk_info.level
 964          = dbase.stk_info.level + 1;    /* bump recursion level              */
 965       dbase.stk_info.curp = new_bp;     /* make new buffer current           */
 966       if (dbase.seg_p (3) = null())
 967       then call tedget_segment_ (dbase_p, null(), 3);
 968       sv_p                              /* create stack frame and save...    */
 969          = addr (call_stk.space (dbase.stk_info.next));
 970       sv.prev = dbase.stk_info.top;     /* ...current top of stack           */
 971       sv.bp = bp;                       /* ...current buffer control block   */
 972       sv.ex = b.ex;                     /* ...execution limits               */
 973       sv.a0 = b.a_ (0);                 /* ..."." value                      */
 974       sv.stackl = b.stackl;             /* ...AND keep track of where this   */
 975       b.stackl = rel (sv_p);            /*    data is for relocation         */
 976       sv.this = this;                   /* ...free location                  */
 977       sv.pn = 0;                        /* ...start as if no args            */
 978       sv.pp (0) = null();
 979       sv.pl (0) = 0;
 980       dbase.stk_info.next = dbase.stk_info.next + size (sv);
 981       dbase.stk_info.top = sv_p;        /* push the stack frame              */
 982       bp = dbase.stk_info.curp;         /* new current buffer                */
 983       b.invoking = "1"b;                                              /* #156*/
 984       call init_exec (b.a_.l.re (1),  b.a_.r.le (2));                 /* #156*/
 985       if db_util & lg_util
 986       then call tedshow_ (dbase_p, "stkall");
 987 
 988    end push_one; %skip (4);
 989 tedresetread_:                          /* abort to buffer level 0           */
 990    entry (adb_p);
 991 
 992       dbase_p = adb_p;
 993       if dbase.stk_info.level ^= 0      /* if buffer recursion level > 0     */
 994       then do;
 995          call ioa_ ("Executing (level,line,buffer). [Recursion=^i]",
 996             dbase.recurs);
 997          bp = dbase.stk_info.curp;      /* current buffer                    */
 998          do while (dbase.stk_info.level ^= 0);/* release buff recursion stk  */
 999             call tedcount_lines_ (bp, 1, ex_next - 1, j);
1000             call ioa_ ("^-^3i ^4i b(^a)", dbase.stk_info.level, j, b.name);
1001             call pop_one;
1002          end;
1003       end;
1004       bp = dbase.stk_info.curp;         /* get pointer to level 0 ctl block  */
1005       ex_next = ex_last + 1;            /* set buffer exhausted          #156*/
1006       if reset_read
1007       then call iox_$control (iox_$user_input, "resetread", null (), code);
1008       return; %page;
1009 set_req_line: entry;
1010 
1011       if (rdy.len ^= 0)
1012       then do;
1013          free rdy_line;
1014          rdy.len = 0;
1015       end;
1016       call cu_$arg_ptr (1, tp, i21, code); dcl arg char (i21) based (tp);
1017       if (code ^= 0)
1018       then do;
1019          return;
1020       end;
1021       rdy.len = i21;
1022       allocate rdy_line;
1023       rdy_line = arg;
1024       return;
1025 
1026 dcl 1 rdy           int static,
1027       2 len         fixed bin (21) init (0),
1028       2 pt          ptr;
1029 
1030 dcl rdy_line        char (rdy.len) based (rdy.pt);
1031 
1032 get_req_line: entry;
1033 
1034       call cu_$af_arg_count (l, code);
1035       if (code ^= 0)
1036       then call ioa_ ("^a", rdy_line);
1037       else do;
1038 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
1039 dcl af_val          char (af_len) var based (af_ptr);
1040 dcl af_len          fixed bin (21);
1041 dcl af_ptr          ptr;
1042 dcl l               fixed bin;
1043          call cu_$af_return_arg (l + 1, af_ptr, af_len, code);
1044          af_val = rdy_line;
1045       end;
1046       return;                           /* tedend_buffer_ */%page;
1047 
1048 /**** <<<<----- dcl_tedcount_lines_.incl.pl1 tedcount_lines_                 */
1049 tedcount_lines_:                        /* return # lines in string          */
1050    entry (abp, asi, ase, alct);
1051 dcl (
1052     abp             ptr,                /* -> buffer in which to count       */
1053     asi             fixed bin (21),     /* where string begins in segment    */
1054     ase             fixed bin (21),     /* where string ends in segment      */
1055     alct            fixed bin (21)      /* # lines                     [OUT] */
1056     )               parm;               /* ----->>>>                         */
1057 
1058 dcl lct             fixed bin (21);
1059 dcl loc             fixed bin (21);
1060 
1061       bp = abp;
1062       lct = 0;
1063       if db_util
1064       then call ioa_$ioa_switch_nnl (db_output,
1065          ".lct:sn=^i", b.cur.sn);
1066       if (b.cur.sn ^= 0)                /* any data in buffer?               */
1067       then do;
1068          call count ((asi), min (ase, b.b_.l.re));
1069          call count (max (b.b_.r.le, asi), ase);
1070          if (b.b_.r.re < b.b_.r.le)     /* upper part empty                  */
1071          then loc = min (ase, b.b_.l.re);
1072          else loc = ase;
1073 
1074 /* RW 88 */
1075          if (loc ^= 0) then                                           /* #193*/
1076              if (b_c (loc) ^= NL) then
1077                     lct = lct + 1;
1078       end;
1079       alct = lct;
1080       if db_util
1081       then call ioa_$ioa_switch (db_output, " =^i", alct);
1082       return;
1083 
1084 count: proc (ti, te);
1085 dcl (ti             fixed bin (21),     /* beginning point                   */
1086     te              fixed bin (21)      /* ending point                      */
1087     )               parm;
1088 
1089 dcl lti             fixed bin (21);     /* local ti                          */
1090 dcl str             char (te) based (b.cur.sp);
1091 dcl II              fixed bin (21);
1092 
1093       lti = ti;
1094       do while (lti <= te);
1095          II = index (substr (str, lti), NL);
1096          if (II ^= 0)                   /* a NL found                        */
1097          then do;
1098             lct = lct + 1;              /* count one line                    */
1099             lti = lti + II;             /* move past it                      */
1100          end;
1101          else lti = te + 1;
1102       end;
1103       if db_util
1104       then call ioa_$ioa_switch_nnl (db_output, " ^i:^i ^i", ti, te, lct);
1105 
1106    end count; %page;
1107 tedck_ptr_:                             /* check on flagged ^read seg        */
1108    entry (aabp);
1109 dcl (
1110     aabp            ptr                 /* -> buffer control block           */
1111     )               parm;
1112 
1113 dcl error_table_$invalidsegno fixed bin (35) ext static;
1114 dcl tuid            bit (36);
1115 
1116       bp = aabp;
1117       call hcs_$get_uid_seg (b.cur.sp, tuid, code);
1118       if (code = error_table_$invalidsegno)
1119       then goto re_init;
1120       if (code ^= 0)
1121       then do;
1122          call com_err_ (code, dbase.tedname,
1123             "Checking on b(^a) segment ^a>^a", b.name, b.dname, b.ename);
1124          goto re_init;
1125       end;
1126       if (tuid = b.uid)
1127       then goto ck_out;
1128 re_init:                                /* assume can't do anything with     */
1129                                         /*  that pointer */
1130       call hcs_$initiate_count (b.dname, b.ename, "", ii, 0, tp, code);
1131       if (tp = null ())
1132       then do;
1133          b.b_ = tedcommon_$no_data;
1134          dbase.not_read_ct = max (0, dbase.not_read_ct - 1);
1135          call com_err_ (code, dbase.tedname,
1136             "Trying to reconnect segment ^a>^a to b(^a)",
1137             b.dname, b.ename, b.name);
1138          b.dname = "";
1139          b.file_sw = "0"b;
1140          b.terminate = "0"b;
1141          b.mod_sw = "0"b;
1142          b.get_bit_count = "0"b;
1143          b.not_pasted = "0"b;
1144          goto ck_out;
1145       end;
1146       addr (b.cur.sp) -> its.segno = addr (tp) -> its.segno;
1147       call hcs_$get_uid_seg (b.cur.sp, b.uid, code);
1148       ii = divide (ii, 9, 24, 0);
1149       if (ii ^= b.maxl)
1150       then do;
1151          call com_err_ (0, dbase.tedname,
1152             "Segment ^a>^a connected to b(^a) changed size from ^i to ^i",
1153             b.dname, b.ename, b.name, b.b_.r.re, ii);
1154          b.maxl, b.b_.r.re, b.b_.l.re, b.b_.l.re = ii;
1155          b.b_.l.le = 1;
1156       end;
1157 ck_out:
1158       b.ck_ptr_sw = "0"b;
1159       return; %page;
1160 
1161 dcl (
1162     addcharno, addr, char, divide, index, length, max, min, null, rel, reverse,
1163     rtrim, search, size, substr, unspec, verify
1164     )               builtin;
1165 
1166 dcl (ex_next        defined b.ex.l.le,  /* next char to execute              */
1167     ex_EOD          defined b.ex.l.re,  /* last char in part to execute      */
1168     ex_lre          defined b.ex.r.le,  /* last char in left part to execute */
1169     ex_last         defined b.ex.r.re)  /* last char to execute              */
1170                     fixed bin (21);                                   /* #156*/
1171 dcl ex_s            char (b.ex.l.re) based (b.cur.sp);
1172 dcl ex_c            (b.ex.l.re) char (1) based (b.cur.sp);
1173 %include tedbcb;
1174 %include tederror_;
1175 %include tedstk;
1176 %include tedbase;
1177 %include tedcommon_;
1178 %include its;
1179 dcl tedset_ck_ptr_  entry (ptr);
1180 dcl tedget_existing_buffer_ entry (     /* find a named buffer               */
1181                     ptr,                /* -> database                       */
1182                     ptr,                /* -> string containing buffer name  */
1183                     fixed bin (21),     /*   length of string           [IN] */
1184                                         /*   how much was used         [OUT] */
1185                     ptr,                /* buffer control block (OUT)        */
1186                     char (168)var       /* error message text                */
1187                     );
1188 
1189 /*dcl tedget_buffer_entry (             /* find (or create) a buffer         */
1190 /*                  ptr,                /* -> database                       */
1191 /*                  ptr,                /* -> string containing buffer name  */
1192 /*                  fixed bin (21),     /*   length of string           [IN] */
1193 /*                                      /*   how much was used         [OUT] */
1194 /*                  ptr,                /* buffer control block (OUT)        */
1195 /*                  char (168)var       /* error message text                */
1196 /*                  );                                                       */
1197 
1198 
1199 dcl tedeval_        entry (             /* process evaluations               */
1200                     ptr,                /* -> database                       */
1201                     ptr,                /* -> evaluation string              */
1202                     fixed bin (21),     /*   length thereof             [IN] */
1203                                         /*   amount used up            [OUT] */
1204                     ptr,                /* -> buffer control block           */
1205                     ptr,                /* -> matched string in \g{...}      */
1206                                         /*    null otherwise                 */
1207                     fixed bin (21),     /*  length of string in \g{...}      */
1208                                         /* <0 in \{...}, 0 otherwise         */
1209                     char (500) var,     /* output string, if any             */
1210                     char (168) var,     /* error message, if any             */
1211                     fixed bin (35)      /* return code                       */
1212                     );
1213 
1214 
1215 dcl tedshow_        entry options (variable);
1216 %include tedsrch_;
1217 dcl tedget_segment_ entry (             /* get a segment to work in          */
1218                     ptr,                /* -> database                       */
1219                     ptr,                /* -> gotten segment           [OUT] */
1220                     fixed bin,          /* sequence # of it         [IN/OUT] */
1221                                         /* if >0 upon entry, it will then    */
1222                                         /*  fill that entry in seg_p array   */
1223                                         /* otherwise it will take any one    */
1224                     );
1225 
1226 
1227 dcl tedpromote_     entry (             /* get a larger data buffer          */
1228                     ptr,                /* -> buffer to promote              */
1229                     fixed bin (21)      /* amount not fitting                */
1230                     );
1231 
1232 
1233 
1234    end tedutil_;