1 /* ***********************************************************
   2    *                                                         *
   3    * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   4    *                                                         *
   5    * Copyright (c) 1972 by Massachusetts Institute of        *
   6    * Technology and Honeywell Information Systems, Inc.      *
   7    *                                                         *
   8    *********************************************************** */
   9 
  10 
  11 /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16            */
  12 /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
  13 /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
  14 /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
  15 
  16 /*                                                                           */
  17 /*    _|_              |                       |                             */
  18 /*     |      _      _ |   ___     _      _    | _                           */
  19 /*     |     / \    / \|  /  _   |/ \    / \   |/ \                          */
  20 /*     |    (__/   (   |  \_/ \  |      (      |   |                         */
  21 /*     \_    \_/    \_/|   ___/  |       \_/   |   |                         */
  22 /*                                                    -----                  */
  23 /*                                                                           */
  24 
  25 /* ted utility procedure to search addressed portion of buffer with          */
  26 /*  specified regular expression                                             */
  27 
  28 tedsrch_:                               /* dummy entry                       */
  29    proc ();
  30    return;
  31 
  32 /* UPDATE HISTORY (finally)                                                  */
  33 /* EL#   date       TR        comments                                       */
  34 /* --- 84-??-??          implement an output switch for debugging            */
  35 /* 146 84-10-10 phx17390 /^..*a/ loops when "a" is first char of buffer      */
  36 /*              phx17429 global-if "/^..*X/ P" loops on lines like "X"       */
  37 /*              phx17531 /^...*>/ also loops when line begins with ">"       */
  38 /* 150 84-10-12 phx17701 interprets "/ * /" incorrectly.                     */
  39 
  40 /**** input string, which is expression                                      */
  41 dcl in_p            ptr;                /* -> expression                     */
  42 dcl in_l            fixed bin (21);     /*   length thereof                  */
  43 dcl in_s            char (in_l) based (in_p); /* expression as a string      */
  44 dcl in_c            (in_l) char (1) based (in_p);   /* expression as chars   */
  45 
  46 /**** data refering to the string being searched                             */
  47 dcl file_str        char (part.right_loc) based (b.cur.sp);
  48 dcl file_char       (part.right_loc) char (1) based (b.cur.sp);
  49 /**** A buffer consists of an upper part and a lower part, either of which   */
  50 /****  may be empty. The next 4 variables describe the part being worked in. */
  51 dcl 1 part,
  52       2 min_left    fixed bin (21),     /* lowest location to consider       */
  53       2 left_loc    fixed bin (21),     /* location (in buffer) of left end  */
  54       2 cur_loc     fixed bin (21),     /* current place                     */
  55       2 right_loc   fixed bin (21),     /* right end                         */
  56       2 left_size   fixed bin (21),     /* how much of the left part is left */
  57       2 this        fixed bin;          /* which part of file are we in      */
  58 
  59 dcl (ami_sw, ame_sw)bit (1);
  60 dcl first_char_matched fixed bin (21);
  61 dcl last_char_matched fixed bin (21);
  62 dcl (lb, ub)        fixed bin (21);      /* lower/upper bounds               */
  63 dcl (i, ii, j, l, sl, type) fixed bin (21);
  64 dcl rep_no          fixed bin;
  65 dcl mct             fixed bin;
  66 dcl concealsw       bit (1);
  67 dcl ch              char (1);
  68 dcl ch1             char (1);
  69 dcl NL              char (1) int static options (constant) init ("
  70 ");
  71 
  72 dcl re_p            ptr;
  73 dcl 1 re            based (re_p),       /* copy of compiled regexp           */
  74       2 maxl        fixed bin,          /* max length of compiled expr       */
  75       2 len         fixed bin,          /* length of this compiled expr      */
  76       2 sws,
  77         3 flag      bit (18) unal,
  78         3 NL_sw     bit (1) unal,       /* was literal NL given in expr      */
  79         3 strmode   bit (1) unal,       /* was compiled in string mode       */
  80         3 fill      bit (16) unal,
  81       2 parts       char (re.len);      /* actual compiled expression        */
  82 dcl FLAG            bit (18) unal int static options (constant)
  83                     init ("252525"b3);
  84 
  85 dcl (rep_p, lrep_p) ptr;                /* -> part/last part                 */
  86 
  87 dcl 1 rep           based (rep_p),      /* regexp part- string               */
  88       2 typ         fixed bin (8)unal,  /* what kind of entry                */
  89       2 lbd         fixed bin (8)unal,  /* min occurances to find            */
  90       2 ubd         fixed bin (8)unal,  /* max occurances (0 -> infinity)    */
  91       2 len         fixed bin (8)unal,  /* length of string which follows    */
  92       2 str         char (rep.len),     /*  literal data if needed           */
  93       2 next        char (1);           /* where next part is based          */
  94 
  95 
  96 dcl ioa_            entry options (variable);
  97 dcl (ioa_$ioa_switch,
  98      ioa_$ioa_switch_nnl) entry options (variable);
  99 dcl (
 100      addr, fixed, index, length, min, null, string, substr, unspec, verify
 101      )              builtin; %page;
 102 /**** <<<<----- dcl_tedsrch_.incl.pl1 tedsrch_$init_exp                      */
 103 init_exp:                               /* initialize an expression area     */
 104     entry (acreg_p, ain_l);
 105 /*dcl (                                                                      */
 106 /*  acreg_p         ptr,                /* -> compiled expression area  [IN] */
 107 /*  ain_l           fixed bin (21)      /*   length of area in words         */
 108 /*  )               parm;               /* ----->>>>                         */
 109 
 110       re_p = acreg_p;
 111       re.maxl = (ain_l - 3) * 4;
 112       re.len = 0;
 113       string (re.sws) = ""b;
 114       return;%skip(4);
 115 /**** <<<<----- dcl_tedsrch_.incl.pl1 tedsrch_$compile                       */
 116 compile:                                /* compile a regular expression      */
 117    entry (ain_p, ain_l, acreg_p, astrmode, alitmode, msg, acode);
 118 dcl (
 119     ain_p           ptr,                /* -> regular expression to search   */
 120     ain_l           fixed bin (21),     /*   length thereof                  */
 121     acreg_p         ptr,                /* -> compiled expression area  [IN] */
 122     astrmode        bit (1)aligned,     /* 0- line mode     1- string mode   */
 123     alitmode        bit (1)aligned,     /* 0- reg expr      1- literal expr  */
 124     msg             char (168) var,     /* error message               [OUT] */
 125     acode           fixed bin (35)      /* error status code           [OUT] */
 126     )               parm;               /* ----->>>>                         */
 127 
 128       re_p = acreg_p;
 129       acode = 0;
 130       in_p = ain_p;
 131       in_l = ain_l;
 132 
 133       re.len = 0;                       /* no regular expression             */
 134       re.flag = FLAG;
 135       rep_p = addr (re.parts);
 136       lrep_p = null();
 137       rep.len = 0;
 138       call start_sub_expression (STR_1);
 139 %skip(2);
 140       if alitmode                       /* the whole expr is used as-is      */
 141       then do;
 142          i = 1;                         /* since the hole might be in the    */
 143                                         /*  middle of the area to be         */
 144                                         /*  searched, all searchs will be    */
 145                                         /*  broken following NLs.            */
 146 get_more:
 147          ii = index (substr (in_s, i), NL);
 148          if (ii = 0)
 149          then ii = in_l - i + 1;
 150          rep.len = ii;
 151          rep.str = substr (in_s, i, rep.len);
 152          if (ii = 0)
 153          then goto all_done;
 154          call start_sub_expression (STR);
 155          goto get_more;
 156       end;
 157 
 158       concealsw = ""b;                  /* init concealment switch           */
 159       re.strmode = astrmode;            /* save current line/string mode     */
 160       re.NL_sw = "1"b;                  /* assume literal NL                 */
 161       do i = 1 to in_l;                 /* pre-process and copy regexp       */
 162          ch = in_c (i);                 /* pick up a char from expression    */
 163          if concealsw
 164          then do;
 165             concealsw = ""b;            /* reset concealment switch          */
 166             goto tstar;                 /* process char as normal char       */
 167          end;%skip(2);
 168          if (ch = "^") & (i = 1)        /* if "^" 1st char in the regexp     */
 169          then do;
 170             ch = NL;                    /* replace with NL if so             */
 171             rep.typ = I_STR;            /* TYPE:  /^string   /               */
 172             goto move_ch;               /* place new-line in sub-expression  */
 173          end;                           /*  in place of "^"                  */
 174          if (ch = "$") & (i = in_l)     /* check for "$", as last char */
 175          then do;
 176             ch = NL;                    /* replace with NL if so             */
 177             re.NL_sw = ""b;
 178          end;%skip(2);
 179          if (ch = "\")
 180          then do;
 181             ch1 = in_c (i + 1);
 182             unspec (ch1) = unspec (ch1) | "000100000"b;   /* make lowercase  */
 183             if (ch1 = "c")              /* "\c"                              */
 184             then do;
 185                i = i + 1;
 186                concealsw = "1"b;
 187                goto skip;
 188             end;
 189             if (ch1 = "x")
 190             then if (in_c (i + 2) = "[")
 191             then do;                    /* expression extention              */
 192                i = i + 3;
 193                call extention;
 194                goto skip;
 195             end;
 196          end;%skip(2);
 197          if (ch = ".")                  /* special regexp ctl char           */
 198          then do;
 199             if (i < in_l)
 200             then if (in_c (i + 1) = "*")
 201             then do;                    /*  ".*"                             */
 202                i = i + 1;               /* yes, skip over it                 */
 203                call start_sub_expression (DOTSTAR);
 204                lb, ub = 0;
 205                goto skip;               /* skip to end of loop               */
 206             end;
 207             if (rep.typ = DOTSTAR) & (rep.len = 0)  /* ".*."                 */
 208             then next_type = DOTSTAR;
 209             else next_type = STR;
 210 dcl next_type       fixed bin;
 211             call start_sub_expression (DOT);
 212             rep.len = 1;
 213             rep.str = ".";
 214             lb = verify (substr (in_s, i), ".")-1;
 215             if (lb < 0)
 216             then lb = in_l - i + 1;
 217             ub = lb;
 218             i = i + ub - 1;
 219             call start_sub_expression (next_type);
 220             goto skip;                  /* skip to end of loop               */
 221          end;
 222          if (ch = "*")
 223          then do;
 224             if (lrep_p = null ())
 225             then do;
 226 no_star_char:
 227                msg = "R??) No char for * to apply to.";
 228                goto err_exit;
 229             end;
 230             if (lrep_p -> rep.typ = STAR)
 231             | (lrep_p -> rep.typ = NOT_CHAR)
 232             | (lrep_p -> rep.typ = DOTSTAR)
 233             then goto no_star_char;
 234             if (lrep_p -> rep.typ = DOT)
 235             then do;
 236                rep_p = lrep_p;
 237                rep.typ = DOTSTAR;
 238                rep.lbd = rep.lbd - 1;
 239                rep.ubd = 0;
 240                rep.len = 0;
 241                goto skip;
 242             end;
 243             if (lrep_p -> rep.typ = I_STR) & (lrep_p -> rep.len = 1)
 244             then goto no_star_char;
 245             if (lrep_p -> rep.len = 1)
 246             then do;
 247                lrep_p -> rep.typ = STAR;
 248                goto skip;
 249             end;
 250 /**** Whats left at this point is STR_1, I_STR or STR with more than 1 char  */
 251             rep_p = lrep_p;
 252             ch = substr (rep.str, rep.len, 1);
 253             rep.len = rep.len - 1;
 254             call start_sub_expression (STAR);
 255             rep.len = 1;
 256             rep.str = ch;
 257             call start_sub_expression (STR);
 258             goto skip;
 259          end;
 260 tstar:
 261          if (i < in_l)
 262          then if (in_c (i + 1) = "*")
 263               then do;                  /* check for char followed by "*"    */
 264                  i = i + 1;             /*  skip over it                     */
 265                  call start_sub_expression (STAR);
 266                  lb, ub = 0;            /* ub=0 --> no-limit                 */
 267                  rep.len = 1;
 268                  rep.str = ch;
 269                  do ii = (i + 1) to in_l /* pick up following ch's           */
 270                     while (in_c (ii) = ch);
 271                     if (ii < in_l)
 272                     then if (in_c (ii + 1) = "*")
 273                     then goto skp2;
 274                     i = i + 1;          /* skip over ch                      */
 275                     rep.lbd = rep.lbd + 1; /* raise minimum                  */
 276                     lb = lb + 1;                                      /* #150*/
 277                  end;
 278 skp2:
 279                  call start_sub_expression (STR);
 280                  goto skip;             /* skip to end of loop               */
 281               end;
 282               if (rep.typ = DOT)
 283               then call start_sub_expression (STR);
 284 move_ch:
 285               rep.len = rep.len + 1;    /* normal char not followed by "*",  */
 286               substr (rep.str, rep.len, 1) = ch;
 287               if (ch = NL)              /* Due to the gap, NLs may require   */
 288               then do;                  /* ..special handling.               */
 289                  if (rep.len = 1) & (rep.typ = I_STR)
 290                  then;                  /* Not if its from "/^"              */
 291                  else if re.NL_sw       /* ..or from "$/"                    */
 292                  then call start_sub_expression (STR);
 293                                         /* break the string at this point    */
 294               end;
 295 skip:
 296       end;
 297       if (rep.len = 0) & (rep.typ = DOTSTAR)      /* TYPE:  /   .* <nil> /   */
 298       then do;
 299          rep.typ = DOTSTARnil;
 300          rep.len = 1;
 301          rep.str = NL;
 302          re.NL_sw = ""b;
 303       end;
 304 all_done:
 305       call start_sub_expression (MATCH);
 306       re.len = re.len + 4;
 307       if db_srch
 308       then call dump_entry (re.len);
 309       return;%page;
 310 /**** <<<<----- dcl_tedsrch_.incl.pl1 tedsrch_$search                        */
 311 search:                                 /* search for expression             */
 312    entry (acreg_p, abp, asi, ase, ami, ame, ame2, msg, acode);
 313 dcl (
 314 /****acreg_p        ptr,                /* -> compiled expression            */
 315     abp             ptr,                /* -> buffer ctl block for file      */
 316     asi             fixed bin (21),     /* beginning of string to search     */
 317     ase             fixed bin (21),     /* end of string to search           */
 318     ami             fixed bin (21),     /* beginning of match                */
 319     ame             fixed bin (21),     /* end of match                      */
 320     ame2            fixed bin (21)      /* end of string used for match      */
 321 /****msg            char (168)var,      /* error message return        [OUT] */
 322 /****acode          fixed bin (35)      /* error status code           [OUT] */
 323     )               parm;               /* ----->>>>                         */
 324 
 325 dcl BOL             bit (1);            /* tells if ^x... type               */
 326       re_p = acreg_p;
 327       bp = abp;
 328       if (re.len = 0) | (re.flag ^= FLAG)
 329       then do;
 330          msg = "E/u) // undefined.";
 331          goto err_exit;
 332       end;%skip(5);
 333       BOL = ""b;
 334       part.min_left = asi;              /* Set low-water-mark.               */
 335                                         /* We will never search below this.  */
 336 %skip (2);
 337 /*                    : : : SEARCH FOR EXPRESSION : : :                      */
 338 
 339       if ""b then do;
 340 really_retry:
 341          if db_srch & lg_srch
 342          then call ioa_$ioa_switch (db_output, "<RE-TRY>");
 343       end;
 344       part.this = 0;
 345       call check_bounds;                /* setup, check for empty buffer     */
 346       if (part.cur_loc > part.right_loc)
 347       then call check_bounds;           /* search fails on empty buffer area */
 348       if ""b then do;
 349 retry:
 350          if db_srch & lg_srch
 351          then call ioa_$ioa_switch (db_output, "<re-try>");
 352 /**** from location 1 */
 353          if (first_char_matched = 0)    /* restart regexp search             */
 354          then part.cur_loc = part.cur_loc + part.left_size;
 355 /****    then part.cur_loc = part.cur_loc + 1;   changed 82-11-29            */
 356          else part.cur_loc = first_char_matched + 1;
 357          if (part.cur_loc > part.right_loc)
 358          then call check_bounds;        /* starting at next line in buffer   */
 359                                         /*  area                             */
 360 
 361       end;
 362       rep_p = addr (re.parts);
 363       rep_no = 1;
 364       first_char_matched, last_char_matched = 0; /*  nothing found yet       */
 365       ami_sw, ame_sw = ""b;
 366       if db_srch & lg_srch
 367       then call ioa_$ioa_switch (db_output, "^i|^i<^i<^i",
 368          part.min_left, part.left_loc, part.cur_loc, part.right_loc);
 369 search:
 370       type = rep.typ;                   /* get sub-expression type code      */
 371       lb = rep.lbd;
 372       ub = rep.ubd;
 373       sl = rep.len;                     /* get length of literal char string */
 374 
 375       if db_srch
 376       then do;
 377          if (rep_no = 1)
 378          then call ioa_$ioa_switch (db_output, "    #  typ,min,max,len");
 379          call ioa_$ioa_switch_nnl (db_output,
 380             "l^i,cur^i,r^i^19.1t ^i:^i^40.1t",
 381             part.left_loc, part.cur_loc, part.right_loc,
 382             first_char_matched, last_char_matched);
 383          call dump_entry (rep_no);
 384       end;
 385       if (type > max_type)
 386       then do;
 387 invalid_type:
 388          call ioa_ ("tedsrch_: Invalid type ^i", type);
 389          goto err_exit;
 390       end;
 391       mct = 0;
 392       part.left_size = part.right_loc - part.cur_loc + 1;
 393 dcl max_type        fixed bin defined Ematch;
 394       goto srch (type); %skip (3);
 395 dcl STR_1           fixed bin int static init (0) options (constant);
 396 srch (00): /**** "/string-----/"        match 1st normal string              */
 397 again_1:
 398       if (part.left_size >= rep.len)    /* enough left for string to fit?    */
 399       then j = index (substr (file_str, part.cur_loc), rep.str);
 400       else j = 0;
 401       if (j = 0)                        /* if no match, maybe search failed  */
 402       then do;
 403          call check_bounds;             /* if we come back,                  */
 404          goto again_1;                  /*  there is still more to search    */
 405       end;
 406       type = STR;                       /* if more needed, must be HERE      */
 407       goto srch_end_4; %skip (3);
 408 dcl I_STR           fixed bin int static init (1) options (constant);
 409 srch (01): /**** "/^string----/"        match 1st initial string             */
 410       BOL = "1"b;
 411 again_2:
 412       if (part.cur_loc = part.left_loc)   /* check for start of line     */
 413       then do;
 414 dcl kr char (1);
 415          if (part.left_loc = b.b_.l.le) /* if at beginning of lower part     */
 416             | (b.b_.l.re < b.b_.l.le)   /* or if no lower part at all        */
 417          then kr = NL;                  /* ..make believe a NL is before it  */
 418          else kr = b_c (b.b_.l.re);     /* otherwise take last char of lower */
 419       end;
 420       else if (part.cur_loc > part.left_loc)
 421       then kr = file_char (part.cur_loc-1);   /* take char just in front     */
 422       else do;
 423          signal condition (Error);dcl Error condition;
 424       end;
 425       if (kr ^= NL)
 426       then do;                          /* skip remainder of partial line    */
 427 find_NL_1:
 428          l = index (substr (file_str, part.cur_loc), NL);
 429          if (l = 0)                     /* COULD A LINE END UP SPLIT?        */
 430          then do;                       /* ...not supposed to (I think)      */
 431             if (part.this = 1)
 432             then do;
 433                call check_bounds;
 434                goto find_NL_1;
 435             end;
 436             call fail;                  /* no next line to search            */
 437          end;
 438          part.cur_loc = part.cur_loc + l; /* point to next line     */
 439          if (part.cur_loc > part.right_loc)
 440          then call check_bounds;        /* check for last line               */
 441       end;
 442 
 443 /**** try initial string on 1st line                                         */
 444       if (part.left_size < sl-1)        /* gotta be enough chars left        */
 445       then do;                          /* if not, regexp search failed..    */
 446          call check_bounds;             /* ..unless there is still more data */
 447          goto again_2;
 448       end;
 449       if (substr (file_str, part.cur_loc, sl-1)     /* don't use the leading */
 450          = substr (rep.str, 2, sl-1))   /* NL for this one                   */
 451       then do;
 452          j = 1;
 453       end;
 454       else do;                          /* string compare failed on 1st line */
 455          ii = 0;                        /* search remainder of buffer area   */
 456          j = index (substr (file_str, part.cur_loc), rep.str);
 457          if (j = 0)                     /* no match, regexp search failed..  */
 458          then do;
 459             call check_bounds;          /* ..unless there is still more data */
 460             goto again_2;
 461          end;
 462          j = j + 1;
 463       end;
 464       sl = sl - 1;                      /* don't include the initial NL      */
 465       goto srch_end_4; %skip (3);
 466 dcl DOTSTAR         fixed bin int static init (2) options (constant);
 467 dcl DOTSTARnil      fixed bin int static init (8) options (constant);
 468 srch (02): /****  "/---.*string/"       match next string                    */
 469 srch (08): /****  "|.*|"                match "rest"                         */
 470                                         /* find end of line containing       */
 471                                         /*  string found so far              */
 472 /**** STRING MODE .*XXX WILL NOT HACK SPANNING THE GAP                       */
 473       if ^re.strmode
 474       then do;
 475          j = index (substr (file_str, part.cur_loc), NL); /* look for NL     */
 476          if (j > 0)                     /* if none found                     */
 477          then part.left_size = j;       /* ..take all that's left            */
 478       end;
 479       if (rep.typ = DOTSTARnil)         /* this ended in .*                  */
 480       then sl = part.left_size;         /* so take all there is left         */
 481       else sl
 482          = index (substr (file_str, part.cur_loc, part.left_size), rep.str);
 483                                         /* search rest of ? for string       */
 484       if (sl <= lb)                     /* not found                     #146*/
 485 /*    if (sl = 0)                       /* not found                     #146*/
 486       then do;
 487 /**** location 1 */
 488          goto retry;                    /* .. restart regexp search          */
 489       end;
 490 /*    if (sl <= lb)                     /* not enough "dots" available?      */
 491 /*    then goto re/try;                                                      */
 492       mct = ub;                         /* found what we need                */
 493       if (rep.typ = DOTSTAR)
 494       then sl = sl + rep.len - 1;       /* the total length is the length    */
 495                                         /*  skipped over plus the length of  */
 496                                         /*  the string searched for.         */
 497       goto srch_end_3; %skip (3);
 498 dcl STR             fixed bin int static init (3) options (constant);
 499 srch (03): /****  "/---string---/"      match next literal string            */
 500                                         /* attempt to match string in place  */
 501       if (part.left_size < sl)          /* enough chars left?                */
 502       then goto keep_trying;
 503       if (substr (file_str, part.cur_loc, sl) ^= rep.str)
 504       then goto keep_trying;
 505       goto srch_end_2; %skip (3);
 506 dcl STAR            fixed bin int static init (4) options (constant);
 507 srch (04): /****  "/----x*----/"        match any occurences of a char       */
 508       ch = rep.str;                     /* get the "x" from "x*"             */
 509       if (first_char_matched > 0)       /* if match already started,         */
 510       then do;                          /* ..no special action needed.       */
 511 x_star:
 512          do sl = part.cur_loc to part.right_loc
 513             while (file_char (sl) = ch);
 514          end;
 515          sl = sl - min (part.right_loc, part.cur_loc);
 516          if (sl < lb)                   /* is minimum amount present?        */
 517          then goto retry;                                             /* #150*/
 518          mct = min (ub, sl);            /* take up to max                #150*/
 519          goto srch_end_3;
 520       end;
 521 /**** since haven't figured out how to optimize any of the initial cases,    */
 522 /****  just keep doing what has always been done.                            */
 523       goto x_star;
 524 star_x:                                 /* haven't figured out how to do     */
 525                                         /*  / *str/ yet                      */
 526                                         /*  /\[3:7" "]str/ either            */
 527                                         /*  /   *str/ is mostly here         */
 528 
 529 /*                                      /* initial matching                 * /
 530       if ^re.strmode
 531       then do;
 532          j = index (substr (file_str, part.cur_loc), NL); /* look for NL    * /
 533          if (j > 0)                     /* if none found                    * /
 534          then part.left_size = j;       /* ..take all that's left           * /
 535       end;
 536       if (lb > 0)                       /* do we need at least one?         * /
 537       then do;                          /* see if one is out there          * /
 538          sl = index (substr (file_str, part.cur_loc, part.left_size), ch);
 539          if (sl = 0)                    /* not found, no use looking in this* /
 540          then do;                       /* ..area any more                  * /
 541             part.cur_loc = part.cur_loc + part.left_size;
 542             if (part.cur_loc > part.right_loc)
 543             then call check_bounds;     /* starting at next line in buffer  * /
 544                                         /*  area                            * /
 545             goto re#try;                /* .. restart regexp search         * /
 546          end;
 547          part.cur_loc = part.cur_loc + sl - 1;
 548          goto x_star;
 549       end;
 550                                         /* min is zero                      * /
 551       trp = rep_p;                      /* lets go look at what's next      * /
 552       rep_p = addr (rep.next);
 553       if (rep.typ = STR)
 554       then do;
 555          sl = index (substr (file_str, part.cur_loc, part.left_size), rep.str);
 556          if (sl = 0)                    /* not found, no use looking in this* /
 557          then do;                       /* ..area any more                  * /
 558             part.cur_loc = part.cur_loc + part.left_size;
 559 try_again:
 560             if (part.cur_loc > part.right_loc)
 561             then call check_bounds;     /* starting at next line in buffer  * /
 562                                         /*  area                            * /
 563             goto re#try;                /* .. restart regexp search         * /
 564          end;
 565          sl = sl - 1;
 566          if (sl < lb)                   /* did we even pass over enough     * /
 567          then do;                       /* ..characters?                    * /
 568             part.cur_loc = part.cur_loc + sl; /* ..No                       * /
 569             goto try_again;
 570          end;
 571 
 572          part.cur_loc = part.cur_loc + sl - 1;
 573          goto x_star;
 574       end;
 575       if (part.left_size < sl)          /* enough chars left?               * /
 576       then goto keep_trying;
 577       goto srch_end_2;*/%skip (3);
 578 dcl DOT             fixed bin int static init (5) options (constant);
 579 srch (05): /****  "/---\x[n.]---/"      match specific number of any char    */
 580 /****            "/---.---/" "/---.....---/"                                 */
 581       if (part.left_size < lb)          /* is that enough?                   */
 582       then do;
 583          call fail;                     /* HANDLE split & stringmode */
 584       end;
 585       if (ub = 0)
 586       then ub = part.left_size;
 587       sl = min (part.left_size, ub);
 588       if ^re.strmode                    /* in linemode "." may not match     */
 589       then do;                          /* ..a NL                            */
 590          j = index (substr (file_str, part.cur_loc, sl), NL) -1;
 591          if (j >= 0)
 592          then sl = j;
 593          if (sl < lb)
 594          then goto really_retry;
 595       end;
 596       mct = ub;
 597       goto srch_end_3; %skip (3);
 598 dcl NOT_CHAR        fixed bin int static init (6) options (constant);
 599 srch (06): /****  "/---\x[^"c"]---/"    match absence of a char              */
 600       if (substr (file_str, part.cur_loc, 1) = rep.str)
 601       then goto keep_trying;
 602       goto srch_end_2; %skip (3);
 603 dcl XX              fixed bin int static init (7) options (constant);
 604 srch (07): /****  "/^\x[^"c"]---/"      match absence of a char initially    */
 605       if XX=XX then
 606       goto invalid_type;%skip (3);
 607 dcl Bmatch          fixed bin int static init (9) options (constant);
 608 srch (09): /****  "/---\x[<]---/"       begin the match here                 */
 609       ami = part.cur_loc;
 610       ami_sw = "1"b;
 611       goto srch_end_0;%skip (3);
 612 dcl Ematch          fixed bin int static init (10) options (constant);
 613 srch (10): /****  "/---\x[>]---/"       end the match here                   */
 614       ame = last_char_matched;
 615       ame_sw = "1"b;
 616       goto srch_end_0;%skip (3);
 617 srch_end_4:
 618       part.cur_loc = part.cur_loc + j - 1;
 619 srch_end_3:
 620       if (first_char_matched = 0)
 621       then do;
 622          first_char_matched = part.cur_loc;
 623          part.min_left = first_char_matched + 1;  /* not go below here again */
 624       end;
 625 srch_end_2:
 626       last_char_matched = part.cur_loc + sl - 1;
 627       part.cur_loc = last_char_matched + 1;
 628 srch_end_0:
 629       mct = mct + 1;
 630       if db_srch & lg_srch
 631       then do;
 632 dcl lgl             fixed bin (21);
 633          lgl = last_char_matched - first_char_matched + 1;
 634          call ioa_$ioa_switch (db_output,
 635             "^i,^i,^i ^i:^i ""^va""", lb, mct, ub,
 636             first_char_matched, last_char_matched, lgl,
 637             substr (file_str, first_char_matched, lgl));
 638       end;
 639       if (mct < lb)
 640       then goto srch (type);
 641       if ""b
 642       then do;
 643 keep_trying:
 644          if (mct < lb)
 645          then goto really_retry;
 646          ub = mct;                      /* Got here because min have been    */
 647                                         /*  found, max have not. Must make   */
 648                                         /*  it be a success.                 */
 649       end;
 650       if (mct < ub)
 651       then goto srch (type);
 652       rep_p = addr (rep.next);          /* move to next sub-expression       */
 653       rep_no = rep_no + 1;
 654       if (rep.typ ^= MATCH)
 655       then do;
 656          if (part.cur_loc > part.right_loc)
 657          then do;                       /* search until specified buffer     */
 658             call check_bounds;          /*  area exhausted                   */
 659          end;
 660          goto search;
 661       end;
 662 dcl MATCH           fixed bin int static options (constant) init (-1);
 663                                         /* end of expr, match succeeds       */
 664       ame2 = last_char_matched;
 665       if ^re.strmode                    /* if line mode                      */
 666          & ^re.NL_sw                    /*  and "$" was used                 */
 667          & (last_char_matched >= first_char_matched) /* and not null string  */
 668       then if (file_char (last_char_matched) = NL) /* last char NL, don't    */
 669            then last_char_matched = last_char_matched - 1;   /* inc in match */
 670       if db_srch
 671       then call ioa_$ioa_switch (db_output,
 672          "^-[^d:^d ^d:^d] ^d^[(^d:^d)^;:^2s^]^d",
 673          b.b_.l.le, b.b_.l.re, b.b_.r.le, b.b_.r.re,
 674          first_char_matched, ami_sw|ame_sw, ami, ame, last_char_matched);
 675       if ^ami_sw
 676       then ami = first_char_matched;
 677       if ^ame_sw
 678       then ame = last_char_matched;
 679       if BOL & (ame = ame2)             /* make sure s/^...// doesn't wipe   */
 680       then ame2 = ame2 + 1;             /* ..whole line                      */
 681       acode = 0;                        /* tell caller match found           */
 682 
 683 exit:
 684       return;
 685 err_exit:
 686       acode = 2;
 687       return;
 688 
 689 fail: proc;                             /* made a proc so I can find out     */
 690                                         /*  where a fail came from.          */
 691       acode = 1;                        /* here if regexp search failed      */
 692       if db_srch
 693       then call ioa_$ioa_switch (db_output,
 694          "^-[^d:^d ^d:^d] X:X",
 695          b.b_.l.le, b.b_.l.re,
 696          b.b_.r.le, b.b_.r.re);
 697       goto exit;
 698    end fail;%skip(3);
 699 start_sub_expression: proc (new_type);
 700 
 701 dcl new_type        fixed bin;
 702 
 703       if (rep.len ^= 0)                 /* if sub-expression outstanding     */
 704       then do;
 705          rep.lbd = lb;
 706          rep.ubd = ub;
 707          re.len = re.len + rep.len + 4;
 708          if db_srch
 709          then call dump_entry (re.len);
 710          lrep_p = rep_p;
 711          rep_p = addr (rep.next);
 712       end;
 713       rep.len = 0;
 714       lb, ub = 1;
 715       rep.typ = new_type;
 716 
 717    end start_sub_expression;%page;
 718 extention: proc;                        /* data inside \x[  ]                */
 719 
 720 /* =========================================================================
 721                        extention definition & wishlist
 722     tedread_ptr_ converts these obsolete forms into the described form:
 723           \[n]x    => \x[n"x"]
 724           \[n].    => \x[n.]
 725           \[n]\c.  => \x[n"."]
 726 
 727    metalanguage used:
 728           1) comments are inside {}'s.
 729           2) <form...> means any number of <form>'s
 730           3) <[min]>   means an optional <min> }
 731    =========================================================================
 732 
 733 extention ::= \[ <form...> ]
 734 
 735 <form>    ::= <[min]> <[max]> <element>
 736             | <element> *     {a* => 0:a}
 737 
 738 <min>     ::= <digits>        {min # wanted, default: 1}
 739 <max>     ::= : <digits>      {max # wanted, default: min}
 740             | :               {infinite # OK}
 741 
 742 <element> ::= " <char...> "   {match a string}
 743             |   <set>         {test for char being a member of a set}
 744             | ^ <set>         {test for char NOT in a set (NYA)}
 745 
 746 <set>     ::= <simple>        {use a simple set}
 747             | s( <simple'...> ){build a compound set (NYA) }
 748 
 749 <simple'> ::= " <char...> "   {each char is added to the set}
 750             |   <simple>      {each implied char is added to the set}
 751             | ^ <simple>      {each implied char is removed from the set}
 752             | ^ " <char> "    {the char is removed from the set}
 753 
 754 <simple>  ::= .               {everything but NL (unless string mode)}
 755             | p               {printable                    NYA}
 756             | w               {whitespace(SP HT FF VT)      NYA}
 757             | u               {uppercase                    NYA}
 758             | l               {lowercase                    NYA}
 759             | a               {upper+lower+"_"              NYA}
 760             | x               {hex degit                    NYA}
 761             | d               {decimal digit                NYA}
 762             | o               {octal digit                  NYA}
 763             | b               {binary digit                 NYA}
 764             |
 765    ========================================================================= */
 766 
 767 dcl (llb, lub)      fixed bin;          /* local lower/upper bounds          */
 768 dcl beg_num         fixed bin;
 769 dcl not_sw          bit (1);
 770 
 771 loop:
 772       i = i + verify (substr (in_s, i), " ") - 1;
 773       if (in_c (i) = "]")
 774       then do;
 775          call start_sub_expression (STR);
 776          return;
 777       end;
 778       call start_sub_expression (MATCH);/* flush pending expression          */
 779       llb, lub = -2;                    /* set "empty"                       */
 780 /**** lower bound number                                                     */
 781       beg_num = i;
 782       ii = verify (substr (in_s, i), "0123456789") - 1;
 783       if (ii > 0)
 784       then do;
 785          llb, lub = fixed (substr (in_s, i, ii));
 786          if (lub = 0)
 787          then lub = -1;                 /* set "zero-seen"                   */
 788          i = i+ii;
 789          i = i + verify (substr (in_s, i), " ") - 1;
 790       end;
 791 /**** upper bound number                                                     */
 792       if (in_c (i) = ":")
 793       then do;
 794          i = i + 1;
 795          if (llb = -2)
 796          then llb = 1;
 797          lub = 0;                       /* init to infinity                  */
 798          i = i + verify (substr (in_s, i), " ") - 1;
 799          ii = verify (substr (in_s, i), "0123456789") - 1;
 800          if (ii > 0)
 801          then do;
 802             lub = fixed (substr (in_s, i, ii));
 803             i = i + ii;
 804             i = i + verify (substr (in_s, i), " ") - 1;
 805          end;
 806       end;
 807 /**** active term                                                            */
 808       ch = in_c (i);
 809       if (ch = "^")
 810       then do;
 811          i = i + 1;
 812          i = i + verify (substr (in_s, i), " ") - 1;
 813          ch = in_c (i);
 814          not_sw = "1"b;
 815       end;
 816       else not_sw = ""b;
 817       if (ch = ".")
 818       then do;
 819          if not_sw
 820          then do;
 821             msg = "Rnd) ""^."" is meaningless";
 822 x_exit:
 823             msg = msg || " in \x[]. """;
 824             msg = msg || substr (in_s, 1, i);
 825             msg = msg || """";
 826             goto err_exit;
 827          end;
 828          if (lub ^= -1)
 829          then do;
 830             call start_sub_expression (DOT);
 831             rep.len = 1;
 832             rep.str = ".";
 833          end;
 834          i = i + 1;
 835          i = i + verify (substr (in_s, i), " ") - 1;
 836       end;
 837       else if (ch = """")
 838       then do;
 839          if (re.len = 0)
 840          then next_type = STR_1;        /* first match                       */
 841          else next_type = STR;          /* continuing match                  */
 842          call start_sub_expression (next_type);
 843 more_str:
 844          i = i + 1;
 845          ii = index (substr (in_s, i), """") - 1;
 846          j = rep.len;
 847          rep.len = rep.len + ii;
 848          substr (rep.str, j+1, ii) = substr (in_s, i, ii);
 849          i = i + ii + 1;
 850          if (in_c (i) = """")
 851          then do;
 852             rep.len = rep.len + 1;
 853             substr (rep.str, rep.len, 1) = """";
 854             goto more_str;
 855          end;
 856          if not_sw
 857          then do;
 858             if (rep.len ^= 1)
 859             then do;
 860                msg = "Rnc) ""^"" cannot apply to multi-char string";
 861                goto x_exit;
 862             end;
 863             rep.typ = NOT_CHAR;
 864          end;
 865       end;
 866       else if (ch = "<")
 867       then do;
 868          if (lrep_p ^= null())          /* ignore if first, that's what      */
 869          then do;                       /* ..you get anyway                  */
 870             call start_sub_expression (Bmatch);
 871             call no_min_max ("<");
 872             i = i + 1;
 873             rep.len = 1;
 874             rep.str = "<";
 875          end;
 876       end;
 877       else if (ch = ">")
 878       then do;
 879          call start_sub_expression (Ematch);
 880          call no_min_max (">");
 881          i = i + 1;
 882          rep.len = 1;
 883          rep.str = ">";
 884       end;
 885       else do;
 886          msg = "Ruc) Unknown char";
 887          goto x_exit;
 888       end;
 889 /**** "*" operator, cannot exist with [nn][:nn]                              */
 890       i = i + verify (substr (in_s, i), " ") - 1;
 891       if (in_c (i) = "*")
 892       then do;
 893          call no_min_max ("*");
 894          if (rep.typ = DOT)
 895          then do;
 896             msg = "Rds) "".*"" not allowed";
 897             goto x_exit;
 898          end;
 899          else llb, lub = 0;             /* set 0:infinity                    */
 900          i = i + 1;
 901       end;
 902 /**** set default bounds if needed                                           */
 903       if (llb = -1)
 904       then llb = 1;
 905       if (lub = -1)
 906       then lub = llb;                   /* llb > lub is ERROR                */
 907       lb = llb;                         /* llb/lub perhaps not needed        */
 908       ub = lub;
 909       goto loop;
 910 
 911 no_min_max: proc (chr);
 912 dcl chr char (1);
 913          if (llb ^= -1) | (lub ^= -1)
 914          then do;
 915             msg = "Rcs) ""nn:nn values incompatable with """;
 916             msg = msg || chr;
 917             msg = msg || """. ";
 918             goto x_exit;
 919          end;
 920       end no_min_max;
 921    end extention;%page;
 922 dis_exp: entry (acreg_p);               /* redisplay compiled expression     */
 923 
 924 
 925 
 926       re_p = acreg_p;
 927 
 928       call ioa_$ioa_switch (db_output,
 929          "^[^14p^;^s^].   #RE len=(^i)^i^[ NL_sw^;^]^[ strmode^;^]
 930 ^[^14x^]    #  typ,min,max,len", db_gv, re_p, re.maxl, re.len, NL_sw, strmode,
 931          db_gv);
 932 
 933       if (re.len = 0) | (re.flag ^= FLAG)
 934       then return;
 935       rep_no = 1;
 936       rep_p = addr (re.parts);
 937 more:
 938       call dump_entry (rep_no);
 939       if (rep.typ ^= MATCH)
 940       then do;
 941          rep_p = addr (rep.next);
 942          rep_no = rep_no + 1;
 943          goto more;
 944       end;
 945       return;%page;
 946 check_bounds: proc;
 947 /**** In these 3 cases, the As represent the address range.                  */
 948 /**** Case 0:     (empty)                                                    */
 949 /**** Case 1: xxAAAxxx...xxxxx          not split                            */
 950 /**** Case 2: xxxxxAAA...Axxxx          split                                */
 951 /**** Case 3: xxxxxxxx...xAAAx          not split                            */
 952 
 953 /**** part.this = 2 does not mean you are processing in the upper part. It   */
 954 /**** means that you are either in the right of a split range or the range   */
 955 /**** is not split at all.                                                   */
 956 
 957       if (part.this = 0)
 958       then do;                          /* nowhere yet                       */
 959          if (b.cur.sn = 0)              /* buffer is empty?                  */
 960          then call fail;
 961          if (part.min_left = b.b_.l.re + 1) /* if just above lower,          */
 962          then do;                       /* ..switch to upper                 */
 963             if (b.b_.r.re < b.b_.r.le)  /* ..unless upper is empty.          */
 964             then call fail;
 965             part.min_left = b.b_.r.le;
 966          end;
 967          part.cur_loc = part.min_left;  /* start by assuming string is       */
 968          part.this = 2;                 /* ..not split                       */
 969          part.right_loc = ase;
 970 
 971          if (part.min_left <= b.b_.l.re) /* string start in lower part?      */
 972          then do;                       /* --YES                             */
 973             part.left_loc = b.b_.l.le;  /* set left end to lower part        */
 974             if (ase > b.b_.l.re)        /* string extend out of lower part?  */
 975             then do;                    /* --YES                             */
 976                part.right_loc = b.b_.l.re; /* set right end to end of lower  */
 977                part.this = 1;           /* indicate there's another to go    */
 978             end;
 979          end;
 980          else do;
 981             part.left_loc = b.b_.r.le;
 982          end;
 983          part.min_left = part.min_left + 1;  /* prevent loop on re-try       */
 984       end;
 985       else if (part.this = 1)           /* have been operating in 1st part   */
 986          & (b.b_.r.le <= b.b_.r.re)     /* & upper part isn't empty          */
 987       then do;
 988          part.left_loc,
 989             part.cur_loc = b.b_.r.le;   /* continue in the 2nd part          */
 990          part.right_loc = ase;
 991          part.left_size = part.right_loc - part.cur_loc + 1;
 992          part.this = 2;
 993          return;
 994       end;
 995       else                              /* have been operating in 2nd part   */
 996          call fail;                     /*   nowhere to go from here         */
 997       if db_srch
 998       then call ioa_$ioa_switch (db_output,
 999          "min=^i(^i)l^i,cur^i,r^i", part.min_left, part.this,
1000          part.left_loc, part.cur_loc, part.right_loc);
1001       return;
1002 
1003    end check_bounds; %page;
1004 
1005 dump_entry: proc (num);
1006 
1007 dcl num             fixed bin;
1008 
1009 dcl (i, ndx)        fixed bin;
1010 dcl ch              char (1);
1011 dcl result          char (256)var;
1012 /* format: off */
1013 dcl mark            (-2:17) char (8) int static options (constant) init (
1014 /* -1 */            "!/",     "",
1015 /*  0 */            "/",      "!",
1016 /*  1 */            "/^",     "!",
1017 /*  2 */            "!.*",    "!",
1018 /*  3 */            "!",      "!",
1019 /*  4 */            "!",      "*!",
1020 /*  5 */            "!.!",    "",
1021 /*  6 */            "!NOT""", """",
1022 /*  7 */            "!/^NOT""","""",
1023 /*  8 */            "!.*<NIL>","!");
1024 /* format: on */
1025 
1026          ndx = rep.typ * 2;
1027          call ioa_$ioa_switch_nnl (db_output,
1028             "^[^14p^;^s^]    #^2i^2i ^3i,^3i,^3i ^a", db_gv,
1029             rep_p, num, rep.typ, rep.lbd, rep.ubd, rep.len, mark (ndx));
1030          ndx = ndx + 1;
1031          if (mark (ndx) ^= "")
1032          then do;
1033             result = "";
1034             do i = 1 to rep.len;
1035                if (length (result) > 250)
1036                then do;
1037                   call ioa_$ioa_switch_nnl (db_output,
1038                      "^va", length (result), result);
1039                   result = "";
1040                end;
1041                ch = substr (rep.str, i, 1);
1042                if (ch = NL)
1043                then result = result || "\NL";
1044                else if (ch = "          ")
1045                then result = result || "\HT";
1046                else if (ch = "\")
1047                then result = result || "\\";
1048                else result = result || ch;
1049             end;
1050             call ioa_$ioa_switch_nnl (db_output,
1051                "^va", length (result), result);
1052          end;
1053          call ioa_$ioa_switch (db_output,
1054             mark (ndx));
1055 
1056 end dump_entry;
1057 
1058 
1059 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
1060 
1061 %include tedcommon_;
1062 %include tedbcb;
1063 %include tedbase;
1064 
1065    end tedsrch_;