1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    *********************************************************** */
  6 
  7 /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16            */
  8 /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
  9 /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
 10 /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
 11 
 12 proc_expr:                              /* process the expression for global execution */
 13    proc (ted_support_p, msg, code);     /* of an external function           */
 14 
 15 dcl msg             char (168) var,
 16     code            fixed bin (35);
 17 
 18       code = 0;
 19       if db_glob
 20       then call ioa_ (">proc rchr(^i)=`^1a' de=^i", req.cc, rchr (req.cc),
 21               req.de);
 22 loop1:
 23       delim = rchr (req.cc);            /* pick up str delimiter             */
 24       if (delim = " ")
 25       then do;
 26          req.cc = req.cc + 1;
 27          goto loop1;
 28       end;
 29       if (delim = NL)
 30       then do;
 31          code = tederror_table_$No_Delim1;
 32          return;
 33       end;
 34 
 35       expr_b = req.cc + 1;
 36       concealsw = "0"b;
 37       do req.cc = req.cc + 1 to req.de; /* try to find end of str1      */
 38          if ^concealsw
 39          then do;
 40             ch = rchr (req.cc);
 41             if (ch = delim)
 42             then goto sub1;
 43             if (ch = "\")
 44             then do;
 45                if (rchr (req.cc + 1) = "c")
 46                   | (rchr (req.cc + 1) = "C")
 47                then do;
 48                   req.cc = req.cc + 1;
 49                   concealsw = "1"b;
 50                end;
 51             end;
 52          end;
 53          else concealsw = "0"b;
 54       end;
 55 
 56       code = tederror_table_$No_Delim2; /*  no end of string                 */
 57       return;
 58 
 59 sub1:
 60       expr_l = req.cc - expr_b;
 61       if (expr_l > 0)
 62       then call tedsrch_$compile (addr (rchr (expr_b)), expr_l,
 63               ted_support.reg_exp_p, (ted_support.string_mode), ""b, msg, code);
 64 
 65 /* req.nc now points to 2nd delim    */
 66 
 67       if db_glob
 68       then call ioa_ ("<proc rchr(^i)=`^1a' de=^i", req.cc, rchr (req.cc),
 69               req.de);
 70       return; %page;
 71 do_global:                              /* globally execute some function    */
 72    entry (worker, mode, ted_support_p, msg, code);
 73 
 74 dcl worker          entry (),           /* routine to do all the work        */
 75     mode            char (1);           /* "g" or "v"                        */
 76 
 77       code = 0;
 78       xsw = (mode = "v");
 79       gb_sb = inp.sb;
 80       gb_se = inp.se;
 81       if db_glob
 82       then call ioa_ (">do sb=^i se=^i ln=^i", inp.sb, inp.se, inp.lno);
 83 gb_loop:
 84       inp.sb = gb_sb;
 85       i = index (                       /* then find end of it               */
 86          substr (istr, gb_sb, gb_se - gb_sb + 1), NL);
 87       if (i = 0)                        /* worry about no NL at EOB          */
 88       then inp.se = gb_se;
 89       else inp.se = gb_sb + i - 1;
 90       if db_glob
 91       then call ioa_ ("-do sb=^i se=^i ln=^i", inp.sb, inp.se, inp.lno);
 92       gb_sb = inp.se + 1;               /* keep beginning of next line..     */
 93                                         /* search line for REGEXP            */
 94       call tedsrch_$search (ted_support.reg_exp_p, ted_support.bcb_p,
 95          inp.sb, inp.se, 0, 0, 0,       /* don't care what match was         */
 96          msg, code);
 97       if (code = 2)
 98       then do;
 99          code = tederror_table_$Error_Msg;
100          return;
101       end;
102       if xsw = (code ^= 0)              /* ^match w/ exclude request         */
103       then do;                          /*  OR match w/ global request       */
104                                         /* this line is to be processed      */
105          code = 0;
106          call worker;
107          if (code ^= 0)
108          then return;
109       end;
110       else do;
111          i = inp.se - inp.sb + 1;
112          substr (ostr, out.de + 1, i) = substr (istr, inp.sb, i);
113          out.de = out.de + i;
114       end;
115       ted_support.inp.lno = ted_support.inp.lno + 1;
116       if (gb_sb <= gb_se)
117       then goto gb_loop;
118       code = 0;
119       if db_glob
120       then call ioa_ ("<do sb=^i se=^i ln=^i", inp.sb, inp.se, inp.lno);
121       return;
122 
123 dcl concealsw       bit (1);
124 dcl ch              char (1);
125 dcl delim           char (1);
126 dcl expr_b          fixed bin (21);
127 dcl expr_l          fixed bin (21);
128 dcl gb_sb           fixed bin (21);
129 dcl gb_se           fixed bin (21);
130 dcl i               fixed bin (21);
131 dcl xsw             bit (1);
132 dcl NL              char (1) int static options (constant) init ("
133 ");
134 dcl ioa_            entry () options (variable);
135 
136 %include ted_support;
137 
138 dcl 1 tedcommon_$etc ext static,
139       2 unused      fixed bin (24),
140       2 com_blank   bit (1) aligned,
141       2 com1_blank  bit (1) aligned,
142       2 caps        bit (1) aligned,
143       2 sws,
144         3 db_ted    bit (1) aligned,
145         3 db_addr   bit (1) aligned,
146         3 db_eval   bit (1) aligned,
147         3 db_sort   bit (1) aligned,
148         3 db_zproc  bit (1) aligned,
149         3 db_gv     bit (1) aligned,
150         3 db_util   bit (1) aligned,
151         3 db_srch   bit (1) aligned,
152         3 db_glob   bit (1) aligned,
153         3 db_sp1    bit (1) aligned,
154       2 not_used    fixed bin,
155       2 not_used2   bit (1) aligned,
156       2 reset_read  bit (1) aligned;
157 
158    end proc_expr;