


		    PNOTICE_ted.alm                 11/14/89  1103.9r w 11/14/89  1103.9        3555


	dec	1			"version 1 structure
	dec	2			"no. of pnotices
	dec	3			"no. of STIs
	dec	156			"lgth of all pnotices + no. of pnotices
          acc       "Copyright, (C) Honeywell Information Systems Inc., 1989"
          acc       "Copyright (c) 1989 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"C1TEDM0B0000"
	aci	"C2TEDM0B0000"
	aci	"C3TEDM0B0000"
	end
 



		    ted4.alm                        05/02/89  1148.8rew 05/02/89  1045.3       30834


" ***********************************************************
" *                                                         *
" * Copyright, (C) BULL HN Information Systems Inc., 1989   *
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1988                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(88-08-03,RWaters), approve(88-08-03,MCR7950),
"     audit(88-09-29,Huen), install(88-10-07,MR12.2-1146):
"     Changed version number to 3.2a for MR12.2.
"  2) change(89-03-29,Huen), approve(89-03-29,MCR8062),
"     audit(89-04-25,JRGray), install(89-05-02,MR12.3-1037):
"     Changed version number to 3.3a for MR12.3 .
"                                                      END HISTORY COMMENTS


;	name	tedcommon_
	use	text
				"dcl 1 tedcommon_$id ext static,
id:	dec	4		"      2 ted_vers char(12)var;
	aci	'3.3a',12,

	macro	do_def
&R3,&K&(&i:&)
	getlp
	tra	&1$&2
	segdef	&F3
	&end

do_def	ted_command_,ted,ted,ted4
do_def	ted_command_,qedx,qx,qedx
do_def	ted_command_,ted_opt,ted_opt
do_def	ted_command_,safe,safe
do_def	ted_command_,com,com
do_def	ted_command_,restart,restart
do_def	ted__,act,act,ted_act
do_def	ted__,blank,blank
do_def	ted__,noblank,noblank
do_def	ted__,partblank,partblank
do_def	ted__,passthru,passthru
do_def	ted__,clear_chars_moved,clear_chars_moved
do_def	ted__,show_chars_moved,show_chars_moved
do_def	ted__,dbn,dbn
do_def	ted__,dbf,dbf
do_def	ted__,lgn,lgn
do_def	ted__,lgf,lgf
do_def	tedutil_,set_req_line,set_req_line
do_def	tedutil_,get_req_line,get_req_line
do_def	tedmgr_,buffer,buffer,ted_buffer
do_def	tedmgr_,tedmgr_,tedmgr_
do_def	tedshow_,tedshow_,tedshow_
do_def	tedsort_,set,Jset
do_def	tedsort_,show,Jshow

"/* ted common data area		tedcommon_.incl.pl1 */
				"/* ... version.revision ... */
				"dcl 1 tedcommon_$no_data
				"	like buf_des;
no_data:	dec	0		"        3 l.ln	fixed bin (21),
	dec	1		"        3 l.le	fixed bin (21),
	dec	0		"        3 l.re	fixed bin (21),
	dec	0		"        3 r.ln	fixed bin (21),
	dec	1		"        3 r.le	fixed bin (21),
	dec	0		"        3 r.re	fixed bin (21);
	segdef	id,no_data,no_seg

				"dcl 1 tedcommon_$no_seg
				"	like seg_des,
	even
no_seg:	its	32767,1		"        3 sp	ptr,
	dec	0		"        3 sn	fixed bin,
	dec	1		"        3 pn	fixed bin,
	dec	0		"        3 ast	fixed bin,
	dec	0		"        3 mbz	fixed bin;

	use	link

				"/* ... all other variables ... */
				"dcl 1 tedcommon_$etc ext static,
etc:	oct 000000000000		"      2 com_blank bit(1)aligned,
	oct 000000000000		"      2 com1_blank bit(1)aligned,
	oct 400000000000		"      2 caps bit(1)aligned,
	oct 400000000000		"      2 reset_read bit(1);
	oct 0,0,0,0,0,0,0,0,0,0,0,0	"      2 dbsw(12)bit(1)aligned,
	oct 0,0,0,0,0,0,0,0,0,0,0,0	"      2 lgsw(12)bit(1)aligned,
	oct 0,0			"      2 (db_catch, xxxx)bit(1)aligned,
	its	32767,1		"      2 db_output ptr;
	segdef	etc		"
				"dcl 1 tedcommon_$eval ext static,
"eval:	its	32767,1		"      2 global ptr;
"	segdef	eval

	join	/link/link
	join	/text/text

	end
  



		    ted_.pl1                        05/02/89  1148.8rew 05/02/89  1041.8     1755963


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-08-03,RWaters), approve(88-08-03,MCR7950), audit(88-09-29,Huen),
     install(88-10-07,MR12.2-1146):
     Bug fixes for MR12.2.
  2) change(89-03-29,Huen), approve(89-03-29,MCR8062), audit(89-04-25,JRGray),
     install(89-05-02,MR12.3-1037):
     Fix bug 160: Modify ted to ignore trailing whitespace after a quit
     request.
  3) change(89-03-29,Huen), approve(89-03-29,MCR8079), audit(89-04-25,JRGray),
     install(89-05-02,MR12.3-1037):
               Fix bug 210: Modify ted to ltrim on the "help" request.
               Fix bug 208: Modify ted to ignore leading <TAB> characters.
               Fix bug 207: Modify ted to extend "help" request to work in
     "f" request.
                                                   END HISTORY COMMENTS */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

/*							       */
/*   _|_              |					       */
/*    |      _      _ |					       */
/*    |     / \    / \|					       */
/*    |    (__/   (   |					       */
/*    \_    \_/    \_/|					       */
/*                       -----				       */
/*							       */

/* ted is an editor based on qedx.  There have been extensive changes and    */
/*  additions						       */
/* ted	06/01/72	James Falksen				       */
/* ted3	01/01/73	James Falksen				       */
/* ted4	11/01/74	James Falksen				       */
/* ted2.5 05/01/80  jaf					       */
/* ted2.6 02/25/81  jaf					       */
/*        01/05/81  jaf  added g./  / request which uses null=X value	       */
/* ted3.0 05/10/84  jaf  added db_output iocb pointer support	       */
/*		     converted from tedmrl_ to mrl_		       */

/* UPDATE HISTORY						       */
/* EL#   date	TR	comments				       */
/* 119	      phx15727 "#" doesn't always know a buffer is empty.	       */
/* 131	      phx16660 "fo",no output. "+5" knows b(o) empty, "#" doesn't  */
/* 142	      phx17283 g* "d" leaving empty buffer, "x" didn't show that   */
/* 145	      phx17343 null_ptr_ref from "y" in empty buffer	       */
/* 129 84-10-08 phx16839 handle "locked" buffers properly.		       */
/* 137 84-10-09 phx16858 make initial b0 same state as all other new buffers */
/* 140 84-10-09 phx17209 "x" on windowed buffer not show windowed size       */
/* 157 84-10-09 phx18306 pathname processing sometimes messed up. Problem    */
/*		was already fixed, but tightened things up a little.     */
/* 147 84-10-10 phx17391 recursive fileout not always handled well	       */
/* 152 84-10-11 phx17594 OOB fault on empty buffer (after [buffer X])	       */
/* 153 84-10-12 phx17665 Got a no_read_permission fault doing a "w"	       */
/* 159 84-10-12 phx15158 let ted$qedx "q" check for modified buffers	       */
/* --a 84-10-19 -------- |function doesn't get right inp.lno if first line   */
/*		of buffer is empty				       */
/* 156 84-10-19 phx18195 prohibit invoking buffer in INPUT mode and	       */
/*		modifying buffer being executed.		       */
/* 160 84-10-19 phx17878 rtrim quit request lines (incomplete fix)	       */
/* 1xx 84-11-05 -------- fixes up to this point broke m/M/k/K	       */
/* 162 85-01-11 -------- "vd/x/" leaves "." undefined if last line deleted   */
/* 191 88-08-07 phx19915,19147 print a better error message than             */
/*     'unsupported operation' when reading a non-existent file              */
/* 193 88-08-07 phx19382 tabin sometimes references thru null pointer when   */
/*	'.' is undefined and buffer is empty                               */
/* 194 88-08-07 phx19660 !f<NL> stopped working because of fix to #147       */
/* 197 88-08-07 phx19916 rtrim all error messages                            */
/* 200 88-09-07 phx20649 needed a ',' after "resetread" in 'o' request output*/
/* 201 88-09-07 phx20688 et_$no_component rather than noentry should be      */
/*	printed when talking about archive components                      */
/* 160 89-01-11 phx17878 Rtrim the "quit" request.                           */
/* 210 89-03-15 phx21267 Ltrim the "help" request.                           */
/* 208 89-03-15 phx21260 Extend the ignoring of leading spaces to include    */
/*       <TAB> character.                                                    */
/* 207 89-03-15 phx21035 Extend "help" request to work in "f" request.       */
/* END HISTORY						       */

ted__:
ted_:				/* main part of editor	       */
   proc (ated_data_p, acode) options (variable);
dcl (				/* +++++ */
    ated_data_p	ptr,		/* -> data structure	       */
    acode		fixed bin (35)	/* return code		       */
    )		parm;		/* <<>> */

dcl ted_data_p	ptr;

      ted_data_p = ated_data_p;
      if (ted_data.version ^= ted_data_version_1)
      then do;
         call ioa_ ("^a: Assuming old version of ted_data structure given.",
	    ted_data.tedname);
         ted_data.version = 1000;
      end;
      DBA = ted_data.tedname;
      ted_mode = ted_data.ted_mode;
      hold_db_output = db_output;
      if (db_output = null ())	/* make sure there is a switch for   */
      then db_output = iox_$user_output;/* ..debugging output	       */
      if db_catch
      then do;
         if (db_output = iox_$user_output)
         then do;
	  db_output = null ();	/* don't kill user_output	       */
	  call iox_$attach_name ("ted_db_output_", db_output,
	       "vfile_ ted.db_output", null (), code);
	  if (code = 0)
	  then call iox_$open (db_output, 2, ""b, code);
	  if (code ^= 0)
	  then do;
	     call iox_$detach_iocb (db_output, 0);
	     db_output = null ();
	     acode = code;
	     return;
	  end;
         end;
      end;

      if (ted_mode ^= RESTART)
      then do;
/**** A caller of ted_ may find it easier to include arguments in the call   */
/****  instead of building an argument list for arg_list_p to point to. If   */
/****  the arguments are fixed in number there is no good reason to have to  */
/****  go to that trouble. To help this out, ted_ will allow additional      */
/****  arguments to be passed to it. References to these will then be	       */
/****  plugged into the structure.				       */
         call cu_$arg_count (hold_de, code);
         if (hold_de > 2)
         then do;
	  call cu_$arg_list_ptr (ted_data.arg_list_p);
	  ted_data.arg_list_1 = 3;
	  ted_data.arg_list_n = hold_de;
         end;
      end;

      call tedinit_ (ted_data_p, dbase_p, code);
      if (code ^= 0)
      then do;
         acode = code;
         return;
      end;
      if db_catch
      then call ioa_$ioa_switch (db_output, "^/====Begin ted level ^i^/",
	      dbase.recurs);

      bp = ptr (dbase_p, cb_c_r);
      call make_consistent;
      ted_safe = (dbase.dir_db ^= "");
      if (ted_data.return_string_p = null ())
      then af_bp = null ();
      else do;
         argname = "(argn)";
         call tedget_buffer_ (dbase_p, addr (argname), length (argname),
	    af_bp, msg);
         if (af_bp = null ())
         then goto rq_err_msg;
      end;
      call tedsrch_$init_exp (addr (dbase.regexp),
	 divide (length (dbase.regexp), 4, 21, 0));
      gbp = null ();
      edit_sw = db_ted | db_trac;
      input_sw = db_ted | db_trac;
      break_sw, flow_sw = "0"b;
      old_style = "1"b;		/* allowed for now		       */

/*			 **** ***** ****			       */
/* ------------------------------------------------------------------------- */
/* Gapped standards permit a range to be split across the gap, but a line of */
/*  text cannot be split between requests.  Some requests, like "w" and "p"  */
/*  will function across the gap.  Others, like "i", or "r" will force the   */
/*  gap to the place being worked at. Except, "d" will work differently      */
/*  depending on whether when the gap is in the range or not.	       */
/* ------------------------------------------------------------------------- */

get_the_string: proc;

      if (ted_data.input_l > 0)
      then call tedpseudo_ (bp, -1, ted_data.input_p, ted_data.input_l);
      b.no_io = "1"b;
      b.dname = "<<<external string>>";
      b.ename = "";
      b.file_sw = "1"b;
      b.cname = "";
      b.kind = "";
   end get_the_string;
      msg_ptr = addrel (addr (msg), 1);
      pi_passthru = "0"b;
      maxseg = sys_info$max_seg_size * 4;
      query_info.version = query_info_version_5;
      query_info.yes_or_no_sw = "1"b;
      b.a_.l.le (0), b.a_.l.re (0) = 1; /* set current line to null	       */
      b.a_.r.le (0), b.a_.r.re (0) = addr_undef;
      gvx_p, sub_p = null ();
      if (ted_mode ^= RESTART)
      then do;
         nulreq = "p";
      end;
      else ted_mode = SAFE;
      b0_bp = bp;
      if (ted_data.input_p ^= null ())
      then call get_the_string;
      unspec (subf1) = "012014011011"b3;
      unspec (subf2) = "012012012"b3;
      qedx_mode = (DBA = "qedx");
      pi_sw, b_depth = 0;
      dbase.S_count = -1;
      app_sw, fo_sw, go_sw = "0"b;
      gvNL = ""b;
      read_sw = "1"b;
      on condition (program_interrupt)
         begin;
dcl continue_to_signal_ entry (fixed bin (35));
	  if pi_passthru
	  then call continue_to_signal_ (code);
	  else do;
	     if (pi_sw = 1)		/* are we currently accepting PIs?   */
	     then do;
	        pi_sw = 0;		/* if so, reset enable switch	       */
	        call iox_$control (iox_$user_output, "resetwrite", null (),
		   code);
	        goto pi_label;	/* goto (non-local) specified loc    */
	     end;
	     else if (pi_sw = 2)
	     then do;
	        pi_sw = 0;
	        intsw = "1"b;	/*  just indicate interrupt occurred */
	     end;
	     else if (pi_sw = 3)	/* during INPUT mode	       */
	     then do;
	        pi_sw = 0;
	        which_mode = "EOF";	/* #117*/
	        goto pi_label;
	     end;
	     else goto nx_line;
	  end;
         end;			/* PROGRAM_INTERRUPT	       */

      req_not, req_ch, req_chx = " ";
      svpath = "";			/* #157*/
      iocb_ptr = null ();

      on condition (cleanup) call cleaner;
cleaner: proc;

      if (iocb_ptr ^= null ())
      then do;
         call iox_$close (iocb_ptr, code);
         call iox_$detach_iocb (iocb_ptr, code);
      end;
      if fo_sw
      then call detach ("1"b);
      i = dbase.recurs;		/* hang on to recursion depth	       */
      call tedcleanup_ (dbase_p);
      if db_catch
      then call ioa_$ioa_switch (db_output, "^/====End ted level ^i^/", i);
      if (hold_db_output = null ()) & (db_output ^= iox_$user_output)
      then do;
         call iox_$close (db_output, code);
         if ^lg_catch
         then do;
	  call iox_$open (db_output, 2, ""b, code); /* throw away the data */
	  call iox_$close (db_output, code);
         end;
         call iox_$detach_iocb (db_output, code);
      end;
      db_output = hold_db_output;

   end cleaner;

      reset = rq_err;

      on_quit, string_sw = "0"b;
      req_not = " ";

      if (ted_data.ted_com_l > 0)
      then do;
         call tedpseudo_ (dbase.cba_p, -1, ted_data.ted_com_p,
	    ted_data.ted_com_l);
         dbase.cba_p -> b.ex.l.re = ted_data.ted_com_l;
         if db_ted
         then call tedshow_ (bp, ". rl* rl");
      end;
/**** initialize b0 with the same code as all other buffers.	   #137*/
      rl_i = 1;			/* #137*/
      rl_l = 3;			/* #137*/
      rl_s = "b0 ";			/* #137*/
      goto next;			/* #137*/
%page;
/* return here to process each new request line, from either a buffer or     */
/*  user_input (which is not ever known to the request loop).  If there is   */
/*  an error, control is returned here to cancel any unprocessed request     */
/*  line.  Comes back here from "next" is there are no more requests on the  */
/*  line.							       */

nx_line:
      req_str = "";

      err_go = " ";
      rl_i = 1;
      if go_sw			/* goto does not turn off f req      */
      then goto nx_read;
      if fo_sw
      then call detach ("0"b);
nx_read:
      if on_quit			/* is condition(quit) enabled?       */
      then do;
         if (not_read_ct < 1)		/* if there are no ^read files left  */
         then do;
	  revert quit;		/*   get rid of the quit handler     */
	  on_quit = "0"b;
         end;
      end;
      else do;			/* On the other hand, if no quit     */
         if (not_read_ct > 0)		/*  handler and there are ^read      */
         then do;			/*  files, get one established       */
	  on condition (quit)
	     begin;
	        call tedset_ck_ptr_ (dbase_p);
	        call continue_to_signal_ (code);
	     end;
	  on_quit = "1"b;
         end;
      end;
kill_read_ptr:
      pi_label = kill_read_ptr;
      pi_sw = 1;
      which_mode = "EDIT";
      call tedread_ptr_ (dbase_p, dbase.rl.sp, 0, dbase.rl.r.re, rl_l,
	 which_mode);
      pi_sw = 0;
      if (chars_moved >= 0)		/* count chars moved into request    */
      then chars_moved = chars_moved + rl_l; /* ..buffer also	       */
      if (which_mode = "\R\F")
      then goto eof_err;
      if (rl_l = dbase.rl.r.re) & (rl_c (dbase.rl.r.re) ^= NL)
      then call ioa_ ("*Request line exceeds ^i, error may follow.",
	      dbase.rl.r.re);
      if db_Ed
      then hold_db_ted = db_ted; %page;
next:
      if b.get_bit_count
	 | b.ck_ptr_sw
      then do;			/* #152*/
         call tedcheck_buffer_state_ (dbase_p, bp, msg); /* #152*/
         if (b.b_.l.le > b.b_.l.re) & (b.b_.r.le < b.b_.r.re)
         then call demote (0);	/* #152*/
      end;			/* #152*/
      if db_Ed
      then db_ted = hold_db_ted;
      b.INPUT = ""b;		/* no INPUT in progress	   #156*/
      pi_passthru = "0"b;
      if rl_i >= rl_l		/* check after each req	       */
      then goto nx_line;		/*  if request line exhausted	       */
      rl_i
	 = rl_i + verify (substr (rl_s, rl_i), " 	") - 1; /* #208*/
      if (rl_i >= rl_l)
      then goto nx_line;

      if (substr (rl_s, rl_i, 4) = "help") /* #207,210*/
      then do;
         if (rl_l = rl_i + 4)
         then do;
	  if (length (dbase.err_msg) >= 4)
	  then do;
	     substr (rl_s, rl_i, 5) = "-msg ";
	     substr (rl_s, rl_i + 5, 4) = substr (dbase.err_msg, 1, 4);
	     substr (rl_s, rl_i + 9, length (err_req)) = err_req;
	     rl_l = rl_l + 4 + length (err_req);
	     substr (rl_s, rl_l, 1) = NL;
	     rl_l = rl_l + 1;
	  end;
         end;
         else substr (rl_s, rl_i, 4) = "";
         call tedhelp_ (substr (rl_s, rl_i));
dcl tedhelp_	entry (char (*));
         goto nx_line;
      end;

      intsw = "0"b;			/* reset previous PI (if any)	       */
      if ^string_sw			/* if not in string mode	       */
      then do;
         b.a_.l.re (0) = b.a_.l.le (0); /* ignore carry-over strings	       */
         b.a_.r.le (0) = b.a_.r.re (0);
      end; %skip (4);
      req_not, req_ch, req_chx, req_str = "";
      rl_b = 0;
      bp = ptr (dbase_p, dbase.cb_c_r);
      if (index ("0123456789,;+-/.$()<?\@[]", rl_c (rl_i)) = 0)
      then do;			/* no address chars here, fake it    */
/**** don't destroy address status for option request.		       */
				/* RW 88 */
         if (rl_c (rl_i) ^= "o")
         then do;
	  b.present (1), b.present (2) = "0"b;
	  b.a_ (1) = b.a_ (0);	/*#193*/
	  goto got_add;
         end;
      end;
      used = rl_l - rl_i + 1;
      call tedaddr_ (dbase_p, addr (rl_c (rl_i)), used, bp, msg, code);
				/* find address if any	       */
      rl_i = rl_i + used;
      if (code > 3)
      then goto print_error;
      if (code = 2)
      then do;
         if (err_go ^= " ")
         then goto print_error;
         goto cm_err;
      end;
      goto got_add; %skip (5);
/*	         various and sundry error message routines	       */

dcl EOF		bit (1);
eof_err:
      msg = "Xrf) \r read \f.";

cm_err:
      code = ted_mode;		/* failure to match REGEXP	       */
      call tedend_buffer_ (dbase_p, level); /*  pop buffer stack	       */
      if level ^= 0			/* if already at request level       */
      then do;
         call tederror_ (dbase_p, msg);
         goto rq_err;		/* treat as normal error	       */
      end;
      goto nx_line;			/* resume input at next higher level */

not_allowed:
      msg = "Xna) Not allowed on this buffer. ";
      goto add_request;

err_Blv:
      msg = "Blv) Remembered >10 buffers.";
      goto add_request;

err_Bnd:
      msg = "Bnd) Can't delete current or remembered buffer.";
      goto add_request;

err_Bnr:
      msg = "Bnr) No buffer remembered.";
      goto add_request;

err_Sbd:
      msg = "Sbd) Bad decimal digit.";
      goto add_request;

err_Sd1:
      msg = "Sd1) No 1st delimiter.";
      goto add_request;

err_Sd2:
      msg = "Sd2) No 2nd delimiter.";
      goto add_request;

err_Sd3:
      msg = "Sd3) No 3rd delimiter.";
      goto add_request;

err_Sje:
      msg = "Sje) Bad sort spec.";
      goto add_request;

err_Sjk:
      msg = "Sjk) Bad key spec.";
      goto add_request;

err_Slx:
      msg = "Slx) Label exceeds 16 chars.";
      goto add_request;

err_Smp:
      msg = "Smp) Missing ).";
      goto add_request;

err_Snb:
      msg = "Snb) No blank after ";
      goto add_request;

err_Sne:
      msg = "Sne) No char for \=.";
      goto add_request;

err_Sts:
      msg = "Sts) Tabstop not in 1-200.";
      goto add_request;

err_Snf:
      msg = "Snf) No routine name supplied.";
      goto add_request;

print_error_rc:
      call tederror_rc_ (dbase_p, msg, code);
      goto rq_err;

syntax_error:
      msg = "Xse) Bad syntax for ";
add_request:
      msg = msg || " ";
      msg = msg || req_str;
      if (rl_b > 0)
      then do;
         msg = msg || " """;
         msg = msg || substr (rl_s, rl_b, rl_i - rl_b + 1);
         msg = msg || """";
      end;
print_error:
      if (rel (bp) ^= dbase.cb_c_r)	/* if working on some buffer other.. */
      then do;			/*   ..than the "current" one,       */
         msg = msg || " (in b(";	/*   ..tell them where we are.       */
         msg = msg || rtrim (b.name);
         msg = msg || "))";
      end;
rq_err_msg:
      if (msg ^= "")
      then call tederror_ (dbase_p, msg);
rq_err:
      err_req = req_str;
      if (err_go ^= " ")
      then do;
         err_gol = err_go;
dcl err_gol	char (16);
         err_go = "";
         code = 0;
         call tedset_ptr_ (dbase_p, rtrim (err_gol), code);
         if (code = 0)
         then goto nx_line;
      end;
      call tedresetread_ (dbase_p);	/* reset buffer push down stack   */
				/*  and input buffer	       */
      if (ted_mode = COM)
      then do;
         acode = tederror_table_$ted_com_abort;
				/* call com_err_ (acode, DBA);       */
         call cleaner;
         return;
      end;
      go_sw = "0"b;
      b_depth = 0;
      goto nx_line;

got_add:
      cb_w_r = rel (bp);		/* remember which we are working on  */
      if (rl_i >= rl_l)
      then ch = NL;
      else ch = rl_c (rl_i);		/* pick up first char. after address */
      alt_sw, not_sw = "0"b;
      if ch = NL
      then do;			/* if end of line		       */
         if b.present (1)		/* and "orphan" address	       */
         then do;			/* ...print line(s) referenced       */
	  if nulreq ^= "p"		/* (chose which way)	       */
	  then ch = "P";
	  else ch = "p";
         end;
         else goto nx_line;		/* ...otherwise, done with line      */
      end;
      else rl_i = rl_i + 1;		/* bump request line char. index     */

      req_ch, req_str = ch;
      req_not, req_chx = "";
      if do_req (ch)
      then goto nx_line;
      goto next;

exit:
      acode = 0;
      return;

dcl (
    NX_LIN	init ("1"b),	/* forget rest of request line       */
    NX_REQ	init ("0"b)	/* continue execution on same line   */
    )		bit (1) int static options (constant); %page;
do_req: proc (rqc) returns (bit (1));	/* returns 1 to abort request line   */
				/*         0 to continue	       */
dcl rqc		char (1);


      if (rqc < " ") | (rqc > "~") then goto invalid_request_octal;
      if ^caps
      then if (rqc >= "A") & (rqc <= "Z")
	 then goto invalid_request;
      call tedshow_$init;
      goto cmd (rank (rqc));

dcl fs_util_$suffix_info entry (char (*), char (*), ptr, fixed bin (35)); /* #--c*/
%include copy_flags; /* #--c*/
%include suffix_info; /* #--c*/
dcl 1 SI		like suffix_info;	/* #--c*/
dcl OC		(0:7) char (1) int static init
		("0", "1", "2", "3", "4", "5", "6", "7");
dcl 1 oct		based (addr (req_ch)),
      2 (A, B, C)	bit (3);


invalid_request_octal:
      msg = "Xrq) Invalid request \***.";
      substr (msg, 23, 1) = OC (fixed (oct.A, 35));
      substr (msg, 24, 1) = OC (fixed (oct.B, 35));
      substr (msg, 25, 1) = OC (fixed (oct.C, 35));
      req_str = substr (msg, 24, 4);
      goto print_error; %skip (2);
/* . . . invalid requests . . */
/* format: off */
cmd (036):		/* $  ADDR- last line of buffer	       */
cmd (038):		/* & */
cmd (040):		/* (  ADDR- begin byte address	       */
cmd (041):		/* )  ADDR- end byte address		       */
cmd (043):		/* +  ADDR- positive relative address	       */
cmd (044):		/* ,  ADDR- address separator		       */
cmd (045):		/* -  ADDR- negative relative address	       */
cmd (046):		/* .  ADDR- current location		       */
cmd (047):		/* /  ADDR- expression delimiter	       */
cmd (048):		/* 0  ADDR- linenumber/relative	       */
cmd (049):		/* 1  ADDR- "			       */
cmd (050):		/* 2  ADDR- "			       */
cmd (051):		/* 3  ADDR- "			       */
cmd (052):		/* 4  ADDR- "			       */
cmd (053):		/* 5  ADDR- "			       */
cmd (054):		/* 6  ADDR- "			       */
cmd (055):		/* 7  ADDR- "			       */
cmd (056):		/* 8  ADDR- "			       */
cmd (057):		/* 9  ADDR- "			       */
cmd (059):		/* ;  ADDR- address separator		       */
cmd (060):		/* <  ADDR- backup search marker	       */
cmd (063):		/* ?  ADDR- prefix marker		       */
cmd (064):		/* @  ADDR- absolute buffer reference	       */
cmd (065):		/* A */
cmd (066):		/* B */
cmd (067):		/* C */
cmd (068):		/* D */
cmd (071):		/* G */
cmd (073):		/* I */
cmd (078):		/* N */
cmd (079):		/* O */
cmd (086):		/* V */
cmd (089):		/* Y */
cmd (090):		/* Z */
cmd (091):		/* [  ADDR- range on search		       */
cmd (092):		/* \ */
cmd (093):		/* ]  ADDR- range on search		       */
cmd (095):		/* _ */
cmd (096):		/* ` */
cmd (125):		/* }  closing mark of evaluaton	       */
invalid_request:;			/* format: on */
      msg = "Xrq) Invalid request ";
      msg = msg || req_str;
      goto print_error; %skip (6);
/* . . . call	: call specified buffer making parameters available      */

cmd (037):			/* % */
      call ignore_both;
      call tedcall_ (dbase_p, code);
      if (code ^= 0)
      then goto rq_err;
      return (NX_LIN); %page;
/* . . . read 	: read in specified file after addressed line in buffer  */

abbrev: proc (ck_sw);
dcl ck_sw		bit (1) aligned;

      if ck_sw then call ck_blank;
      begin;
dcl hold		char (500);
dcl it		fixed bin (21);
dcl abbrev_$expanded_line entry (ptr, fixed bin (21), ptr, fixed bin (21), ptr,
		fixed bin (21));

         i = rl_l - rl_i + 1;
         substr (hold, 1, i) = substr (rl_s, rl_i, i);
         call abbrev_$expanded_line (addr (hold), i, dbase.rl.sp, 512, tbp,
	    it);
         if (tbp ^= dbase.rl.sp)
         then do;
	  msg = "Iab) Abbrev result >512.";
	  goto print_error;
         end;
         rl_i = 1;
         if (substr (rl_s, it, 1) ^= NL)
         then do;
	  it = it + 1;
	  substr (rl_s, it, 1) = NL;
         end;
         rl_l = it;
      end;			/* begin block */
   end abbrev;

cmd (082):			/* R */
      call abbrev (com1_blank);
      if ""b
      then do;
cmd (114):			/* r */
         if alt_sw
         then call abbrev ("1"b);
         else if com1_blank
         then call ck_blank;
      end;
      if ^b.present (1)		/* if no address given,	       */
      then b.a_.l.re (1), b.a_.r.le (1) = b.b_.r.re; /*  add to EOB window */
      else b.a_.l.re (1) = max (0, b.a_.r.le (1));
      call ignore_2;
      string (b.bs) = "0"b;		/* reset old-style escape seen       */
      if (b.cur.sn ^= 0)		/* if buffer not empty	       */
      then trustsw = "0"b;		/* ... then can't trust name	       */
      else trustsw = "1"b;		/* ... else can		       */
      wsw = "0"b;
      write_l = 0;
      if ^b.no_io
      then goto get_file;
      if (b.cur.sn ^= 0)		/* if buffer not empty	       */
      then goto not_allowed;		/* ..too bad		       */
      call get_the_string;
      return (NX_LIN); %page;
/* . . . write 	: write out specified contents of buffer into a file     */

cmd (087):			/* W */
      call abbrev ("1"b);
cmd (119):			/* w */
      if alt_sw
      then call abbrev ("1"b);
      else if com1_blank
      then do;			/* optional writes		       */
         if (rl_c (rl_i) = "m")
         then do;			/* write-modified request	       */
	  req_chx = "m";
	  req_str = req_str || "m";
	  rl_i = rl_i + 1;
         end;
         call ck_blank;
         if (req_chx = "m")
         then do;
	  tbi = 2;
	  call ignore_all;		/* tell 'em we won't take addr's     */
	  b.present (1), b.present (2) = "1"b; /* make sure none there     */
	  trustsw = "1"b;
	  wct = 0;
	  pi_label = write_loop_pi;
	  pi_sw = 1;
	  goto write_loop;
write_loop_error:
	  call ioa_ ("In b(^a)^/^a", b.name, substr (msg, 6));
write_loop:
	  tbi = tbi + 1;
	  if (tbi > bufnum)
	  then do;
write_loop_pi:
	     if (wct = 0)
	     then call ioa_ ("No buffers written.");
	     return (NX_REQ);
	  end;
	  bp = addr (CB (tbi));
	  if (b.cur.sn = 0) | b.no_io
	  then goto write_loop;
	  if ((b.b_.l.re - b.b_.l.le + 1) + (b.b_.r.re - b.b_.r.le + 1) = 0)
	  then goto write_loop;	/* no data		       */
	  b.a_.l.re (1) = 1;	/* write whole buffer	       */
	  b.a_.r.le (2) = b.maxl;
	  svlen = 0;
	  msg = "";
	  mustreprotect = "0"b;
         end;
      end;
      if b.no_io
      then goto not_allowed;
      if b.present (1) & ^b.present (2)
	 & (b.a_.l.re (1) = 1) & (b.a_.r.le (1) = 0)
      then write_l = 0;
      else do;
         if ^b.present (1)		/* default is whole buffer	       */
         then do;			/* ..regardless of window	       */
	  if (b.cur.sn = 0)
	  then do;
	     msg = "Abe) Buffer empty.";
	     goto print_error;
	  end;
	  b.a_.l.le (1), b.a_.l.re (1) = 1;
	  b.a_.r.le (2), b.a_.r.re (2) = b.maxl;
	  b.present (1), b.present (2) = "1"b;
         end;
         else call default$whole_buffer;
         call addr_status_ends (1, b.maxl);
         if (b.a_.l.re (1) ^= b_lhe) | (b.a_.r.le (2) ^= b_rhe)
         then trustsw = "0"b;		/* not writing whole thing	       */
         else trustsw = "1"b;
         write_l = b.a_.r.le (2) - b.a_.l.re (1) + 1;
         if (b_stat = B_LO_HI)	/* if range spans the hole, take out */
         then write_l = write_l - (b.b_.r.le - b.b_.l.re - 1); /* its size  */
      end;
      wsw = "1"b;
      if (req_chx ^= "m")
      then do;
get_file:
         subfile_name = "%%%%%";	/* to catch uninitilized uses	       */
         msg = "";
         rl_i = rl_i + verify (substr (rl_s, rl_i), " ") - 1;
         if (rl_c (rl_i) = "(")	/* its a buffer read or write	       */
         then do;
	  if wsw			/* w (x) is same as m (x) with..     */
	  then goto mo3;		/*   ..different defaults	       */
	  goto read_buffer;
         end;
         if b.no_io
         then goto not_allowed;
         mustreprotect = "0"b;
         svlen = rl_l - rl_i;		/* calc length of pathname	       */
      end;
      fd = b.file_d;		/* pull the remembered file data     */
      if (svlen = 0)		/* if no pathname supplied	       */
      then do;
         if ^fd.file_sw		/* ...do we have one saved?	       */
         then do;			/*  NO			       */
	  if (req_chx = "m")
	  then goto write_loop;
	  msg = "Inp) No pathname given.";
	  goto print_error;
         end;
         if ^fd.trust_sw		/* can we trust pathname?	       */
         then do;
	  if (ted_mode ^= COM)
	  then do;
	     query_info.status_code = 0;
	     call command_query_ (addr (query_info), answer, DBA,
		"Do you want to ^a with the untrusted pathname ^a>^a^a^a?",
		req_str, fd.dname, fd.ename, fd.kind, fd.cname);
	     if (substr (answer, 1, 1) = "y")
	     then do;
	        fd.trust_sw = "1"b;	/* looks OK from here	       */
	        if not_sw
	        then trustsw = "1"b;
	        goto accept_name;	/* (may look different there)	       */
	     end;
	  end;
	  msg = "Int) Can't trust saved pathname ";
	  call msg_path (fd.kind);
	  if (req_chx = "m")
	  then goto write_loop_error;
	  if (ted_mode = COM)
	  then goto print_error;
	  return (NX_LIN);
         end;
accept_name:
         if not_sw			/* we must force this name	       */
         then do;
	  fd.trust_sw = "1"b;	/* ...remember the fact	       */
	  fd.file_sw = "1"b;	/* ...and indicated that it is saved */
	  fd.force_name = "1"b;
	  b.file_d = fd;
	  return (NX_LIN);
         end;
         if ^trustsw		/* if we can't trust pathname after  */
         then fd.trust_sw = "0"b;	/* ...this, remember the fact	       */
         else do;
	  if ^fd.mod_sw & wsw	/* Don't write unmodified buffer     */
	       & (req_chx = "m")	/*  if wm			       */
	  then goto write_loop;
         end;
      end;			/*  (using remembered name)	       */

      else do;			/* process the supplied pathname     */
         if b.force_name & not_sw	/* don't let her change a	       */
         then do;			/* ..forced name		   #129*/
	  msg = "Ifp) Cannot change forced pathname.";
	  call msg_path (b.kind);
	  goto print_error;
         end;
         svpath = substr (rl_s, rl_i, svlen);
         fd.kind = "";
         if ^qedx_mode
         then do;
	  enl = search (reverse (svpath), "<>");
	  if (enl = 0)
	  then enl = 1;
	  else enl = length (svpath) + 2 - enl; /* #157*/
	  i = index (substr (svpath, enl + 1), "|");
	  if (i ^= 0)
	  then do;
	     i = enl + i - 1;
	     fd.kind = "|";
	     subfile_name = substr (svpath, i + 2, svlen - i - 1);
	     svpath = substr (svpath, 1, i);
	     if (svlen - i > 32)
	     then do;
	        msg = "Isn) Subfile name too long. ";
	        msg = msg || rtrim (svpath);
	        call tederror_ (dbase_p, msg);
	        goto rq_err;
	     end;
	     svlen = i;
	  end;
         end;
         if (substr (svpath, 1, 4) = "[pd]")
         then do;
	  if (pdname = " ")
	  then pdname = get_pdir_ ();
	  svpath = pdname || substr (svpath, 5, svlen - 4);
	  svlen = svlen + 28;
         end;
         call expand_pathname_$component (svpath, fd.dname, fd.ename, fd.cname,
	    code);
         if (code ^= 0)
         then do;
bad_path:
	  msg = rtrim (svpath);
	  goto print_error_rc;
         end;
         if (fd.kind = "|")
         then fd.cname = subfile_name;
         else if (fd.cname ^= "")
         then fd.kind = ":";
         if trustsw | not_sw		/* if we can trust this pathname     */
         then do;
	  fd.trust_sw = "1"b;	/* ...remember the fact	       */
	  fd.file_sw = "1"b;	/* ...and indicated that it is saved */
	  fd.force_name = not_sw;
	  if not_sw		/* only remembering?	       */
	  then do;
	     b.file_d = fd;
	     return (NX_LIN);
	  end;
         end;
         else fd.trust_sw = "0"b;	/* ...mis-trust it		       */
      end;

      SI.version = SUFFIX_INFO_VERSION_1; /* #--c*/
      call fs_util_$suffix_info (fd.dname, fd.ename, addr (SI), code); /* #--c*/
      if (code ^= 0)
      then do;			/* #--c*/
				/* RW 88 */
         if (code = error_table_$unsupported_operation) then do; /* #191*/
				/* try to get more information about the problem...    /* #191*/
	  call hcs_$status_minf (fd.dname, fd.ename, 1, 0, 0, code); /* #191*/
				/* no error: stick with the unsupported op message     /* #191*/
				/* otherwise use the new error code, whatever it is    /* #191*/
	  if (code = 0) then	/* #191*/
	       code = error_table_$unsupported_operation; /* #191*/
         end;			/* #191*/
         if (code = error_table_$noentry) & wsw
         then goto make_one;		/* #--c*/
         goto get_err;		/* #--c*/
      end;			/* #--c*/
      if (SI.type_name ^= "segment")
      then do;			/* #--c*/
         msg = "Ims) Can't process ";	/* #--c*/
         msg = msg || SI.type_name;	/* #--c*/
         call msg_path (fd.kind);	/* #--c*/
         if (req_chx = "m")
         then goto write_loop_error;	/* #--c*/
         goto print_error;		/* #--c*/
      end;			/* #--c*/


      call hcs_$initiate_count (fd.dname, fd.ename, "", bc, 0, file_p, code);
      if (file_p = null)
      then do;
         if ^wsw
         then goto get_err;
         if (fd.kind = ":")
         then do;
no_ac_write:
	  if (req_chx = "m")
	  then do;
	     msg = "Xwa) Can't write to an archive. ";
	     call msg_path (fd.kind);
	     goto write_loop_error;
	  end;
	  call com_err_ (0, DBA, "Can't write to an archive. ^a>^a::^a",
	       fd.dname, fd.ename, fd.cname);
	  goto rq_err;
         end;
make_one:				/* #--c*/
         call tedcheck_entryname_ (fd.ename, code);
         if (code ^= 0)
         then goto bad_path;
				/* try to create segment	       */
         call hcs_$make_seg (fd.dname, fd.ename, "", 01011b, file_p, code);
         if (file_p = null)
         then do;
get_err:
	  if trustsw & ^wsw
	       & ^b.force_name	/* #129*/
	  then b.file_d = fd;
	  call msg_path (fd.kind);
	  call tederror_rc_ (dbase_p, msg, code);
	  if (req_chx = "m")
	  then goto write_loop;
	  goto rq_err;
         end;
         bc = 0;
      end;

dcl real_dname	char (168);
dcl real_ename	char (32);

      call hcs_$fs_get_path_name (file_p, real_dname, 0, real_ename, code);
      call hcs_$status_long (real_dname, real_ename, 1, addr (branch_status),
	 null, code);
      if (branch_status.mode & "01000"b) ^= "01000"b
      then do;			/* #153*/
         code = error_table_$insufficient_access; /* #153*/
         msg = "";			/* #153*/
         goto get_err;		/* #153*/
      end;			/* #153*/
      file_l = divide (bc, 9, 21, 0);
      if wsw			/* check for WRITE-protected file    */
      then do;
         if (fd.kind = ":")
         then goto no_ac_write;
         if b.pseudo		/* is this a ^read file?	       */
         then call promote (b.maxl);	/*    materialize it	       */
         if (branch_status.mode & "00010"b) ^= "00010"b
         then do;			/* if segment has no w access	       */
	  query_info.status_code = error_table_$moderr;
	  call command_query_ (addr (query_info), answer, DBA,
	       "Do you want to write to the protected ^[file^]^[archive^]"
	       || "^[subfile^] ^a>^a^a^a?",
	       (fd.kind = " "), (fd.kind = ":"), (fd.kind = "|"),
	       fd.dname, fd.ename, fd.kind, fd.cname);
	  if (substr (answer, 1, 1) = "n")
	  then do;
	     if (req_chx = "m")
	     then goto write_loop;
	     return (NX_LIN);
	  end;
	  seg_acl.userid = get_group_id_ (); /* wants to update	       */
	  seg_acl.access = "1010"b;	/* give user rw		       */
	  seg_acl.ex_access = "0"b;
	  call hcs_$add_acl_entries (fd.dname, fd.ename, addr (seg_acl), 1,
	       code);
	  if (code ^= 0)
	  then do;
	     msg = "(add_acl) ";
	     goto get_err;
	  end;
	  mustreprotect = "1"b;
         end;
         bc = write_l * 9;		/* length of data to be written      */
      end;

      if (fd.kind = ":")		/* processing an archive	       */
      then goto find_archive_element;
      if (fd.kind = "|")		/* processing a superfile	       */
      then goto find_subfile;

      if wsw & (write_l = 0)
      then do;
         sub_type = " subfile ";
x_not_found:
         msg = "";
         call msg_path ((sub_type));
				/* RW 88 */
         if (sub_type = " component ") then /*#201*/
	    call tederror_rc_ (dbase_p, msg, (error_table_$no_component)); /*#201*/
         else			/*#201*/
	    call tederror_rc_ (dbase_p, msg, (error_table_$noentry));
         call reprotect;		/* put things back, if necessary     */
         if (req_chx = "m")
         then goto write_loop;
         goto rq_err;
      end;

file_ready:
      if ^wsw
      then goto read_file;
      if (b_stat = B_LO_HI)		/* range is split, move high part    */
      then do;			/*   into file first	       */
         i = b.a_.r.le (2) - b.b_.r.le + 1;
         call mrl_ (addr (b_c (b.b_.r.le)), i,
	    addr (file_c (write_l - i + 1)), i);
         b.a_.r.le (2) = b.b_.l.re;	/* adjust to look like unsplit       */
      end;
				/* here always looks like unsplit    */
      i = b.a_.r.le (2) - b.a_.l.re (1) + 1;
/***** MRL is used to get bounds faults over with ASAP		       */
      call mrl_ (addr (b_c (b.a_.l.re (1))), i, file_p, i);
      if trustsw
      then do;			/* #129*/
         fd.not_pasted = "0"b;	/* #129*/
/****    clear mod_sw if the buffer is not "locked"		   #129*/
/****    or the default pathname is being used			   #129*/
         if ^b.force_name | (svlen = 0) /* #129*/
         then b.mod_sw, fd.mod_sw, fd.not_pasted = "0"b; /* #129*/
      end;			/* #129*/
      b.trust_sw = trustsw;
close_up_file:
      if b.force_name
      then b.trust_sw = "1"b;		/* #129*/
      else if trustsw
      then b.file_d = fd;
      call terminate_file_ (file_p, (bc), TERM_FILE_TRUNC_BC_TERM, code);
      if code ^= 0
      then do;
         msg = "(truncate) ";
         goto get_err;
      end;
      call reprotect;
      if (req_chx = "m")
      then do;
         wct = wct + 1;
         if (wct = 1)
         then call ioa_ ("Buffers written:");
         call ioa_ ("  (^a)	^a>^a^a^a", b.name, b.dname, b.ename, b.kind,
	    b.cname);
         goto write_loop;
      end;
      return (NX_LIN); %skip (3);
reprotect: proc;
      if mustreprotect		/* restore ACL to original state     */
      then do;
         delete_acl.userid = seg_acl.userid; /* delete ACL		       */
         call hcs_$delete_acl_entries (fd.dname, fd.ename,
	    addr (delete_acl), 1, code);
         if code ^= 0
         then do;
	  msg = "(delete_acl) ";
	  goto get_err;
         end;
      end;
   end reprotect; %skip (3);
read_buffer:
      b.cd.r.re = b.a_.r.le (1) + 1;	/* set destination point	       */
      used = rl_l - rl_i + 1;
      call tedget_existing_buffer_ (dbase_p, addr (rl_c (rl_i)),
	 used, tbp, msg);
      rl_l = rl_l + used;
      if (tbp = null)
      then goto rq_err_msg;
      if (tbp -> b.cur.sn = 0)
      then do;
         msg = "b(";
         msg = msg || rtrim (tbp -> b.name);
         msg = msg || ")";
         call tederror_rc_ (dbase_p, msg, tederror_table_$zero_length_buffer);
         goto rq_err;
      end;
      tbp -> b.cd.l.re = tbp -> b.a_.l.re (1); /* set source range	       */
      tbp -> b.cd.r.le = tbp -> b.a_.r.le (2);
				/*  //			       */
      b.a_.l.ln (1) = -1;		/* <<----------		       */
				/*  \\			       */
      call buffer_buffer_copy (tbp, bp, "1"b); /* Add to right end for the */
				/*  same reason that files are added */
				/*  that way.		       */
      b.a_.r.le (2) = b.a_.r.le (1) - 1;/*  [bbc set rle(1) for us]	       */
      if (b.a_.r.le (2) < 1)		/* buffer was empty		       */
      then b.a_.r.le (2) = b.b_.r.re;	/* ..so take end of data	       */
      call iso_line;
      return (NX_LIN); %page;
read_file:
      if trustsw & ^b.force_name
      then b.file_d = fd;
      else b.trust_sw = b.force_name;
      if (file_l = 0)
      then do;
         msg = "";
         call msg_path (" ");
         call tederror_rc_ (dbase_p, msg, (error_table_$zero_length_seg));
         if (req_chx = "m")
         then goto write_loop;
         return (NX_LIN);
      end;
      if (b.cur.sp = null ())		/* if buffer empty		       */
      then do;
         b.dtcm = branch_status.date_time_modified;
         b.uid = branch_status.unique_id;
      end;

      b.newa = tedcommon_$no_data;
      if ^read_sw			/* if ^read is in effect	       */
	 & (b.cur.sn = 0)		/* ..and buffer is empty	       */
      then do;			/* just -> the data		       */
         call tedpseudo_ (bp, -1, file_p, file_l);
         b.terminate = "1"b;
         dbase.not_read_ct = dbase.not_read_ct + 1;
         b.initiate = "0"b;
         b.ck_ptr_sw = "0"b;
         b.a_.r.le (2) = b.b_.l.re;
         call iso_line;
         return (NX_LIN);
      end;
      else do;
/**** Various conditions:	(AAAA is addressed string)		       */
/**** xxxxxxxxxxAAAAxxxxxx..........zzzzzzzzzz	openup		       */
/**** xxxxxxxxxx..........AAAAxxxxxxzzzzzzzzzz	add(RIGHT)	       */
/**** xxxxxxxxxx......ffffAAAAxxxxxxzzzzzzzzzz	iso_line		       */
/**** xxxxxxxxxx......zzzzzzzzzzzzzzzzzzzzzzzz			       */

/**** ........................................	openup		       */
/**** ........................................	add(RIGHT)	       */
/**** ....................................ffff	iso_line		       */
/**** ....................................zzzz			       */


         if (b.cur.sn = 0)		/* if buffer is empty	       */
	    & ^b.force_name		/* ..and not "locked"	   #129*/
         then fd.mod_sw = "0"b;	/* ..it is not modified by reading   */
         else fd.mod_sw = "1"b;	/* ..otherwise it is.	       */
         b.a_.l.re (1) = b.a_.l.re (1) + 1;
         call openup;		/* move hole to where we need it     */
         call add_2r (ted_safe, file_p, file_l, NLct_unknown);
				/* copy in specified file	       */
         b.mod_sw = fd.mod_sw;	/* add doesn't really know	       */
         b.a_.r.le (2) = b.b_.r.le + file_l - 1;
         call iso_line;
         call hcs_$terminate_noname (file_p, code); /* don't be sloppy!      */
         if (req_chx = "m")
         then goto write_loop;
         return (NX_LIN);
      end; %page;
find_archive_element:
      call archive_$get_component (file_p, (bc), fd.cname, ttp, bc, code);
      if (code ^= 0)
      then do;
         sub_type = " component ";
         goto x_not_found;
      end;
      file_p = ttp;			/* -> component		       */
      file_l = divide (bc, 9, 21, 0);
      goto file_ready; %skip (3);
find_subfile:			/* bc already contains size of data  */
      subfile_name = rtrim (fd.cname);	/* .. to be written		       */
      header_l = length (subfile_name) + 7;
      bc = bc + file_l * 9;		/* add in length of existing segment */
      if (file_l = 0)		/* no segment was found,	       */
      then do;			/* ..initialize brand new superfile  */
         substr (file_s, 1, length (superfile)) = superfile;
         file_l = length (superfile);
         bc = bc + file_l * 9;	/* add in length of segment header   */
         after_l = 0;		/* nothing after component	       */
				/* (since its not there)	       */
      end;
      else do;			/* the file already exists	       */
         xfi = index (file_s, subf1 || subfile_name || subf2);
         if (xfi ^= 0)		/* found the subfile	       */
         then do;
				/* look for end of subfile	       */
	  xfe = index (substr (file_s, xfi + 1), subf1);
	  if (xfe = 0)
	  then xfe = file_l - xfi + 1;
	  after_l = file_l - xfi - xfe + 1; /* ...after  this	       */
	  file_l = xfe - header_l;	/* length of subfile	       */
	  file_p = addr (file_c (xfi + header_l)); /* -> data	       */
	  if ^wsw
	  then do;
	     if db_ted
	     then call ioa_$ioa_switch (db_output,
		     "^10p wl=^i fl=^i al=^i bc=^i",
		     file_p, write_l, file_l, after_l, bc);
	     goto read_file;
	  end;
	  bc = bc - file_l * 9;	/* remove length of data being       */
				/* ..replaced		       */
         end;
         else after_l = 0;		/* subfile NOT FOUND	       */
      end;

      if (write_l ^= 0)		/* writing a subfile	       */
      then do;
         if (after_l = 0)
         then do;			/* new subfile, must create header   */
	  file_p = addr (file_c (file_l + 1)); /* ..at the end	       */
	  substr (file_s, 1, 4) = subf1;
	  substr (file_s, 5, length (subfile_name)) = subfile_name;
	  substr (file_s, length (subfile_name) + 5, 3) = subf2;
	  file_p = addr (file_c (header_l + 1));
	  file_l = write_l;
	  bc = bc + header_l * 9;	/* add in length of new header       */
         end;
				/* move past the header	       */
         if db_ted
         then call ioa_$ioa_switch (db_output, "^10p wl=^i fl=^i al=^i bc=^i",
	         file_p, write_l, file_l, after_l, bc);
         if (after_l > 0)
         then do;
	  if (file_l > write_l)	/* more found than being written,    */
	  then do;		/* ..close up hole in file	       */
(nostringrange):
	     substr (file_s, write_l + 1, after_l)
		= substr (file_s, file_l + 1, after_l);
	  end;
	  else if (file_l < write_l)	/* less found than being written,    */
	  then do;		/* ..open up hole in file	       */
	     call mrl_ (addr (file_c (file_l + 1)), after_l,
		addr (file_c (write_l + 1)), after_l);
	  end;
         end;
         goto file_ready;
      end;
				/* deleting a subfile	       */
      if (after_l > 0)
      then do;			/* move the following data down      */
(nostringrange):
         substr (file_s, 1, after_l) = substr (file_s, file_l + 1, after_l);
      end;
      goto close_up_file; %page;
/* . . .  request 	: clean up and exit from ted editor (i.e., return to     */
/*		  caller)					       */

cmd (113):			/* q */
      if ^alt_sw & (substr (rl_s, rl_i, 1) = "f") /* #160*/
      then do;			/* #160*/
         rl_i = rl_i + 1;		/* #160*/
         goto cmd (081);
      end;
      if ^alt_sw & (substr (rl_s, rl_i, 5) = "hold
")
      then do;
         if ted_safe
         then do;
	  do tbi = 3 to bufnum;
	     bp = addr (CB (tbi));
	     if (b.cur.sn > 2) & ^b.pseudo
	     then call promote$seg;	/* clean up garbage'ed words	       */
	  end;
	  call tedhold_ (dbase_p);
	  goto exit;
         end;
         msg = "Xns) Not in -safe mode";
         goto print_error;
      end;
   /*** special syntax checks for quit request			   #160*/
      if (b.present (1))
      then goto syntax_error;		/* #160*/
      if (rl_c (rl_i) ^= NL)
      then do;			/* #160*/
         rl_i = rl_i + verify (substr (rl_s, rl_i), SP_HT) - 1; /* #160*/
         if (rl_c (rl_i) ^= NL)
         then goto syntax_error;	/* #160*/
      end;			/* #160*/
      if ^alt_sw
/****            & ^qedx_mode					   #159*/
      then do;
/**** really need to search for b0 since it could have been deleted	       */
         save_mod = b0_bp -> b.mod_sw;
         if (ted_data.input_p ^= null ())
         then b0_bp -> b.mod_sw = "0"b;
         call tedcheck_buffers_ (dbase_p, wct);
         b0_bp -> b.mod_sw = save_mod;
         if (wct ^= 0)
         then do;
	  query_info.status_code = 0;
	  call command_query_ (addr (query_info), answer, DBA,
	       "Do you still wish to quit?");
	  if (substr (answer, 1, 1) = "n")
	  then return (NX_LIN);
         end;
      end;
cmd (081):			/* Q */
   /*** special syntax checks for quit request			   #160*/
      if (b.present (1))
      then goto syntax_error;		/* #160*/
      if (rl_c (rl_i) ^= NL)
      then do;			/* #160*/
         rl_i = rl_i + verify (substr (rl_s, rl_i), SP_HT) - 1; /* #160*/
         if (rl_c (rl_i) ^= NL)
         then goto syntax_error;	/* #160*/
      end;			/* #160*/
      bp = af_bp;
      if (bp ^= null ())
      then do;
         af_value = "";
         call addr_status_ends_set (1, b.maxl);
         if (b_stat ^= B_MT)
         then do;
	  if (b_stat ^= B_HI_HI)	/* range is split, add low part     */
	  then do;		/* ..in first		       */
	     af_value = af_value || substr (b_s, 1, b.b_.l.re);
	     if (b_stat = B_LO_HI)
	     then b_stat = B_HI_HI;
	  end;
	  if (b_stat ^= B_LO_LO)
	  then do;
	     af_value = af_value
		|| substr (b_s, b.b_.r.le, b.maxl - b.b_.r.le + 1);
	  end;
         end;
      end;
      if (ted_data.input_p ^= null ())
      then do;
         bp = b0_bp;
/**** b0_bp approach wrong because b0 could be deleted and then some other   */
/****  buffer use its slot, while b0 gets regenerated somewhere else.	       */
         call addr_status_ends_set (1, b.maxl);
         if (b_stat ^= B_MT)
         then do;
	  write_l = (b.b_.l.re - b.b_.l.le + 1)
	       + (b.b_.r.re - b.b_.r.le + 1);
	  if (ted_data.output_p ^= null ()) /* an output segment supplied  */
	  then do;
	     ted_data.output_l = write_l;
	     tbp = ted_data.output_p;
	     b.mod_sw = "1"b;	/* force it modified	       */
	  end;
	  else if b.mod_sw		/* don't replace input segment       */
	  then do;		/* ..unless it's changed	       */
	     ted_data.input_l = write_l;
	     tbp = ted_data.input_p;
	  end;
	  if b.mod_sw
	  then do;
	     if (b_stat = B_LO_HI)	/* range is split, move high part    */
	     then do;		/*   into segment first	       */
	        i = b.a_.r.le (2) - b.b_.r.le + 1;
	        call mrl_ (addr (b_c (b.b_.r.le)), i,
		   addr (tbp -> file_c (write_l - i + 1)), i);
	        b.a_.r.le (2) = b.b_.l.re; /* adjust to look unsplit      */
	     end;
				/* here always looks like unsplit    */
	     i = b.a_.r.le (2) - b.a_.l.re (1) + 1;
/***** MRL is used to get bounds faults over with ASAP		       */
	     call mrl_ (addr (b_c (b.a_.l.re (1))), i, tbp, i);
	  end;
         end;
      end;
      call cleaner;
      goto exit;			/* and return to caller of ted       */
%page;
/* . . . line-feed	:					       */

cmd (076):			/* L */
      ttp = iox_$error_output;
      goto line_feed;
cmd (108):			/* l */
      if alt_sw
      then ttp = iox_$error_output;
      else ttp = iox_$user_output;
line_feed:
      if com_blank then call ck_blank;
      call ignore_all;
      call iox_$put_chars (ttp, addr (NL), 1, 0);
      return (NX_REQ);
%skip (4);
/* . . . print	: print out specified portion of current buffer file on  */
/*		  user's console				       */

cmd (112):			/* p */
      if com_blank then call ck_blank;
      call default$cur_line;
      if alt_sw then goto PRINTb;
      call print;
      call iso_line;		/* set "." to last line printed   */
      return (NX_REQ); %skip (4);
/* . . . delete 	: delete specified lines from current buffer	       */

cmd (100):			/* d */
      if com1_blank then call ck_blank;
      call default$cur_line_extend;
      call delete;			/* what about when last char?	       */
      call iso_line;
      return (NX_REQ); %page;
/* . . . append	: after addressed line			       */
/****	      b.a_.l.re(1)    b.a_.r.le (1)			       */
/**** Addr:    	       |    |				       */
/****		xxxxxxxAAAAAAxxxxx.............yyyy		       */
/**** adjust to:		   |				       */
/****			b.a_.l.re (1)			       */

cmd (097):			/* a */
      if com1_blank then call ck_blank;
      if (b.cur.sn = 0)		/* if buffer empty		       */
      then b.a_.r.re (1), b.a_.r.le (1) = 0;
      else if ^b.present (1)
      then call default$cur_line_extend;
      call ignore_2;
      b.a_.l.re (1) = b.a_.r.le (1) + 1;
      goto in_mode; %skip (3);
/* . . . change	: replace addressed line(s)			       */
/****	      b.a_.l.re(1)    b.a_.r.le (2)			       */
/**** Addr:    	       |    |				       */
/****		xxxxxxxAAAAAAxxxxx.............yyyy		       */
/**** adjust to:    xxxxxxx...................xxxxxyyyy		       */
/****				      |			       */
/****				b.a_.l.re (1)		       */

cmd (099):			/* c */
      if com1_blank then call ck_blank;
      call default$cur_line;
      call delete;
      b.a_.l.re (1) = b.b_.r.le;
      goto in_mode; %skip (3);
/* . . . insert	: before addressed line			       */
/****	      b.a_.l.re(1)    b.a_.r.le (1)			       */
/**** Addr:     	       |    |				       */
/****		xxxxxxxAAAAAAxxxxx.............yyyy		       */
/**** adjust to:	       |					       */
/****		b.a_.l.re (1)				       */
cmd (105):			/* i */
      if com1_blank then call ck_blank;
      if (b.cur.sn = 0)		/* if buffer empty		       */
      then b.a_.l.le (1), b.a_.l.re (1) = 1;
      else call default$cur_line_extend;
      call ignore_2;
%skip (5);
in_mode:				/* ---common code---	       */
      if (b.cur.sn = 0)
      then b.trust_sw = b.force_name;
      call openup;
      EOF = "0"b;
      if alt_sw
      then which_mode = "BULK";
      else do;
         which_mode = "INPUT";
         if (rl_c (rl_i) = NL)	/* skip NL or		       */
	    | (rl_c (rl_i) = SP)	/* ..blank immediately following     */
         then rl_i = rl_i + 1;	/* .. input request		       */
scan_req_line:
         k = index (substr (rl_s, rl_i), "\"); /* Any escapes?	       */
         if (k = 0)			/* if not found		       */
         then k = rl_l - rl_i + 1;	/*  take rest of line	       */
         else k = k - 1;		/*  take everything up to there      */
         if (k > 0)			/* if anything in between	       */
         then do;			/* ...add it to buffer	       */
	  call add_2l (ted_safe, addr (rl_c (rl_i)), k, NLct_check);
	  rl_i = rl_i + k;
         end;
         if (rl_i <= rl_l)		/* if something left, handle it    */
         then do;
	  k = index ("fcFC", rl_c (rl_i + 1));
	  if (k > 2) then k = k - 2;
	  if (k > 0)
	  then do;
	     rl_i = rl_i + 2;	/* skip the \f or \c	       */
	     if (k = 1)
	     then goto input_finish;
	  end;
				/* just copy char across	       */
	  call add_2l (ted_safe, addr (rl_c (rl_i)), 1, NLct_check);
	  rl_i = rl_i + 1;
	  goto scan_req_line;
         end;
      end;

      if (b.cur.sn = 0)		/* if no buffer there,	       */
      then call promote (1);		/* ..get one		       */
      pi_label = input_pi;
      pi_sw = 3;

      b.INPUT = "1"b;		/* indicate INPUT in progress	   #156*/
      do while (which_mode ^= "EOF");
         k = b.b_.l.re;		/* remember last char filled	       */
         call tedread_ptr_ (dbase_p,	/* -> database		       */
	    b.cur.sp,		/* -> buffer		       */
	    k,			/* last char used in buffer	       */
	    b.b_.r.le - 2,		/* last char usable		       */
	    b.b_.l.re,		/* last char filled		  [OUT]*/
	    which_mode);		/* mode			       */
input_pi:
         k = b.b_.l.re - k;		/* how many characters were input    */
         if (k > 0)
         then b.mod_sw = "1"b;
         if (chars_moved >= 0)	/* count the chars that were put     */
         then chars_moved = chars_moved + k; /* ..the data buffer	       */
         if (b.b_.l.ln ^= -1)
         then do;
				/* count NLs */
         end;
         b.maxln = -1;		/* say we don't know # lines	       */
         if (which_mode = "\R\F")
         then goto input_over;
         if (which_mode ^= "EOF")
         then call promote (b.b_.r.le - b.b_.l.re + 2); /* get more room   */
      end;

input_over:
      if (b.b_.l.re < b.b_.l.le)	/* if no data present,	       */
	 & (b.b_.r.re < b.b_.r.le)
      then call delete$all;
      else do;
input_finish:
         b.a_.r.le (2) = b.b_.l.re;
         b.a_.r.ln (2) = b.b_.l.ln;
      end;
      call iso_line;		/* "."-> last line input	       */
      if db_ted
      then call tedshow_ (bp, ". inp bcb");
      if (which_mode = "\R\F")
      then goto eof_err;
      return (NX_REQ); %page;

cmd (074):			/* J */
      alt_sw = "1"b;

cmd (106):			/* j */
      call scan;
      if com_blank then call ck_blank;
      if (substr (rl_s, expr_b, expr_l) = "?")
      then do;
         call tedsort_$show;
         return (NX_REQ);
      end;
      if (substr (rl_s, expr_b, 2) = "s=")
      then do;
         call tedsort_$set (substr (rl_s, expr_b + 2, expr_l - 2));
         return (NX_REQ);
      end;
      call default$whole_buffer;	/* Default: sorting whole window     */
      ii = i;
      do sort_l = 1 to 3;
         sort_sn (sort_l) = 0;
         call tedget_segment_ (dbase_p, sort_p (sort_l), sort_sn (sort_l));
      end;
      if alt_sw
      then do;
         expr_b = expr_b - 1;
         rl_c (expr_b) = "s";
         expr_l = expr_l + 1;
      end;
      rl_b = expr_b;
      call openup;
dcl sort_l	fixed bin (21);	/* @@@@ */
      call tedsort_ (addr (rl_c (expr_b)), expr_l,
	 addr (b_c (b.a_.l.re (1))), b.a_.r.le (2) - b.a_.l.re (1) + 1,
	 sort_p, sort_l,
	 msg, code);
      call tedfree_segment_ (dbase_p, sort_sn (1));
      call tedfree_segment_ (dbase_p, sort_sn (2));
      if (code ^= 0)
      then do;
         call tedfree_segment_ (dbase_p, sort_sn (3));
         if (code = 2)		/* only 1 line sorted	       */
         then return (NX_REQ);
         rl_i = expr_b + expr_l - 1;
         goto add_request;
      end;
      else do;			/* there's a window here where ^safe */
         b.b_.r.le = b.a_.r.le (2) + 1; /* delete old copy		       */
         call add_2l (ted_safe, sort_p (3), sort_l, NLct_unknown);
         b.a_.r.le (2) = b.b_.l.re;
         call iso_line;
         call tedfree_segment_ (dbase_p, sort_sn (3));
         return (NX_REQ);
      end;
      goto rq_err; %skip (3);
/* . . . type	: type a string				       */

cmd (084):			/* T */
      ttp = iox_$error_output;
      goto type;
cmd (116):			/* t */
      if alt_sw
      then ttp = iox_$error_output;
      else ttp = iox_$user_output;
type:
      call ignore_all;
      call scan;
      if com_blank then call ck_blank;
      call iox_$put_chars (ttp, addr (rl_c (expr_b)), (expr_l), 0);
      return (NX_REQ); %skip (3);
/* . . . not	: inverse of a request (sorta)		       */

cmd (039):			/* ' */
cmd (094):			/* ^ */

      req_chx, ch = rl_c (rl_i);
      req_str = req_str || req_chx;
      rl_i = rl_i + 1;
      not_sw = "1"b;
      if (index ("#*>rb", req_chx) = 0)
      then goto invalid_request;
      req_not = req_ch;
      req_ch = req_chx;
      req_chx = " ";
      req_not = " ";
      goto cmd (rank (req_ch)); %skip (4);
/* . . . alternate	: alternate form of a few requests		       */

cmd (033):			/* ! */

      if (substr (DBA, 1, 1) = "q")
      then goto invalid_request;
      req_chx, ch = rl_c (rl_i);
      req_str = req_str || req_chx;
      rl_i = rl_i + 1;
      alt_sw = "1"b;
      if (index ("abcefijklmnpqrstuwx!", req_chx) = 0)
      then goto invalid_request;
      if (req_chx = "!")		/* this is slipped in to handle      */
      then req_ch = "|";		/*    when a user has no "|" on his  */
      else do;			/*    keyboard, i.e. unmodified      */
         req_not = "!";		/*    Apple ][		       */
         req_ch = req_chx;
      end;
      req_chx = " ";
				/* RW 88 */
      if (req_ch = "f") then req_ch = "F"; /*#194*/
      goto cmd (rank (req_ch)); %page;
/* . . . substitute	: replace all occurences of str1 with str2	       */

cmd (042):			/*"*"*/
if:
      call scan;
      if com_blank then call ck_blank;
      call default$cur_line;
      if (expr_l > 0)
      then call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
	      addr (dbase.regexp), (string_sw), (dbase.lit_sw), msg, code);
      call tedsrch_$search (addr (dbase.regexp), bp,
	 b.a_.l.re (1), b.a_.r.le (2), mi, me, me2, msg, code);
      if (code = 2)			/* syntax error		       */
      then goto print_error;
      if (code = 0)
      then return (not_sw);		/* search succeeded		       */
      else return (^not_sw);		/* search failed		       */ %skip (5);
cmd (083):			/* S */
      subsw = "1"b;			/* init switch so cannot fail	       */
      if ""b
      then do;

cmd (115):			/* s */
         subsw = "0"b;		/* init switch to nothing found yet  */
         if alt_sw
         then subsw = "1"b;		/*  wait! make it no-fail	       */
      end;
      call default$cur_line;
      call scan;			/* isolate str1 from request line    */
      call init_cfp (sub_p, repl_exp);
      gvx.tot_len = 0;
      call replace$compile;		/* compile str2		       */
      cf.op = 0;
      call end_cf;
dcl repl_exp	char (500);
      if com_blank then call ck_blank;
      if (expr_l > 0)
      then call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
	      addr (dbase.regexp), (string_sw), (dbase.lit_sw), msg, code);
      if (code = 2)
      then goto print_error;
      dbase.S_count = 0;
      call init_cfp (sub_p, repl_exp);
      call substitute (addr (dbase.regexp)); /* cfp -> replace	       */

   /*** code = 8 => search failed				       */
      if ^subsw			/* error if nothing found	       */
      then do;
         if (err_go = "")		/* if user does not want to catch    */
				/*  errors attempt to pop buffer     */
         then call tedend_buffer_ (dbase_p, code); /*  recur stack    */
         if code = 0
         then return (NX_LIN);	/* and continue in calling buffer    */
         msg = "Xsf) Substitute failed.";
         goto print_error;
      end;
      return (NX_REQ); %page;
/* . . . TRANSLATE UPPER/LOWER . . */

cmd (085):			/* U */
cmd (117):			/* u */

      call scan;
      call ck_blank;
      call default$cur_line;
      if b.pseudo
      then call promote (b.maxl);	/* change buffer into real one       */
      if (expr_l > 0)
      then call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
	      addr (dbase.regexp), (string_sw), (dbase.lit_sw), msg, code);
      call upper_lower (addr (dbase.regexp), (req_ch = "U") | alt_sw);
      return (NX_REQ); %skip (3);
/* . . . option request	: set or display options */

cmd (111):			/* o */
      if (rl_i = rl_l)
      then do;
				/* RW 88 */ /*#200*/
         call ioa_ ("^a^[(^a)^;^s^][^i]^[safe^] ^[part_^]^[^;^^^]blank,"
	    || "^[^;^^^]caps,^[^;^^^]resetread,^[^;^^^]break,^[^;^^^]edit,"
	    || "^[^;^^^]input,^[^;^^^]label,^[^;^^^]read,^[^;^^^]old-style,"
	    || "^[^;^^^]g*NL,"
	    || "^[^;^^^]string,null=^a^[^/^-comment=""^a""^]",

	    DBA, (DBA = "ted"), ted_vers, dbase.recurs, (dbase.dir_db ^= ""),
	    (com_blank ^= com1_blank), com_blank, caps, reset_read,
	    break_sw, edit_sw, input_sw, flow_sw,
	    read_sw, old_style, gvNL, string_sw, nulreq,
	    (dbase.comment ^= ""), dbase.comment);
      end;
      else do;
         substr (rl_s, rl_l, 1) = " ";
         do rl_i = rl_i to rl_l;
	  if (substr (rl_s, rl_i, 1) ^= " ")
	       & (substr (rl_s, rl_i, 1) ^= ",")
	  then do;
	     if (substr (rl_s, rl_i, 1) = "^")
	     then do;
	        not_sw = "1"b;
	        rl_i = rl_i + 1;
	     end;
	     else not_sw = "0"b;
dcl optlen	fixed bin;
	     if (substr (rl_s, rl_i, 4) = "edit")
	     then do;
	        optlen = 4;
	        edit_sw = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 5) = "input")
	     then do;
	        optlen = 5;
	        input_sw = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 2) = "on")
	     then do;
	        optlen = 2;
	        input_sw, edit_sw = "1"b;
	     end;
	     else if (substr (rl_s, rl_i, 5) = "trace")
	     then do;
	        optlen = 5;
	        input_sw, edit_sw = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 3) = "off")
	     then do;
	        optlen = 3;
	        input_sw, edit_sw = "0"b;
	     end;
	     else if (substr (rl_s, rl_i, 5) = "label")
	     then do;
	        optlen = 5;
	        flow_sw = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 9) = "partblank")
	     then do;
	        optlen = 9;
	        com_blank = "0"b;
	        com1_blank = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 5) = "blank")
	     then do;
	        optlen = 5;
	        com_blank, com1_blank = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 4) = "caps")
	     then do;
	        optlen = 4;
	        caps = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 4) = "read")
	     then do;
	        optlen = 4;
	        read_sw = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 9) = "resetread")
	     then do;
	        optlen = 9;
	        reset_read = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 5) = "break")
	     then do;
	        optlen = 5;
	        break_sw = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 9) = "old-style")
	     then do;
	        optlen = 9;
	        old_style = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 4) = "g*NL")
	     then do;
	        optlen = 4;
	        gvNL = ^not_sw;
	     end;
	     else if (substr (rl_s, rl_i, 5) = "null=")
	     then do;
	        optlen = 5;
	        i = 0;
	        if (substr (rl_s, rl_i + 5, 2) = "!p")
	        then i = 2;
	        if (index ("pP", substr (rl_s, rl_i + 5, 1)) ^= 0)
	        then i = 1;
	        if i = 0
	        then goto inv_opt;
	        nulreq = substr (rl_s, rl_i + 5, i);
	        optlen = optlen + i;
	     end;
	     else if (substr (rl_s, rl_i, 9) = "comment=""")
	     then do;
	        optlen = 9;
	        i = index (substr (rl_s, rl_i + 9), """");
	        if (i = 0)
	        then do;
		 call ioa_ ("Missing terminal quote on comment");
		 return (NX_LIN);
	        end;
	        dbase.comment = substr (rl_s, rl_i + 9, i - 1);
	        optlen = optlen + i;
	     end;
	     else if (substr (rl_s, rl_i, 2) = "ct") /* OBSOLETE! */
	     then do;
	        optlen = 2;
	        call ioa_ ("ct= ^i", dbase.S_count);
	     end;
	     else if (substr (rl_s, rl_i, 2) = "gv")
	     then do;
	        optlen = 2;
	        call gv_dump;
	     end;
	     else if (substr (rl_s, rl_i, 1) = "*")
	     then do;
	        optlen = rl_l - rl_i + 1;
	        call tedshow_ (bp, "> opt", substr (rl_s, rl_i + 1), "<");
	     end;
	     else if (substr (rl_s, rl_i, 2) = "??")
	     then do;
	        optlen = 2;
	        call ioa_ ("gv	gv_dump");
	        call ioa_ ("*xx	tedshow xx");
	     end;
	     else do;
inv_opt:
	        msg = "Xio) Invalid option ";
	        msg = msg || substr (rl_s, rl_i,
		   rl_l - rl_i);
	        goto print_error;
	     end;
	     rl_i = rl_i + optlen - 1;
	  end;
         end;
      end;
      return (NX_LIN); %page;
/* . . .  execute request	: pass remainder of line to command processor  */

cmd (069):			/* E */
cmd (101):			/* e */
      if com1_blank then call ck_blank;
      call ignore_both;
      substr (rl_s, 1, rl_i - 1) = SP;	/* blank out up to here      */
      if (req_str ^= "e")
      then call iox_$put_chars (iox_$user_output, addr (rl_c (rl_i)),
	      rl_l - rl_i + 1, 0);
      pi_label = kill_execute;	/* allow request to be aborted       */
      pi_sw = 1;			/* by means of a PI		       */
      call tedset_ck_ptr_ (dbase_p);
      call cu_$cp (dbase.rl.sp, rl_l, code);
kill_execute:
      pi_sw = 0;			/* disable PI upon return	       */
      if fo_sw
      then fop -> b.get_bit_count = "0"b;
				/* delete    #152*/
      return (NX_LIN);		/* get fresh request line from input stream */
%skip (5);
/* these routines are support for the dynamic call mechanism	       */
ckpt: proc (p1, p2);

dcl (p1, p2)	fixed bin (21);
				/* Temporarily unsupported	       */
/****      ofe = p2;					       */
/****      ifse = p1;					       */

   end ckpt; %skip (2);
getreq: proc ();

      call tedread_ptr_ (dbase_p, dbase.rl.sp, 0, dbase.rl.r.re,
	 ted_sup.req.de, "|DATA");
      if (chars_moved >= 0)		/* count number of chars he asked to */
      then chars_moved = chars_moved + ted_sup.req.de; /* ..be gotten	       */

   end getreq;
%page;

/* . . . dynamic call	: call ted support routine (perhaps user-written) */
cmd (124):			/* | */
      i = verify (substr (rl_s, rl_i),
	 "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz");
      if (i = 1)
      then goto err_Snf;
      msg = "ted_";
      msg = msg || substr (rl_s, rl_i, i - 1);
      msg = msg || "_";
      req_str = req_str || substr (rl_s, rl_i, i - 1);
      rl_i = rl_i + i - 1;
      call ck_blank;
      rl_i = rl_i + 1;
      if (rl_i > rl_l)
      then rl_c (rl_i) = NL;
      if (b.cur.sn = 0)
      then do;
         b.a_.l.re (1) = 1;
         b.a_.r.le (2) = 0;
      end;
      else call default$cur_line;
do_call:				/* entry for old request simulators */
      call hcs_$make_ptr (codeptr (do_call), (msg), (msg), file_p, code);
      if (code ^= 0)
      then goto print_error_rc;
      ted_sup.version = ted_support_version_2;
      ted_sup.addr_ct = 0;
      if b.present (1)
      then ted_sup.addr_ct = 1;
      if b.present (2)
      then ted_sup.addr_ct = ted_sup.addr_ct + 1;

/**** All the stuff relating to the ted_sup.inp.* values have to be handled  */
/**** so that it will give the proper view when a window is in effect.       */

      b.a_.l.re (2) = b.a_.l.re (1);	/* save beginning address where it   */
				/* ..will be relocated	       */
      b.a_.l.re (1) = b.b_.r.re + 1;	/* pack data within window	       */
      call openup;			/* ..to left End		       */
      b.a_.l.re (1) = b.a_.l.re (2);	/* restore beginning address	       */
      call tedcount_lines_ (bp,	/*b.b_.l.le + 1,			   #--a*/
	 b.b_.l.le, b.a_.l.re (1), ted_sup.inp.lno);
      ted_sup.inp.lno = max (ted_sup.inp.lno, 1); /* #--a*/
      ted_sup.inp.pt = addr (b_c (b.b_.l.le));
      ted_sup.inp.sb = b.a_.l.re (1) - b.b_.l.le + 1;
      ted_sup.inp.se = min (b.a_.r.le (2), b.b_.r.le) - b.b_.l.le + 1;
      ted_sup.inp.de = b.b_.l.re - b.b_.l.le + 1;
      if db_ted
      then call ioa_$ioa_switch (db_output, "inp.pt = ^10p inp.sb=^5i inp.se=^5i inp.de=^5i",
	      ted_sup.inp.pt, ted_sup.inp.sb, ted_sup.inp.se, ted_sup.inp.de);
      sort_sn (1) = 0;
      call tedget_segment_ (dbase_p, ted_sup.out.pt, sort_sn (1));
      ted_sup.out.de = ted_sup.inp.sb - 1;
      substr (ted_sup.out.pt -> b_s, 1, ted_sup.out.de)
	 = substr (ted_sup.inp.pt -> b_s, 1, ted_sup.out.de);

      ted_sup.out.ml = 1048184;
      if db_ted
      then call ioa_$ioa_switch (db_output, "out.pt = ^10p out.de=^5i",
	      ted_sup.out.pt, ted_sup.out.de);
      ted_sup.current = 0;		/* "." undefined		       */
      ted_sup.req.pt = dbase.rl.sp;	/* make request line available       */
      ted_sup.req.de, ted_sup.req.nc = rl_l;
      ted_sup.req.cc = rl_i;
      ted_sup.req.ml = dbase.rl.r.re;
      ted_sup.string_mode = string_sw;
/****      ifse = 0;					       */
/****      iife = b.b_.r.re;					       */
      ted_sup.checkpoint = ckpt;
      ted_sup.get_req = getreq;
      ted_sup.proc_expr = tedglobal_$proc_expr;
      ted_sup.do_global = tedglobal_$do_global;
dcl tedglobal_$proc_expr entry (ptr, char (168) var, fixed bin (35));
dcl tedglobal_$do_global entry (entry (), char (1), ptr, char (168) var,
		fixed bin (35));
      ted_sup.reg_exp_p = addr (dbase.regexp);
      ted_sup.bcb_p = bp;
      msg = "";			/* clean up message		       */
      code = 0;			/* ..and return code	       */
      pi_label = nochange;		/* allow PI to abort the action      */
      pi_sw = 1;

call_again:
      call cu_$ptr_call (file_p, addr (ted_sup), msg, code);
      if (code = error_table_$unimplemented_version)
	 & (ted_sup.version = ted_support_version_2)
      then do;
         ted_sup.version = ted_support_version_1;
         goto call_again;
dcl ted_support_version_1 fixed bin int static init (1);
      end;
      if (ted_sup.version = ted_support_version_1)
      then do;			/* convert old style codes	       */
         if (code = 0)
         then code = tederror_table_$Copy_Set;
         else if (code = 1)
         then code = tederror_table_$NoChange;
         else if (code = 2)
         then code = tederror_table_$Set;
         else if (code = 4)
         then code = tederror_table_$Error_Msg;
      end;

      if (code = tederror_table_$Copy_Set)
      then do;			/* copy back his result	       */
         if db_ted
         then call ioa_$ioa_switch (db_output, "out.pt = ^10p out.de=^5i",
	         ted_sup.out.pt, ted_sup.out.de);
         b.a_.r.le (2) = min (ted_sup.inp.se, ted_sup.inp.de) + b.b_.l.le - 1;
         b.a_.l.re (1) = b.b_.l.le;	/* 1st, get rid everything up to     */
         call delete;		/* ..the end of what he processed    */
				/* then add in his replacement       */
         call add_2l (ted_safe, ted_sup.out.pt, ted_sup.out.de, NLct_check);
         code = tederror_table_$Set;	/* copy part taken care of	       */
      end;
      if ""b
      then do;
nochange:				/* PI resume point		       */
         code = tederror_table_$NoChange;
      end;
      pi_sw = 0;			/* no more interrupts	       */
      call tedfree_segment_ (dbase_p, sort_sn (1));

      if (code = tederror_table_$Set)
      then do;
         if (ted_sup.current > 0)
         then b.a_.r.le (2) = ted_sup.current;
         call iso_line;		/* set current line as he (maybe)    */
         code = tederror_table_$NoChange;
      end;
      if (code = tederror_table_$NoChange)
      then do;
         rl_i = ted_sup.req.nc;	/* propagate request line status     */
         rl_l = ted_sup.req.de;
         return (NX_REQ);
      end;
      if (code = tederror_table_$Error_Msg)
      then do;
         if (substr (msg, 4, 2) ^= ") ")/* He didn't prefix his	       */
         then msg = "Xef) " || msg;	/* ..message so add my prefix to it  */
         goto print_error;
      end;
      goto print_error_rc; %page;
dcl 1 ted_sup	like ted_support;
dcl hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl cu_$ptr_call	entry options (variable); %page;
/* . . . buffer request 	: change current buffer		       */

cmd (098):			/* b */
      call ignore_all;

      if (b.cur.sn ^= 0)		/* if buffer not empty	       */
      then do;
         if (b.b_.l.le ^= 1) | (b.b_.r.re ^= b.maxl)
         then b.a_.l.ln (0), b.a_.r.ln (0), b.maxln = -1; /* #140*/
         b.b_.l.le = 1;		/* open up window again	       */
         b.b_.l.ln = 1;
         b.b_.r.re = b.maxl;
         b.b_.r.ln = b.maxln;
         if ^b.pseudo
         then if (b.cur.ast = 1) | (b.cur.ast = 2) /* if separate segment   */
	    then call promote$seg;	/* ..garbage collect it	       */
      end;
      if alt_sw
      then do;
         if (b_depth = 10)
         then goto err_Blv;
         b_depth = b_depth + 1;
         b_stack (b_depth) = bp;
      end;
      if (substr (rl_s, rl_i, 2) = "()") & ^not_sw
      then do;
         req_str = req_str || "()";
         rl_i = rl_i + 2;
         if (b_depth = 0)
         then goto err_Bnr;
         if com_blank then call ck_blank;
         bp = b_stack (b_depth);
         b_depth = b_depth - 1;
         if (b.b_.l.le ^= 1) | (b.b_.r.re ^= b.maxl)
         then b.a_.l.ln (0), b.a_.r.ln (0), b.maxln = -1; /* #140*/
         b.b_.l.le = 1;		/* open up window again	       */
         b.b_.l.ln = 1;
         b.b_.r.re = b.maxl;
         b.b_.r.ln = b.maxln;
      end;
      else do;
         used = rl_l - rl_i + 1;
         if not_sw			/* must exist or is an error	       */
         then call tedget_existing_buffer_ (dbase_p,
	         addr (rl_c (rl_i)), used, tbp, msg);
         else call tedget_buffer_ (dbase_p,
	         addr (rl_c (rl_i)), used, tbp, msg);
         rl_i = rl_i + used;
         if tbp = null
         then goto rq_err_msg;
         if com_blank then call ck_blank;
         if not_sw
         then do;
	  if (tbp = bp)
	  then goto err_Bnd;
	  do i = 1 to b_depth;
	     if (tbp = b_stack (i))
	     then goto err_Bnd;
	  end;
	  if tbp -> b.no_io
	  then goto not_allowed;
	  bp = tbp;
	  call delete;
	  call iso_line;
	  b.name = "";
	  return (NX_REQ);
         end;
         bp = tbp;			/* Make new buffer current	       */
/**** Make sure the gap is within window or we're in trouble elsewhere.      */
         if (b.b_.l.re > b.a_.r.le (2)) | (b.b_.r.le <= b.a_.l.re (1))
         then do;
	  call openup;
	  b.a_.l.re (1) = b.b_.l.re + 1;
         end;
/**** fix up LN stuff here					       */

         b.b_.l.le = b.a_.l.re (1);	/* setup the addressed window	       */
         b.b_.l.ln = b.a_.l.ln (1);
         b.b_.r.re = b.a_.r.le (2);
         b.b_.r.ln = b.a_.l.ln (2);
      end;

      if (b.b_.l.le > b.a_.r.re (0)) | (b.b_.r.re < b.a_.l.le (0))
      then do;			/* "." outside window	       */
         b.a_.l.le (0) = b.b_.l.le;
         b.a_.r.re (0) = addr_undef;
      end;
      else do;
      /*** anything here? */
      end;
      cb_w_r, cb_c_r = rel (bp);
      if db_ted
      then call tedshow_ (bp, ". b adr");

      return (NX_REQ); %page;
/* . . . move request 	: move data from one buffer to another	       */

cmd (109):			/* m */
cmd (107):			/* k */
      app_sw = alt_sw;
      if ""b then do;
cmd (077):			/* M */
cmd (075):			/* K */
         app_sw = "1"b;
      end;
      if db_Ed
      then do;
         db_ted = "1"b;
      end;
      call default$cur_line;
mo3:
      sbp = bp;
      b.a_.l.le (1) = b.a_.l.re (1);
/**** Setup source address range				       */
      b.cd.l.re = b.a_.l.re (1);
      b.cd.r.le = b.a_.r.le (2);
      used = rl_l - rl_i + 1;
      call tedget_buffer_ (dbase_p, addr (rl_c (rl_i)), used, dbp, msg);
				/* get ctl block of destination      */
      rl_i = rl_i + used;
      if (dbp = null)
      then goto rq_err_msg;
      if dbp -> b.present (2)
      then do;
         msg = "Gma) 2nd addr not allowed on destination.";
         goto add_request;
      end;
      bp = dbp;
      if ^b.present (1) & (b.cur.sn ^= 0)
      then call default$whole_buffer;
      bp = sbp;
      if com_blank then call ck_blank;
/**** I don't remember why the 2nd line down got commented out.	   JAF */
/**** BECAUSE the only time b_.r.re<=a_.r.le(2) is when upper is empty       */
      if (dbp -> b.b_.l.le <= dbp -> b.b_.l.re) /* lower part not empty,    */
/****    & (dbp -> b.b_.r.re < dbp -> b.b_.r.le) /* ..upper part empty, &    */
	 & (dbp -> b.b_.r.re <= dbp -> b.a_.r.le (2)) /* ..addr refs upper   */
      then dbp -> b.a_.r.le (2) = dbp -> b.b_.l.re; /* ....use lower part    */

/**** Setup destination address point				       */
      dbp -> b.cd.r.re = dbp -> b.a_.r.le (2) + 1;
      if (dbp = sbp)
      then do;			/* destination is current buffer     */
         if ^app_sw
         then do;			/* doing "m" or "k"		       */
	  msg = "Bnm) Can't m/k to current buffer.";
	  goto add_request;
         end;
         else if (rqc = "M")		/* Can't move into middle of what    */
         then do;			/* ..is being deleted by the move.   */
	  if (b.cd.l.re <= b.cd.r.re) & (b.cd.r.re <= b.cd.r.le)
	  then do;
	     msg = "Xbm) Bad move spec.";
	     goto add_request;
	  end;
         end;
      end;

      if ^app_sw			/* gonna wipe old buffer contents?   */
      then do;
         bp = dbp;
         if (b.cur.sn ^= 0)		/* are there any old contents?       */
         then if b.file_sw & b.mod_sw
				/* is this a modified file?	       */
	         | b.not_pasted	/* or is it unused, moved text?      */
	    then do;		/*    ask first		       */
	       query_info.status_code = error_table_$inconsistent;
	       call command_query_ (addr (query_info), answer, DBA,
		  "Do you want to overwrite b(^a)? " ||
		  "It contains ^[modified file ^a>^a^a^a^;text ^a^]",
		  b.name, b.file_sw, b.dname, b.ename, b.kind, b.cname);
	       if (substr (answer, 1, 1) = "n")
	       then return (NX_LIN);
	    end;
         if ^b.force_name		/* if name not forced on buffer..    */
         then b.file_sw = "0"b;	/*   ..set "no file associated" on.. */
				/*   ..receiving buffer	       */
         call delete$all;
         bp = sbp;
      end;
/**** Since it is felt that M/K will be done most often without a	       */
/****  destination address, the data is being placed on the left end to      */
/****  minimize the movement as each new piece is appended.		       */
      call buffer_buffer_copy (sbp, dbp, "0"b);
      bp = dbp;			/* go check things about destination */
      if (dbp ^= sbp)		/* if source^=destination buffer     */
      then do;
/****    Make sure the gap is between lines.  Everything assumes this to be  */
/****      the case.					       */
         if (b.b_.l.re >= b.b_.l.le)	/* is there a lower part?	       */
         then do;
	  if (b_c (b.b_.l.re) ^= NL)	/* does lower part not end in NL...  */
	       & (b.b_.r.re >= b.b_.r.le) /* ..and is there an upper part?     */
	  then do;
/**** The hole gets moved to a line boundary. Data is moved upward.	       */
/****  N.B.: A file which does not end with NL could be all in lower part.   */
/****        such as after doing "$($)d"			       */
	     i = index (reverse (
		substr (b_s, b.b_.l.le, b.b_.l.re - b.b_.l.le + 1)), NL);
	     if (i = 0)
	     then b.a_.l.re (1) = b.b_.l.le; /* take what is left	       */
	     else b.a_.l.re (1) = b.b_.l.re - i + 2; /* -> just after NL   */
	     call openup;
	  end;
         end;
         b.a_.l.le (0), b.a_.l.re (0) = 1; /* set "." undefined	       */
         b.a_.r.le (0), b.a_.r.re (0) = addr_undef;
      end;
      if ^b.file_sw
      then do;			/* if there is no file name	       */
         msg = "  ";		/* ..then tell where the data	       */
         msg = msg || req_str;	/* ..came from.		       */
         msg = msg || " from b(";
         msg = msg || rtrim (sbp -> b.name);
         msg = msg || ")";
         b.dname = msg;
      end;
      bp = sbp;			/* go back to source buffer	       */

      if (rqc = "m") | (rqc = "M")
      then do;
         if (ted_mode ^= COM)
         then dbp -> b.not_pasted = "1"b;
         b.a_.l.re (1) = b.cd.l.re;	/* restore source address range      */
         b.a_.r.le (2) = b.cd.r.le;
         call delete;
      end;
      else dbp -> b.not_pasted = "0"b;
      call iso_line;		/* This is done for both move and    */
				/*  kopy for consistency.	       */
      return (NX_REQ); %page;
/* . . . status ("x") request 	: list status of all buffers   . . . */

cmd (088):			/* X */
X_status:
      if (rl_c (rl_i) = NL)
      then select = b.name;
      else do;
         rl_i = rl_i + verify (substr (rl_s, rl_i), " ") - 1;
         if (rl_c (rl_i) ^= "(")
         then do;
	  select = rl_c (rl_i);
	  rl_i = rl_i + 1;
         end;
         else do;
	  i = index (substr (rl_s, rl_i + 1), ")");
	  if (i = 0)
	  then goto err_Smp;
	  select = substr (rl_s, rl_i + 1, i - 1);
	  rl_i = rl_i + i + 1;
         end;
      end;
      goto status;
cmd (120):			/* x */
      if alt_sw
      then goto X_status;
      select = " ";
      if com_blank
      then if (rl_c (rl_i) = "m")
	 then do;
	    req_chx = "m";
	    req_str = req_str || "m";
	    rl_i = rl_i + 1;
	 end;
status:
      call ignore_both;
      if com_blank then call ck_blank;
      if (req_chx = " ")
      then call tedlist_buffers_ (dbase_p, select, "1"b, ln_sw);
      else do;
         call tedcheck_buffers_ (dbase_p, wct);
         if (wct = 0)
         then call ioa_ ("No modified buffers.");
      end;
      return (NX_REQ); %skip (2);
/* . . . print current line number ("=") request 	: prints out line # current line in buffer */

cmd (061):			/* = */
      if com_blank then call ck_blank;
      call ignore_1;
      call default$cur_line;
      call iso_line;		/* set "." to addressed line	       */
      msg = "";
      if string_sw
      then do;
         msg = msg || "0(";
         j = b.a_.l.re (1);
         if (b.a_.l.re (1) > b.b_.l.re)
         then j = j - (b.b_.r.le - b.b_.l.re - 1); /* subtract hole size    */
         msg = msg || ltrim (char (j));
         msg = msg || ")	";
      end;
      call tedcount_lines_ (bp, b.b_.l.le, b.a_.l.re (1), j);
      msg = msg || ltrim (char (j));
      jb = b.a_.l.re (1) - b.a_.l.le (1) + 1;
      if (jb > 1)
      then do;
         msg = msg || "(";
         msg = msg || ltrim (char (jb));
         msg = msg || ")";
      end;
      if ln_sw
      then do;
         msg = msg || " <<";
         msg = msg || ltrim (char (b.a_.r.ln (2)));
      end;
      msg = msg || NL;
      call iox_$put_chars (iox_$user_output, msg_ptr, length (msg), 0);
      return (NX_REQ); %page;
/* . . . global/exclude request       : repeat given request for lines       */
/*				(not) containing) regfexp	       */

cmd (118):			/* v */
      xsw = "1"b;			/* exclude request		       */
      if ""b then do;

cmd (103):			/* g */
         xsw = "0"b;		/* global request		       */
      end;
      Psw = "0"b;			/* set to show not doing "P"	       */
      call default$whole_buffer;	/* Default: global whole window      */
      if rl_i > rl_l
      then goto err_Sd1;		/* error if nothing follows g or v   */
				/*  request		       */
      b.a_.l.re (1) = b.a_.l.le (1);	/* force line orientation	       */
      b.a_.r.le (2) = b.a_.r.re (2);
      req_chx = rl_c (rl_i);		/* get global sub-request	       */
      req_str = req_str || req_chx;
      if (req_chx = "*")
      then do;
         if (gbp = null ())
         then do;
	  argname = "((g*))";
	  call tedget_buffer_ (dbase_p, addr (argname), length (argname),
	       gbp, msg);
         end;
         gbp -> b.noref = "1"b;	/* Mark buffer invisible to "x"      */
         rl_i = rl_i + 1;
         if (rl_i < rl_l)
         then do;
	  call gv_compile;
         /*** NLlast has been set by gv_compile		       */
	  NLlast = NLlast & gvNL;
	  if (code ^= 0)
	  then goto print_error;
         end;
      end;
      else if (req_chx = "h") | (req_chx = "H")
      then do;
         rl_i = rl_i + 1;
         msg = "ted_";
         msg = msg || req_ch;
         msg = msg || "tabout_";
         goto do_tabout;
      end;
      else do;
         if (substr (rl_s, rl_i, 2) = "!p")
         then do;
	  req_not = req_ch;
	  req_str = req_str || "p";
	  req_ch = "!";
	  req_chx = "p";
	  alt_sw = "1"b;
	  rl_i = rl_i + 1;
         end;
         else if (req_chx = ".")
         then do;
	  req_chx = substr (nulreq, 1, 1);
	  if (req_chx = "!")
	  then req_chx = "P";
         end;
         else if (index ("p=Pd", req_chx) = 0)
         then goto invalid_request;
         if (index ("p=P", req_chx) = 0)
         then NLlast = ""b;
         else NLlast = "1"b;
         rl_i = rl_i + 1;
         call scan;
         if (expr_l > 0)
         then call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
	         addr (dbase.regexp), (string_sw), (dbase.lit_sw), msg, code);
/****         if (req_chx = "h")				       */
/****         then do;					       */
/****	       call TABSCAN;				       */
/****         end;						       */
      end;
dcl 1 the_line_no,
      2 l6	pic "zzzzz9",
      2 ch	char (1);
/**** During global processing, data is kept like this:		       */
/**** b.gb.l.le - current location				       */
/**** b.gb.l.re - last location to use in part			       */
/**** b.gb.l.ln - line number of current line			       */
/**** b.gb.r.re - last location to use in buffer			       */

      if com_blank then call ck_blank;
gb3:
      b.gb.l.le = b.a_.l.re (1);	/* hide away the address range       */
      b.gb.l.ln = b.a_.l.ln (1);
      b.gb.r.re = b.a_.r.le (2);
      b.gb.r.ln = b.a_.r.ln (2);
      if (b.gb.r.re <= b.b_.l.re)	/* if ends in lower part	       */
	 | (b.gb.l.le >= b.b_.r.le)	/* ..or begins in upper part	       */
      then b.gb.l.re = b.gb.r.re;	/* ..part limit is address limit     */
      else b.gb.l.re = b.b_.l.re;	/* otherwise part limit is l.re      */
      if (req_chx = "=")
	 | (req_chx = "*")
	 | ((req_chx = "p") & alt_sw)
	 | (req_chx = "P")
      then do;
         call tedcount_lines_ (bp, b.b_.l.le, b.gb.l.le, b.gb.l.ln);
         pi_label = gb_quit;
         pi_sw = 1;
      end;
      else do;
         pi_sw = 2;
         b.gb.l.ln = 1;
      end;
      if db_ted
      then call ioa_$ioa_switch (db_output, "^2-gb:^i <<^i", b.gb.l.ln, b.a_.l.ln (1));
      b.a_.l.ln (1) = b.gb.l.ln;
      if (req_chx = "P") | ((req_chx = "p") | alt_sw)
      then the_line_no.ch = HT;
      if (req_chx = "=")
      then the_line_no.ch = NL;
gb_loop:
      b.a_.l.le (1), b.a_.l.re (1) = b.gb.l.le; /* get begin of cur line   */
      b.a_.r.ln (2) = b.a_.l.ln (1);
      i = index (			/* then find end of it	       */
	 substr (b_s, b.gb.l.le, b.gb.l.re - b.gb.l.le + 1), NL);
      if (i = 0)			/* worry about no NL at EOB	       */
      then b.a_.r.le (2) = b.gb.l.re;
      else b.a_.r.le (2) = b.gb.l.le + i - 1;
      b.a_.r.re (2) = b.a_.r.le (2);
      b.gb.l.le = b.a_.r.le (2);	/* get beginning of next line..      */
      if (b.gb.l.le <= b.gb.l.re)	/* ..if we can		       */
      then b.gb.l.le = b.gb.l.le + 1;
      if db_ted
      then call tedshow_ (bp, ". gv a1 a2 gb");

      if Psw			/* it's P, don't bother searching    */
      then goto gb_p1;
      if (req_chx = "*")
      then do;
         call gv_srch;
         goto gb_end;
      end;
				/* search line for REGEXP	       */
      call tedsrch_$search (addr (dbase.regexp), bp, b.a_.l.re (1),
	 b.a_.r.le (2), mi, me, me2, msg, code);
      if (code = 2)
      then goto print_error;
      if xsw = (code ^= 0)		/* ^match w/ exclude request	       */
      then do;			/*  OR match w/ global request       */
				/* this line is to be processed      */
         if (req_chx = "p")		/* doing "p" request?	       */
         then if alt_sw
	    then goto gb_p1;
	    else goto gb_p2; %skip (3);
         if (req_chx = "P")
         then do;
gb_p1:
	  the_line_no.l6 = b.gb.l.ln;
	  call iox_$put_chars (iox_$user_output, addr (the_line_no), 7, 0);
gb_p2:
	  call iox_$put_chars (iox_$user_output, addr (b_c (b.a_.l.re (1))),
	       b.a_.r.le (2) - b.a_.l.re (1) + 1, 0);
	  if intsw then goto gb_quit; /* abort request if PI has occurred  */
         end; %skip (3);
         else if (req_chx = "=")
         then call ioa_$nnl ("^i^a", b.gb.l.ln, the_line_no.ch);
         else do;
	  if (req_chx = "d")
	  then call delete;		/* iso_line not needed	       */
         end;
      end;

gb_end:
      if (b.gb.l.le <= b.gb.l.re)
      then do;
         b.gb.l.ln = b.gb.l.ln + 1;	/* increment line counter	       */
         goto gb_loop;		/* check for last line processed     */
      end;
      if (b.gb.l.re ^= b.gb.r.re)	/* if there is a split	       */
      then do;			/* ..move to upper part & continue   */
         b.gb.l.le = b.b_.r.le;
         b.gb.l.re = b.gb.r.re;
         goto gb_end;
      end;
gb_quit:
      pi_sw = 0;
      b.gb = tedcommon_$no_data;
/**** Don't leave unused buffer there.				       */
      if (b.b_.l.le > b.b_.l.re) & (b.b_.r.le > b.b_.r.re)
      then call delete$all;		/* #142*/
      else if (b.a_ (2).r.le > b.b_.r.re) /* was last line deleted?	       */
      then b.a_ (2).r.le = b.b_.l.re;	/* point to new last line.	   #162*/
      call iso_line;		/* when done, leave current line at  */
				/* ..last line processed	       */
      if (req_chx = "*")		/* g* uses the rest of the line      */
      then rl_i = rl_l;
      if NLlast
      then call iox_$put_chars (iox_$user_output, addr (NL), 1, 0);
      return (NX_REQ); %page;
/* . . . PRINT request 	: print with line numbers . . . */

cmd (080):			/* P */
      if com_blank then call ck_blank;
      call default$cur_line;		/* default addr (.,.) if needed      */
PRINTb:
      req_chx = req_ch;
      req_ch = " ";
      NLlast = ""b;
      Psw = "1"b;			/* set sw to show PRINT */
      goto gb3;

/* . . . tab-out request . . . */
cmd (072):			/* H */
cmd (104):			/* h */

      msg = "ted_tabout_";
do_tabout:
      if (rl_c (rl_i) = " ")
      then goto err_Sd1;
				/* RW 88 */
      call default$cur_line;		/*#193*/
      goto do_call; %skip (3);
/* . . . tab-in request  . . . */

cmd (121):			/* y */

      if com_blank then call ck_blank;
      b.a_.l.re (1) = b.a_.l.le (1);	/* line oriented only	       */
      msg = "ted_tabin_";		/* simulate obsolete request	       */
				/* RW 88 */
      call default$cur_line;		/*#193*/
      goto do_call; %page;
/* . . . define label . . . */

cmd (058):			/* : */
      i = rl_i;
      if (rl_c (rl_i) = "(")
      then do;
         il = index (substr (rl_s, rl_i), ")");
         if (il = 0)
         then goto err_Smp;
         if (il > 16)
         then goto err_Slx;
      end;
      else il = 1;
      rl_i = rl_i + il;
      if com_blank then call ck_blank;
      if flow_sw
      then call ioa_ ("**FLOW **	^a", substr (rl_s, i, il));
      return (NX_REQ); %skip (3);
/* . . . nop request 	: change value of "." and get next request from input line */

cmd (110):			/* n */
nullrq:
      if com_blank then call ck_blank;
      if ^b.present (1)
      then return (NX_REQ);		/* ignore if no address given	       */
      if alt_sw & b.present (2)
      then do;
         b.a_.l (0) = b.a_.l (1);
         b.a_.r (0) = b.a_.r (2);
         return (NX_REQ);
      end;
      if (b.a_.r.le (1) = 0)
      then do;
         b.a_.l.le (0), b.a_.l.re (0) = 1;
         b.a_.r.le (0), b.a_.r.re (0) = 0;
         return (NX_REQ);
      end;
      b.a_.r.le (2) = b.a_.r.le (1);
      call ignore_2;
      call iso_line;		/* change "." to last line addressed */
      return (NX_REQ);
%page;
/* . . . goto label in this buffer . . . */

cmd (062):			/* > */
ref_label:
      call ignore_all;
      tc = rl_c (rl_i);
      i = rl_i;
      if (tc = "(")
      then do;
         il = index (substr (rl_s, rl_i), ")");
         if (il = 0)
         then goto err_Smp;
         if (il > 16)
         then goto err_Slx;
      end;
      else if (tc = "+") then goto rel_go;
      else if (tc = "-")
      then do;
rel_go:
         il = 2;
         if (index ("0123456789", rl_c (rl_i + 1)) = 0)
         then goto err_Sbd;
      end;
      else il = 1;
      if (tc ^= NL)
      then do;
         rl_i = rl_i + il;
         if (rl_c (rl_i) = ":")
         then do;
	  rl_i = rl_i + 1;
	  code = 1;
         end;
         else code = 0;
         if com_blank then call ck_blank;
      end;
      if not_sw
      then do;
         err_go = substr (rl_s, i, il);
         return (NX_REQ);
      end;
      call tedset_ptr_ (dbase_p, substr (rl_s, i, il), code);
      if (code = 0)
      then do;
         return (NX_LIN);
      end;
      if (code = 10)
      then goto rq_err;
      return (NX_REQ); %skip (4);
/* . . . return from current buffer . . */

cmd (126):			/* ~ */

      call tedend_buffer_ (dbase_p, code);
      return (NX_LIN); %page;
/* . . . comment delimiter (") found 	: change value of "." to last line addressed and ignore rest of line */

cmd (034):			/* " */
comment:
      if ^b.present (1)		/* if no address given..	       */
      then return (NX_LIN);		/* ..ignore completely	       */
      call ignore_2;
      b.a_.r.le (2) = b.a_.r.le (1);
      call iso_line;		/* change "." to last line addressed */
      return (NX_LIN);		/* ignore remainder of request line  */
%skip (3);
/* . . . if-line request 	: test if current line is a specific one . . . */

cmd (035):			/* # */
if_line:
      if com_blank then call ck_blank;
      if (b.cur.sn = 0) then		/* defined to fail if buffer empty */
	 goto if_line_f;
      if ^b.present (1)		/* if no addr supplied,	       */
      then goto if_line_t;		/*    then buffer-empty test	       */
      call default$cur_line;
      if b.present (2)
      then do;
         if (b.a_.l.re (0) < b.a_.l.re (1))
         then goto if_line_f;
         if (b.a_.r.le (0) > b.a_.r.le (2))
         then goto if_line_f;
         goto if_line_t;
      end;
      else do;
         if (b.a_.l.re (0) = b.a_.l.re (1))
         then goto if_line_t;
      end;
if_line_f:			/* if_line_false */
      return (^not_sw);
if_line_t:			/* if_line_true */
      return (not_sw);

%page;
/* . . . z-subsystem request . . . */

cmd (122):			/* z */
      i = index (substr (rl_s, rl_i), " ");
      if (i = 0)
      then i = rl_l - rl_i;
      else i = i - 1;
      req_str = req_str || substr (rl_s, rl_i, i);
      if (substr (rl_s, rl_i, i) ^= "if")
      then do;
         if (b.cur.sn = 0)
         then do;
	  msg = "Abe) Buffer empty.";
	  goto print_error;
         end;
         call default$line_eval;
         if (substr (rl_s, rl_i, i) = "dump")
         then do;
	  rl_i = rl_i + i;
	  msg = "ted_dump_";
	  goto do_call;
         end;
         if (substr (rl_s, rl_i, i) = ".fi.na")
         then do;
	  rl_i = rl_i + i;
	  msg = "ted_fina_";
	  goto do_call;
         end;
         if (substr (rl_s, rl_i, i) = ".fi.ad")
         then do;
	  rl_i = rl_i + i;
	  msg = "ted_fiad_";
	  goto do_call;
         end;
      end;
      rl_i = rl_i + i;
      rl_i = rl_i + verify (substr (rl_s, rl_i), " ");

/**** "zif" falls into "{" routine, after having adjusted rl_i properly      */

/* . . . evaluate request "{" . . . */
cmd (123):			/* { */

      rl_i = rl_i - 1;
      if b.present (1)
      then call default$line_eval;
      used = rl_l - rl_i + 1;
      call tedeval_ (dbase_p, addr (rl_c (rl_i)), used,
	 bp, null (), 0, result, msg, code);
      rl_i = rl_i + used;
      if (code ^= 0)
      then do;
eval_err:
         if (code < 100)
         then goto print_error;
         goto print_error_rc;
      end;
      if (req_str = "zif")
      then do;
         if (result = "0") | (result = "false")
         then return (NX_LIN);
         else return (NX_REQ);
      end;
      if (length (result) ^= 0)
      then do;
         msg = "{ has result """;
         msg = msg || result;
         msg = msg || """.
";
         call iox_$put_chars (iox_$error_output, msg_ptr, length (msg), 0);
      end;
      return (NX_REQ); %page;
/* . . . file-output request	: direct "user_output" to a buffer . . */

cmd (102):			/* f */
      if fo_sw
      then do;			/* #147*/
fo_err:
         if go_sw then msg = "EFo) F";	/* #147*/
         else msg = "Efo) f";		/* #147*/
         msg = msg || " already active";/* #147*/
         goto print_error;		/* #147*/
      end;			/* #147*/
      go_sw = "0"b;
      if alt_sw
      then do;
cmd (070):			/* F */
         if (rl_c (rl_i) = NL)
         then do;
	  go_sw = "0"b;
	  return (NX_LIN);
         end;
         if fo_sw
         then goto fo_err;		/* #147*/
         go_sw = "1"b;
      end;
      call ignore_all;
      used = rl_l - rl_i + 1;
      call tedget_buffer_ (dbase_p, addr (rl_c (rl_i)), used, fop, msg);
      rl_i = rl_i + used;
      if (fop = null)
      then goto rq_err_msg;
      if com_blank then call ck_blank;
      if (pdname = " ")
      then pdname = get_pdir_ ();
      begin;
         fo_name = "ted_."; dcl pic2 pic "99";
         substr (fo_name, 6, 2) = convert (pic2, dbase.recurs);
         got_quit = "0"b;		/* We can't be interrupted while we  */
         on quit got_quit = "1"b;	/* ..are messing with switches       */
         call iox_$attach_name (fo_name, fcbp, "vfile_ " || pdname
	    || ">" || "ted_." || dbase.rq_id, null (), code);
         if (code ^= 0)
         then do;
	  call com_err_ (code, DBA, "attach ted_fo");
	  signal condition (ted_fo_err);
         end;
         call iox_$open (fcbp, 2, "0"b, code);
         if (code ^= 0)
         then do;
	  call com_err_ (code, DBA, "open ted_fo");
	  signal condition (ted_fo_err);
         end;
         call iox_$find_iocb (fo_name || "save", fcbsp, code);
         if (code ^= 0)
         then call com_err_ (code, DBA, "find ^asave", fo_name);
         call iox_$move_attach (iox_$user_output, fcbsp, code);
         if code ^= 0
         then call com_err_ (code, DBA, "move attach user_output");
         code = iox_$attach_iocb (iox_$user_output, "syn_ " || fo_name);
         if (code ^= 0)
         then do;
	  call com_err_ (code, DBA, "attach user_output");
         end;
         fo_sw = "1"b;
         revert quit;
      end;
      if got_quit
      then signal quit;
      return (NX_REQ);

   end do_req; %page;
upper_lower: proc (expr_p, upper);

dcl expr_p	ptr,		/* -> compiled expression area       */
    upper		bit (1);		/* 1-to upper	0-to lower       */

Uu_loop:
      call tedsrch_$search (expr_p, bp,
	 b.a_.l.re (1), b.a_.r.le (2), mi, me, me2, msg, code);
      if (code = 0)
      then do;
         b.mod_sw = "1"b;
         ml = me - mi + 1;
         if (ml = 0)
         then b.a_.l.re (1) = mi + 1;
         else do;
	  b.a_.l.re (1) = me + 1;
	  if upper
	  then substr (b.cur.sp -> b_s, mi, ml)
		  = translate (substr (b.cur.sp -> b_s, mi, ml), AZ, az);
	  else substr (b.cur.sp -> b_s, mi, ml)
		  = translate (substr (b.cur.sp -> b_s, mi, ml), az, AZ);
         end;
         if (b.a_.l.re (1) <= b.a_.r.le (2))
         then goto Uu_loop;
      end;
      if (code = 2)
      then goto print_error;
      call iso_line;

   end upper_lower; %page;
substitute: proc (axp);

dcl axp		ptr;		/* -> compiled search expression     */
/****comptr			** -> compiled replace expression    */
dcl IC		fixed bin;

      IC = gvx.ic;
sub_loop:
      call tedsrch_$search (axp, bp,
	 b.a_.l.re (1), b.a_.r.le (2), mi, me, me2, msg, code);
      if code = 0
      then do;
         dbase.S_count = dbase.S_count + 1;
         subsw = "1"b;		/* indicate something found	       */
         gvx.ic = IC;
         cfp = addr (gvx.word (gvx.ic));
         call replace (mi, me, me2);
         if b.a_.l.re (1) <= b.a_.r.le (2)
         then goto sub_loop;		/* until end of addressed portion    */
				/* of buffer reached	       */
      end;
      call iso_line;		/* set cur line to last line srched  */

   end substitute; %skip (4);
replace: proc (ami, ame, ame2);

dcl (
    ami		fixed bin (21),	/* beginning of match	       */
    ame		fixed bin (21),	/* end of match		       */
    ame2		fixed bin (21));	/* last char searched	       */
/**** cfp points to next compiled expression entry		       */

dcl ml		fixed bin (21);	/* length of string matched	       */
dcl i		fixed bin;
dcl rep_p		ptr;		/* ->matched string		       */
dcl temp_p	ptr;		/* ->temp seg for matched string     */
dcl temp_sn	fixed bin;	/* # of temp seg if it was needed    */

      b.a_.r.le (1) = ame;		/* save match end for relocation     */
      b.a_.r.re (1) = ame2;		/* save search end for relocation    */
      b.a_.l.re (1) = ami;		/* set location for openup	       */
      call openup;
      rep_p = addr (b_c (b.a_.l.re (1)));
      temp_sn = 0;
      ml = ame - ami + 1;		/* find out how long the match was   */
      do cfp = cfp repeat (addr (gvx.word (gvx.ic)));
         if db_srch
         then call tedshow_ (comptr, "cf");
         if (cf.op >= seval_op) & (cf.op <= srepl_op)
         then goto repop (cf.op);
				/*  not a replace operation, quit    */
         if ml = 0			/* if matched string was null	       */
         then do;			/* insure we find a different	       */
				/*  null string next time	       */
	  b.a_.l.re (1) = b.a_.l.re (1) + 1;
         end;
         else do;			/* matched str not null	       */
	  i = index (substr (b_s, b.a_.l.re (1), ml), NL);
	  if (i > 0)		/* NL in old string?	       */
	  then do;
	     if (i = ml)		/* The NL is at the end, therefore   */
	     then do;		/* ..it must be the only one.	       */
	        if (b.maxln > 1)	/* If line count is known, decrement */
	        then b.maxln = b.maxln - 1;
	        else b.maxln = -1;
	     end;
	     else do;
				/* (could see if there are no more)  */
	        b.maxln = -1;	/* forget the count		       */
	     end;
	     b.b_.l.ln, b.b_.r.ln = -1; /* forget the rest	       */
	  end;
	  b.mod_sw = "1"b;
	  if (temp_sn ^= 0)		/* if we had to copy match, clean up */
	  then call tedfree_segment_ (dbase_p, temp_sn);
	  else b.b_.r.le = b.a_.r.le (1) + 1; /* throw away old string     */
	  b.a_.l.re (1) = b.a_.r.re (1) + 1; /* resume at me2 + 1	       */
         end;
         if db_ted
         then call tedshow_ (bp, ". rep b_ a1");
         return;

repop (-1):			/* literal insert		       */
         call add_rep (addr (cf.da), (cf.len), NLct_check);
         goto end_rep;

repop (-2):			/* (replace with matched string)     */
         if (ml > 0)		/* .. skip if null string found      */
         then do i = 1 to cf.len;
	  call add_rep (rep_p, ml, NLct_check);
         end;
         goto end_rep;

repop (-3):			/* "equal" convention: x\= gives     */
				/*  x repeated matchlength times     */
         if (ml > 0)
         then begin;
dcl str		char (ml);
	     str = copy (cf.da, ml);
	     call add_rep (addr (str), ml, ml * fixed (cf.da = NL));
	  end;
         goto end_rep;

repop (-4):			/* evaluation		       */
         call tedeval_ (dbase_p, addr (cf.da), (cf.len),
	    bp, addr (b_c (b.a_.l.re (1))), ml, result, msg, code);
         if (code ^= 0)
         then goto print_error;
         if (length (result) > 0)
         then call add_rep (addrel (addr (result), 1), length (result),
	         NLct_check);
end_rep:
         gvx.ic = gvx.ic + cf.siz;
      end;
add_rep: proc (r_p, r_l, NLcheck);

dcl r_p		ptr,		/* ->replacement string	       */
    r_l		fixed bin (21),	/* length of it		       */
    NLcheck	fixed bin (21);	/* NL check flag		       */
dcl space		fixed bin (21);
dcl m		char (ml) based;

      if (b.cur.ast = 1)		/* if the buffer is full size	       */
	 & (temp_sn = 0)		/* ..& match string is still in      */
      then do;			/* ..the buffer, do the check	       */
         space = b.b_.r.le - b.b_.l.re - 1; /* how much room left	       */
         space = space - r_l;		/* how much left after adding	       */
         if (space < 0)		/* if not enough room left	       */
	    & ((space + ml) >= 0)	/* ..but removing match would help   */
         then do;			/* move the match string elsewhere   */
	  call tedget_segment_ (dbase_p, temp_p, temp_sn);
	  temp_p -> m = rep_p -> m;	/* copy match out of buffer	       */
	  b.b_.r.le = b.a_.r.le (1) + 1; /* remove from buffer	       */
	  rep_p = temp_p;		/* point to new location	       */
         end;
      end;			/* we have done the best we could    */
      call add_2l (ted_safe, r_p, r_l, NLcheck);

   end add_rep;


/* never gets here */ %page;
replace$compile: entry;

      concealsw = "0"b;		/* initialize concealed-char. switch */
      cf.op = -255;
      cf.len = 0;
      do rl_i = j to rl_l;		/* compile char's from str2 */
         ch = rl_c (rl_i);
         if concealsw		/* check for concealed char.	       */
         then do;
	  concealsw = "0"b;		/* reset concealed-char. switch      */
	  call make_rp (srepl_op, ch);
         end;
         else if (ch = delim)
         then do;
	  cf.siz = size (cf);
	  call end_cf;
	  rl_i = rl_i + 1;
	  return;
         end;
         else if ch = BS_C		/* check for concealment char. BS_C  */
         then concealsw = "1"b;	/* set switch to conceal next char.  */
         else if (ch = "\")
         then do;
	  if (index ("cC", rl_c (rl_i + 1)) > 0)
	  then do;
	     rl_i = rl_i + 1;
	     concealsw = "1"b;
	  end;
	  else if (index ("gG", rl_c (rl_i + 1)) > 0)
	  then do;
/**** really need to look for quoted strings in the process...	       */
	     i = index (substr (rl_s, rl_i + 1), "}");
	     if (i = 0)
	     then do;
	        msg = "Gvd) Missing } on \g{.";
	        goto gv_msg_com;
	     end;
	     call make_rp (seval_op, substr (rl_s, rl_i + 2, i - 1));
	     rl_i = rl_i + cf.len + 1;

	  end;
	  else if (ch = "=")
	  then do;
	     rl_i = rl_i + 1;
	     if (cf.len = 0)
	     then goto err_Sne;
	     ch = substr (cf.da, cf.len, 1);
	     cf.len = cf.len - 1;
	     call make_rp (sdup_op, ch);

	  end;
	  else call make_rp (srepl_op, ch);
         end;
         else if ch = "&"		/* (replace with matched string)     */
         then do;
	  call make_rp (sself_op, "&");

         end;
         else call make_rp (srepl_op, ch);
      end;
      goto err_Sd3;			/* shouldn't reach here	       */

make_rp: proc (op1, ch);
dcl op1		fixed bin,
    ch		char (*);

      if (cf.op ^= op1)		/* is element different than new one */
      then do;
         cf.siz = size (cf);
         call end_cf;
         cf.op = op1;
         if (op1 = 0)
         then return;
      end;
(nostringrange): substr (cf.da, cf.len + 1, length (ch)) = ch;
      cf.len = cf.len + length (ch);	/* add char to element	       */
      cf.siz = size (cf);
   end make_rp; %skip;
   end replace; %page;
print: proc;

      pi_label = end_pr;		/* allow printing to be aborted      */
      pi_sw = 1;			/*  by means of a PI	       */
      call addr_status (b.b_.l.le, b.b_.r.re);
      if (b_stat = B_LO_HI)		/* range is split,		       */
      then do;			/*   print left part	       */
         call iox_$put_chars (iox_$user_output,
	    addr (b_c (b.a_.l.re (1))),
	    b.b_.l.re - b.a_.l.re (1) + 1, 0); /* (ignoring return code)   */
         b.a_.l.re (1) = b.b_.r.le;	/* adjust to look unsplit	       */
         if db_ted
         then call ioa_$ioa_switch (db_output, "---- hole ----");
      end;
				/* here always looks like unsplit    */
      call iox_$put_chars (iox_$user_output,
	 addr (b_c (b.a_.l.re (1))),
	 b.a_.r.le (2) - b.a_.l.re (1) + 1, 0);
end_pr:
      pi_sw = 0;			/* turn off PI handling	       */

   end print; %page;
dcl fcbsp		ptr;
dcl fo_name	char (7);
dcl fop		ptr;		/* -> destination of file_out	       */
detach: proc (finish);

dcl finish	bit (1);

      fo_sw = "0"b;
      begin;
         got_quit = "0"b;		/* We can't be interrupted while we  */
         on quit got_quit = "1"b;	/* ..are messing with switches       */
         call iox_$detach_iocb (iox_$user_output, code);
         if (code ^= 0)
         then do;
	  call com_err_ (code, DBA, "detach user_output");
         end;
         call iox_$move_attach (fcbsp, iox_$user_output, code);
         if (code ^= 0)
         then do;
	  call com_err_ (code, DBA, "move attach ^asave", fo_name);
         end;
         call iox_$close (fcbp, code);
         call iox_$detach_iocb (fcbp, code);
         if (code ^= 0)
         then do;
	  call com_err_ (code, DBA, "detach ted_fo");
         end;
         revert quit;		/* Now we can be interrupted again   */
      end;
      if got_quit			/* If he tried to get thru earlier,  */
      then signal quit;		/* ..give it to him now.	       */
      if finish
      then return;
      old_bp = bp;
      bp = fop;
      call hcs_$initiate_count (pdname, "ted_." || dbase.rq_id, "", bc, 0,
	 tbp, code);
      if (tbp = null)
      then do;
         call com_err_ (code, "ted", "output_file (^a>ted_.^a)", pdname,
	    dbase.rq_id);
      end;
      else do;
         call delete$all;		/* iso_line not needed	       */
         call add_2l (ted_safe, tbp, divide (bc, 9, 21, 0), NLct_unknown);
         call hcs_$truncate_seg (tbp, 0, 0);
         call hcs_$terminate_noname (tbp, 0);
      end;
      if ^b.force_name
      then do;
         b.file_sw = "0"b;
         b.dname = "";
      end;
      b.a_.l.le (0), b.a_.l.re (0) = 1;
      b.a_.r.le (0), b.a_.r.re (0) = addr_undef;
      b.get_bit_count = "0"b;
      bp = old_bp;
dcl old_bp	ptr;

   end detach; %page;


dcl superfile	char (196) int static init (
		"l t|		CONTENTS|
b(arg1) ?1,1n t| (match ""| p t|"")| S|/|\c\c/| >s
a ^\F
:s b(exec) l l
>a \B(exec)
l l Q
:a /^		/ s/// +3*/^""/ s/$/                                 / (33),+3(1)d
*/\B(arg1)/ p
>a

"); %skip (4);
/* . . . MSG_PATH . . */

msg_path: proc (mark1);

dcl mark1		char (*);

/* RW 88 */
      msg = rtrim (msg) || " " || ltrim (rtrim (fd.dname)); /*#197*/
      if (msg ^= ">")
      then msg = msg || ">";
      msg = msg || rtrim (fd.ename);
      if (mark1 = " ")
      then return;
      msg = msg || mark1;
      if (mark1 = ":")
      then msg = msg || ":";
      msg = msg || rtrim (fd.cname);

   end msg_path; %skip (2);
ck_blank: proc;

      if (ted_mode ^= COM)
      then if (index ("
	 ", rl_c (rl_i)) = 0)
	 then goto err_Snb;

   end ck_blank;
%page;
ignore_1: proc;

/**** tell user that 1st addr will be ignored if present (in qedx mode)      */
      if ^b.present (2)		/* if there isn't any 2nd addr..     */
      then return;			/*  ..AOK			       */
      if ^qedx_mode			/* This warning only occurs in       */
      then goto not_2;		/* ..qedx mode.		       */
      b21 = "1st";
      goto common;

ignore_2: entry;

/**** tell user that 2nd addr will be ignored if present (in qedx mode)      */
      if ^b.present (2)		/* if there isn't any 2nd addr..     */
      then return;			/*   ..no sweat		       */
      if ^qedx_mode			/* if not in qedx mode	       */
      then do;			/* ..jump on him about it	       */
not_2:
         msg = "Sn2) 2 addrs not allowed.";
         goto add_request;
      end;
      b21 = "2nd";
      goto common;

ignore_all: entry;			/* ignore buffer change & addr's     */

dcl b21		char (4);

      bp = ptr (dbase_p, dbase.cb_c_r);
      cb_w_r = rel (bp);

ignore_both: entry;			/* keep buffer change, ignore addr's */

/**** tell user that both addr will be ignored if present (in qedx mode)     */
      if ^b.present (1)		/* if no addr..		       */
      then return;			/*   ..all is well		       */
      if ^qedx_mode			/* if not in qedx mode	       */
      then do;			/* ..complain		       */
         msg = "Sn1) No addrs allowed.";
         goto add_request;
      end;
      b21 = "both";
common:
      call ioa_ ("Warning: ^a ignores ^a addr.", req_str, b21);

   end ignore_1; %page;
scan: proc;

dcl ch		char (1);

      delim = rl_c (rl_i);		/* pick up str delimiter	       */
      if (delim = " ")
	 | (delim = NL)
      then goto err_Sd1;
      expr_b = rl_i + 1;
      concealsw = "0"b;
      do rl_i = rl_i + 1 to rl_l;	/* try to find end of str1      */
         if ^concealsw
         then do;
	  ch = rl_c (rl_i);
	  if (ch = delim)
	  then goto sub1;
	  if (ch = BS_C)
	  then concealsw = "1"b;
	  if (ch = "\")
	  then do;
	     if (rl_c (rl_i + 1) = "c")
	     then goto bs_c;
	     if (rl_c (rl_i + 1) = "C")
	     then do;
bs_c:
	        rl_i = rl_i + 1;
	        concealsw = "1"b;
	     end;
	  end;
         end;
         else concealsw = "0"b;
      end;

      goto err_Sd2;			/*  no end of str1		       */

sub1:
      expr_l = rl_i - expr_b;
      j, rl_i = rl_i + 1;		/*  first char of str2	       */

   end scan; %page;
dcl (
    B_MT		init (0),		/* buffer empty		       */
    B_LO_LO	init (1),		/* range is in low part	       */
    B_LO_HI	init (2),		/* range spans the hole	       */
    B_HI_HI	init (3)		/* range is in high part	       */
    )		fixed bin int static options (constant);

dcl b_stat	fixed bin;
dcl b_lhe		fixed bin (21);
dcl b_rhe		fixed bin (21);

addr_status_ends_set: proc (lhe, rhe);	/* set address and then...	       */
      b.a_.l.re (1) = lhe;
      b.a_.r.le (2) = rhe;

addr_status_ends: entry (lhe, rhe);	/* give status & left/right ends     */

dcl (lhe, rhe)	fixed bin (21);	/* left-hand/right-hand ends to use  */

/**** The A's represent the addressed range.			       */
/**** ................     buffer empty   --> b_stat = B_MT    (0)	       */
/**** xxAAAAxx...xxxxx - al=low   ar=low  --> b_stat = B_LO_LO (1)	       */
/**** xxxxxAAA...AAxxx - al=low   ar=high --> b_stat = B_LO_HI (2)	       */
/**** xxxx.....xAAAxxx - al=high  ar=high --> b_stat = B_HI_HI (3)	       */
/****	Any other conditions will cause an error message to be printed.    */
/**** b_lhe, b_rhe contain actual left and right data locations in buffer.   */

      if (b.cur.sn = 0)
      then do;
         b_stat = B_MT;
         goto finis;
      end;
      b_lhe = lhe;			/* find lefthand end	       */
      if (b.b_.l.re < b_lhe)		/* is lower part empty?	       */
      then b_lhe = b.b_.r.le;		/* ..switch to upper	       */
      b_rhe = rhe;			/* find righthand end	       */
      if (b.b_.r.le > b_rhe)		/* is upper part empty?	       */
      then b_rhe = b.b_.l.re;		/* ..switch to lower	       */
      if db_ted
      then call ioa_$ioa_switch (db_output, ".   :ends=^i,^i", b_lhe, b_rhe);

addr_status: entry (lhe, rhe);	/* give status only		       */
      if (b.cur.sn = 0)
      then do;
         b_stat = B_MT;
         goto finis;
      end;
/**** If there is an upper part & addr-left is just after lower part	       */
      if (b.b_.r.re >= b.b_.r.le) & (b.a_.l.re (1) = b.b_.l.re + 1)
      then b.a_.l.re (1) = b.b_.r.le;	/* switch to upper part	       */
/**** If there is a lower part & addr-right is just before upper part	       */
      else if (b.b_.l.re >= b.b_.l.le) & (b.a_.r.le (2) = b.b_.r.le - 1)
      then b.a_.r.le (2) = b.b_.l.re;	/* switch to lower part	       */
      if (b.b_.l.re + 1 >= b.a_.l.re (1))
      then do;
         if (b.b_.l.re + 1 >= b.a_.r.le (2))
         then do;
	  b_stat = B_LO_LO;
	  goto finis;
         end;
         if (b.b_.r.le <= b.a_.r.le (2))
         then do;
	  b_stat = B_LO_HI;
	  goto finis;
         end;
      end;
      else if (b.b_.r.le <= b.a_.l.re (1))
	 & (b.b_.r.le <= b.a_.r.le (2))
      then do;
         b_stat = B_HI_HI;
finis:
         if db_ted
         then call ioa_$ioa_switch (db_output, ".   :stat=^a",
	         substr ("MTLLLHHH", b_stat * 2 + 1, 2));
         return;
      end;
      call ioa_ ("Error: b=^i,^i,^i,^i a=^i,^i", lhe, b.b_.l.re, b.b_.r.le,
	 rhe, b.a_.l.re (1), b.a_.r.le (2));
      msg = "Aae) Addressing error occurred.";
      goto print_error;

   end addr_status_ends_set; %page;
buffer_buffer_copy: proc (asbp, adbp, add_right);

dcl asbp		ptr,		/* source buffer control block       */
				/* range to copy is-	       */
				/*    b.cd.l.re : b.cd.r.le	       */
    adbp		ptr,		/* destination buffer control block  */
				/* data is INSERTed at-	       */
				/*    b.cd.r.re		       */
    add_right	bit (1);		/* 0- data is added to left of hole  */
				/* 1- data is added right	       */

dcl old_bp	ptr;
dcl (sbp, dbp)	ptr;		/* -> source, destination ctl block  */
dcl tbp		ptr;
dcl lndx		fixed bin (21) based; /* left index for cpy_2 call      */
dcl (l, tl, tr)	fixed bin (21);

/**** Care must be taken to avoid being wiped out when source = destination. */
/**** These are various conditions which can happen when they are.	       */
/****   The "A"s represent the address range.			       */
/****   The "I"s represent the inserted data.			       */
/****   The "x"s represent the uninvolved data			       */
/****   The "."s represent the gap		Col 2 only happens with K. */
/**** Line 1  points to the destination.			       */
/**** Line 2  is the initial buffer state.			       */
/**** Line 3  is the state after openup.			       */
/**** Line 4  is the state after moving left part of range, if any.	       */
/**** Line 5  is the state after moving right part, if any.		       */
/**** Line 6  is the state after deletion (M only).		       */

/**** Inserting in ?, ? addressed data.		?, ? pairs shown below     */
/****							       */
/**** ?,? |    upper, above    |   upper, within    |   upper, below     |   */
/**** 1)  |  ..........v.....  |  ..........v.....  |  ..........v.....  |   */
/**** 2)  |  AAAxx....xxxxxxx  |  xxx......AAAAxxx  |  xx....xxxxxxAAAx  |   */
/**** 3)  |  AAAxxx....xxxxxx  |  xxxA......AAAxxx  |  xxxxxx....xxAAAx  |   */
/**** 4)  |  AAAxxxMMM.xxxxxx  |  xxxAM.....AAAxxx  |		   |   */
/**** 5)  |                    |  xxxAMNNN..AAAxxx  |  xxxxxxNNN.xxAAAx  |   */
/**** 6)  |  ....xxxMMMxxxxxx  |                    |  xxxxxxNNNxx....x  |   */

/**** ?,? |    lower, above    |   lower, within    |   lower, below     |   */
/**** 1)  |  ...v............  |  ....v...........  |  ...v............  |   */
/**** 2)  |  AAAxx....xxxxxxx  |  xxxAAAA......xxx  |  xxxxxxx....xAAAx  |   */
/**** 3)  |  AAA....xxxxxxxxx  |  xxxA......AAAxxx  |  xxx....xxxxxAAAx  |   */
/**** 4)  |  AAAMMM.xxxxxxxxx  |  xxxAM.....AAAxxx  |		   |   */
/**** 5)  |                    |  xxxAMNNN..AAAxxx  |  xxxNNN.xxxxxAAAx  |   */
/**** 6)  |  ....xxxMMMxxxxxx  |                    |  xxxxxxNNNxx....x  |   */

      sbp = asbp;			/* save parameter values, they get   */
      dbp = adbp;			/* ..clobbered sometimes	       */
      old_bp = bp;			/* keep current bp value	       */

      if db_ted
      then do;
         call ioa_$ioa_switch (db_output, ">bbc: b(^a,^i,^i)->b(^a,^i)^[right^;left^]",
	    sbp -> b.name, sbp -> b.cd.l.re, sbp -> b.cd.r.le,
	    dbp -> b.name, dbp -> b.cd.r.re, add_right);
         if (sbp = dbp)
         then call tedshow_ (sbp, ". s=d cd adr");
         else do;
	  call tedshow_ (sbp, ". sb cd adr");
	  call tedshow_ (dbp, ". db cd adr");
         end;
      end;

      if (sbp -> b.cur.sn = 0)
      then do;			/* The source is empty	       */
         msg = "b(";
         msg = msg || rtrim (sbp -> b.name);
         msg = msg || ")";
         call tederror_rc_ (dbase_p, msg,
	    (tederror_table_$zero_length_buffer));
      end;

/***** DESTINATION buffer  * * * * * * * * * * * * * * * * * * * * * * * * * */
      bp = dbp;
      b.a_.l.re (1), b.a_.r.le (2) = b.cd.r.re; /* set openup point	       */
      call openup;			/* move hole to where data is to go  */
      if (b.b_.r.re = 0)
      then b.a_.r.le (1) = 0;		/* note buffer was empty	       */
      else b.a_.r.le (1) = b.b_.r.le;	/* keep rle before data moved in     */
      if db_ted then call tedshow_ (bp, "a1");

/***** SOURCE buffer * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
      bp = sbp;
      call addr_status_ends (1, b.maxl);

      b.cd.l.re = max (b.cd.l.re, b_lhe);
      b.cd.r.le = min (b.cd.r.le, b_rhe);
      if (b_lhe = b.cd.l.re) & (b_rhe = b.cd.r.le) /* taking all there is?   */
      then b.not_pasted = "0"b;	/* no longer worry		       */

/**** When doing a move request within a buffer, the buffer will never be    */
/**** ..split at this point because openup has already been done at the      */
/**** ..destination. The destination may not be within the source.	       */
      if (b_stat = B_LO_HI)		/* range being read is split	       */
      then do;
         tr = b.cd.r.le - b.b_.r.le + 1;/* calc right length	   #1xx*/
         tl = b.b_.l.re - b.cd.l.re + 1;/* calc left  length	   #1xx*/
         if add_right
         then do;
	  tbp = addr (b.b_.r.le);	/* -> index of left of right part    */
	  l = tr;			/* #1xx*/
         end;
         else do;
	  tbp = addr (b.cd.l.re);	/* -> index of right of left part#1xx*/
	  l = tl;			/* #1xx*/
         end;
/*****		DESTINATION buffer * * * * * * * * * * * * * * * * * * * */
         bp = dbp;			/* switch to destination	       */
         call cpy_2 (ted_safe, sbp -> b.cur.sp, l, NLct_unknown, tbp -> lndx,
	    add_right);		/* #1xx*/
/*****		SOURCE buffer  * * * * * * * * * * * * * * * * * * * * * */
         bp = sbp;			/* switch to source again	       */
         if add_right
         then do;			/* #1xx*/
	  tbp = addr (b.cd.l.re);	/* -> index of right of left part#1xx*/
	  l = tl;			/* #1xx*/
         end;			/* #1xx*/
         else do;			/* #1xx*/
	  tbp = addr (b.b_.r.le);	/* -> index of left of right part#1xx*/
	  l = tr;			/* #1xx*/
         end;			/* #1xx*/
      end;
      else do;			/* #1xx*/
         tbp = addr (b.cd.l.re);	/* -> index of left of string	   #1xx*/
         l = b.cd.r.le - b.cd.l.re + 1; /* calc length to move	   #1xx*/
      end;			/* #1xx*/
/***** DESTINATION buffer  * * * * * * * * * * * * * * * * * * * * * * * * * */
      bp = dbp;
      call cpy_2 (ted_safe, sbp -> b.cur.sp, l, NLct_unknown, tbp -> lndx,
	 add_right);
      if db_ted
      then do;
         call tedshow_ (dbp, ". db b_ a1");
         call ioa_$ioa_switch (db_output, "<bbc");
      end;
      bp = old_bp;			/* restore old bp value	       */
      asbp = sbp;			/* restore the parameters	       */
      adbp = dbp;

   end buffer_buffer_copy; %page;
mov_2l:				/* move buffer data to the left      */
   proc (safe_mode, Aastr_p, astr_l, NLct);
dcl (
    safe_mode	bit (1) aligned,	/* 1- ensure strings don't overlay   */
				/* 0- don't worry about it	       */
    Aastr_p	ptr,		/* -> string to add (^cpy_2)	       */
				/* -> base of string to add (cpy_2)  */
    astr_l	fixed bin (21),	/*   length thereof		       */
    NLct		fixed bin (21)	/*  -1 - don't know		       */
				/*  -2 - find out now many	       */
				/* >=0 - number present	       */
    )		parm;

dcl add_right	bit (1);		/* 0- add to left end of hole	       */
				/* 1- add to right end of hole       */
dcl make_room	bit (1);		/* 0- just moving the hole	       */
				/* 1- adding to buffer, make sure    */
				/*    there is enough room	       */
dcl adj		fixed bin (21);
dcl id		char (3);

      id = "m2l";
      add_right = "0"b;
      make_room = "0"b;
      goto start;

mov_2r:				/* move buffer data to the right     */
   entry (safe_mode, Aastr_p, astr_l, NLct);
      id = "m2r";
      add_right = "1"b;
      make_room = "0"b;
      goto start;

add_2l:				/* add data to the left of hole      */
   entry (safe_mode, Aastr_p, astr_l, NLct);
      id = "a2l";
      add_right = "0"b;
      make_room = "1"b;
      goto start;

add_2r:				/* add data to the right of hole     */
   entry (safe_mode, Aastr_p, astr_l, NLct);
      id = "a2r";
      add_right = "1"b;
      make_room = "1"b;
      goto start;

cpy_2:				/* add data where specified	       */
   entry (safe_mode, Aastr_p, astr_l, NLct, lindex, which_side);
/****Aastr_p -> -> BASE of string				       */
dcl lindex	fixed bin (21);	/* index of left end of string       */
dcl which_side	bit (1);
/**** buffer_buffer_copy calls this entry.  One of the circumstances which   */
/****  can occur is 1) source-buffer=destination-buffer 2) promotion occurs. */
/**** Thus this entry points to the pointer and points to the left index so  */
/****  that if the source string gets moved, the reference to it will keep   */
/****  up with it.						       */
      add_right = which_side;
      if add_right
      then id = "c2r";
      else id = "c2l";
      make_room = "1"b;
      astr_p = addcharno (Aastr_p, lindex - 1);
      if ""b
      then do;
start:
         astr_p = Aastr_p;
      end;
      if (astr_l = 0)
      then return;
      adj = NLct;
      if (adj = -2)
      then do;
         j = index (astr, NL);
         if (j = 0)
         then do;			/* contains NO new-line	       */
	  if (b.b_.r.le > b.b_.r.re)	/* if upper part empty	       */
	  then adj = -1;		/* can't tell what change it makes   */
	  else adj = 0;		/* makes no change in linecount      */
         end;
         else if (j = astr_l)
         then adj = 1;		/* contains ONE new-line	       */
         else adj = -1;		/* >1 new-lines		       */
      end;
      if db_ted
      then do;
         call tedshow_ (bp, ">", id, "b_");
         call ioa_$ioa_switch (db_output, " ^a:    ^[SAFE ^]l=^i adj=^i",
	    id, safe_mode, astr_l, adj);
      end;
      if (adj = NLct_unknown)
      then do;
         if ^add_right
         then b.b_.l.ln = NLct_unknown;
         b.maxln, b.b_.r.ln = NLct_unknown;
      end;
      else do;
         if (b.maxln ^= -1)
         then b.maxln = b.maxln + adj;
         if (b.b_.l.ln ^= -1) & ^add_right
         then b.b_.l.ln = b.b_.l.ln + adj;
         if (b.b_.r.ln ^= -1)
         then b.b_.r.ln = b.b_.r.ln + adj;
      end;

      if make_room			/* adding new data to buffer	       */
      then do;
         b.mod_sw = "1"b;		/* buffer is modified	       */
         hole = b.b_.r.le - b.b_.l.re - 1; /* how much room left	       */
         hole = hole - astr_l;	/* how much left after adding	       */
         if (hole < 0)		/* is enough room left?	       */
         then call promote (-hole);	/* no, must try to get more	       */
         if (substr (id, 1, 2) = "c2")
         then do;
/**** This chases the source string which may have been moved by promotion.  */
	  astr_p = addcharno (Aastr_p, lindex - 1);
         end;
      end;
      b.newb = b.b_;
      if ^make_room
      then b.newb.l.ln = NLct_unknown;
      if db_ted & lg_ted
      then if (astr_l > 100)
	 then call ioa_$ioa_switch (db_output, "astr=""^50a^/<^i chars>^/^50a""^[-->@^i^;<--@^s^i^]",
		 substr (astr, 1, 50), astr_l - 100, substr (astr, astr_l - 49, 50),
		 add_right, b.b_.r.le - 1, b.b_.l.re + 1);
	 else call ioa_$ioa_switch (db_output, "astr=""^va""^[-->@^i^;<--@^s^i^]", astr_l, astr,
		 add_right, b.b_.r.le - 1, b.b_.l.re + 1);
      if (chars_moved >= 0)
      then chars_moved = chars_moved + astr_l;
      if add_right
      then do;			/* put the data on right via MRL     */
         b.new.re = b.b_.r.le - 1;
         b.new.le = b.b_.r.le - astr_l;
         b.newb.r.le = b.new.le;
         if ^make_room		/* moving data within the buffer?    */
         then do;
	  b.old.re, b.test.re = b.b_.l.re;
	  b.old.le, b.test.le = b.old.re - astr_l + 1;
	  b.test.re = b.test.re + 1;	/* allow l.re+1 to relocate	       */
	  if (b.test.le = 1)	/* if at beginning of buffer	       */
	  then b.test.le = b.test.le - 1; /* ..allow l.le-1 also	       */
	  b.newb.l.re = b.old.le - 1;
         end;
         call mrl_ (astr_p, astr_l, addr (b_c (b.new.le)), astr_l);
      end;
      else do;			/* put the data on left via MLR      */
         b.new.le = b.b_.l.re + 1;	/* figure where its going to	       */
         b.new.re = b.new.le + astr_l - 1;
         b.newb.l.re = b.new.re;
         if ^make_room		/* moving data within buffer?	       */
         then do;			/* figure where its coming from      */
	  b.old.le, b.test.le = b.b_.r.le;
	  b.old.re, b.test.re = b.old.le + astr_l - 1;
	  b.test.le = b.test.le - 1;	/* allow r.le-1 to relocate	       */
	  if (b.test.re = b.maxl)	/* if at end of buffer	       */
	  then b.test.re = b.test.re + 1; /* ..allow r.re+1 also	       */
	  b.newb.r.le = b.old.re + 1;
         end;
         substr (b_s, b.new.le, astr_l) = astr;
         if db_ted then call ioa_$ioa_switch (db_output,
/****	         1                 2  3   4            5		       */
	         "a2*: (^p->b_s,b.new.le(^i),^i)=^p->astr,len=^i",
	         b.cur.sp, b.new.le, astr_l, astr_p, b.new.le + astr_l - 1);
      end;
      if make_room
      then call update;
      else call relocate;
      if db_ted
      then call tedshow_ (bp, "< b_"); %skip;
dcl astr		char (astr_l) based (astr_p);
dcl astr_p	ptr;
dcl hole		fixed bin (21);	/* size of hole		       */

   end mov_2l; %page;
delete:				/* delete a string from a buffer     */
   proc;

/**** The string to remove is defined by:   b.a_.l.re (1) : b.a_.r.le (2)  */
/**** Upon exit, l.re (1), r.le (2) = r.le (2) + 1;		       */

      if db_ted
      then call tedshow_ (bp, "> del max adr");
      call addr_status_ends (1, b.maxl);
      if (b_lhe = b.a_.l.re (1)) & (b_rhe = b.a_.r.le (2))
      then do;			/* deleting whole thing	       */
dcl which		char (1);
         if ""b
         then do;
delete$all: entry;
	  which = ".";
         end;
         else which = "<";
         if db_ted
         then call tedshow_ (bp, which, "[all b(" || rtrim (b.name) || ")");
         call demote (0);		/* get rid of buffer space	       */
         b.a_ (1) = tedcommon_$no_data;
         b.a_ (2) = tedcommon_$no_data;
         b.ex = tedcommon_$no_data;
         b.mod_sw = "1"b;
         return;
      end;

      if b.pseudo			/* if ^read file..		       */
      then do;
         call promote (b.maxl);	/* ..then get it read	       */
         call addr_status (b.b_.l.le, b.b_.r.re);
      end;

/**** select action based on where left and right ends of range are	       */

      if (b_stat = B_LO_LO)
      then do; %skip (2);
/****	Before:  xxxxxxAAAAyyyyyy............zzzzzzzzzz	al=low	       */
/****	openup:  xxxxxxAAAA............yyyyyyzzzzzzzzzz	ar=low	       */
/****	 After:  xxxxxx................yyyyyyzzzzzzzzzz		       */
/****	   ".":			 |			       */
/**** When AAAA is addressed, usually characters AAAAyyyyyy will be moved    */
/****  before the work begins. However, when deleting, only characters       */
/****  yyyyyy need to be moved before doing the adjust. The rest are going   */
/****  to be thrown away. We don't even care if zzzzzzzzzz is null.	       */

         b.a_.r.re (1) = b.a_.l.re (1); /* save beginning of range where it  */
				/*  will be relocated	       */
         b.a_.l.re (1) = min (b.a_.r.le (2) + 1, b.b_.r.re + 1);
				/* set left of moved data      */
         call openup;
         b.newb = b.b_;
         b.newb.l.re = b.a_.r.re (1) - 1; /* set new buffer left end from   */
				/*  saved data		       */
      end; %skip (3);
      else if (b_stat = B_LO_HI)
      then do;
/**** Before: zzzzzzzAAA............AAAAAyyyyyyyyyyy	al=low	       */
/****  After: zzzzzzz....................yyyyyyyyyyy	ar=high	       */
/****    ".":			 |			       */
/**** When the address spans the hole, adjusting does all		       */

         b.newb = b.b_;
         b.newb.l.re = b.a_.l.re (1) - 1; /* set buffer left end	       */
         b.newb.r.le = b.a_.r.le (2) + 1; /* set buffer right end	       */
      end;
      else do;
/**** Before: zzzzzzzzzz............xxxxxxAAAAyyyyyy	al=high	       */
/**** openup: zzzzzzzzzzxxxxxx............AAAAyyyyyy	ar=high	       */
/****  After: zzzzzzzzzzxxxxxx................yyyyyy		       */
/****    ".":			      |			       */
/**** When AAAA is addressed, characters xxxxxx are moved. Then the data is  */
/****  removed by adjusting.					       */

         call openup;
         b.newb = b.b_;
         if (b.b_.r.le <= b.b_.r.re)	/* if right part not empty	       */
         then			/* ..set buffer right end	       */
	    b.newb.r.le = min (b.b_.r.re + 1, b.a_.r.le (2) + 1);
      end; %skip (3);
/**** must get smarter about line number handling			       */
      b.newb.l.ln, b.newb.r.ln, b.maxln = NLct_unknown;
      b.mod_sw = "1"b;
				/* set "." to first char after       */
      call update;
      b.a_.r.le (2) = b.b_.r.le;	/* fall off end?		       */
      if db_ted
      then call tedshow_ (bp, "< adr");
				/* ?should check for refs to data?   */
      return;

   end delete; %page;
/**** open up the hole at designated location in current window of	       */
/****  designated buffer					       */
/****  ASSUMPTION: the hole is always within this window		       */
openup: proc;

      if db_ted
      then call tedshow_ (bp, "> opn b_");
      if b.invoking
      then do;			/* #156*/
         msg = "Bnm) Attempting to modify a buffer while it is being invoked.";
         goto print_error;		/* #156*/
      end;			/* #156*/
      if b.pseudo			/* if ^read file then get it read    */
      then call promote (b.maxl);	/*   first		       */
      at = b.a_.l.re (1);

/*common:*/
      if db_ted
      then call ioa_$ioa_switch (db_output, "    : b(^a)@^i", b.name, at);
      action = "no seg";
      if (b.cur.sn = 0)		/* if no segment, then there is...   */
      then goto finis;		/*   ...only hole: you're in it.     */

      action = "already";
      if (at = b.b_.r.le) | (at = b.b_.l.re + 1)
      then goto finis;		/* already there		       */

/**** If running in SAFE mode, the move must be done ensuring that the       */
/****  source and destination strings never overlap. If they did and a crash */
/****  occurred in the middle, there would be no way to restart the	       */
/****  operation. If not safe, then we don't care because we will never have */
/****  to try to restart. add takes this into account.		       */

      if (at > b.b_.l.re)		/* not in left part?	       */
      then do;
         if (at < b.b_.r.le)		/* in the hole?		       */
         then do;
	  if (at = b.maxl)		/* right part empty?	       */
	  then goto finis;
	  signal condition (at_in_gap); dcl at_in_gap condition;
         end;
				/* move left end of right part down  */
         len = min (at, b.maxl + 1) - b.b_.r.le;
         call mov_2l (ted_safe, addr (b_c (b.b_.r.le)), len, 0);
      end;
      else do;			/* move right end of left part down  */
         len = b.b_.l.re - at + 1;
         call mov_2r (ted_safe, addr (b_c (at)), len, 0);
      end;
      action = "";
finis:
      if db_ted
      then call tedshow_ (bp, "< [" || action);
      return; %skip;
dcl action	char (8);
dcl len		fixed bin (21);
dcl at		fixed bin (21);

   end openup; %page;
promote: proc (alen);
      seg_sw = "pro";
      if db_ted
      then call tedshow_ (bp, "> pro max [" || ltrim (char (alen)));
      dbase_p = ptr (bp, 0);		/* manufacture database ptr	       */

      len = alen + buf_max (b.cur.ast); /* how much total space needed    */
      if (len > buf_max (1))
      then do;
         msg = "Xde) Data exceeds ";
         msg = msg || ltrim (char (buf_max (1)));
         msg = msg || " characters; request aborted.";
         goto print_error;
      end;
      goto common;

dcl seg_sw	char (3);
promote$seg: entry;
      seg_sw = "p$s";
      len = (b.b_.l.re - b.b_.l.le + 1) + (b.b_.r.re - b.b_.r.le + 1);
      if db_ted
      then call tedshow_ (bp, "> p$s max [" || ltrim (char (len)));
dcl (
    alen		fixed bin (21)	/* amount of data which does not...  */
    )		parm;		/*   ...fit in the current buffer    */

/* this routine is called under these circumstances:		       */
/*  1) openup/delete in a ^read file; the file is "materialized".	       */
/*  2) add doesn't have a hole big enough for the data		       */
/*  3) buffer needs its own segment ([ted_buffer] or qhold use)	       */

/* These are the various states of b.* (known as of 80-11-15)	       */
/*   name       sp       sn,pn,ast lle:lre       rle:rre		       */
/* b((ted))  234|32174   -1, 0, 0    1:67         69:68	-req data	       */
/* b((val))  77777|1      0, 1, 0    1:0           1:0	EMPTY	       */
/* b(args)   537|4000     1, 3, 0    1:13       4097:4096	PSEUDO (real)    */
/* b(arg1)   537|4000     1, 0, 0    1:5           7:6	PSEUDO (refer)   */
/* b(arg2)   537|4001(18) 1, 0, 0    1:6           8:7	PSEUDO (refer)   */
/* b(0)      622|0       -1, 0, 0    1:265894 265896:265894	^read file       */
/* b(1)      537|6000     1, 4, 5    1:0        1478:4097	read file	       */
/* b(2)      541|0        4, 1, 5    1:2620     4097:4096	[ted_buffered]   */

common:
/**** Find buffer size which will hold the required amount.	       */
      b.pend = tedcommon_$no_seg;
      do b.pend.ast = 1 to hbound (buf_max, 1) - 1
	 while (buf_max (b.pend.ast + 1) >= len);
      end;

      if (b.cur.ast <= b.pend.ast) & (b.cur.ast ^= 0) & (seg_sw = "pro")
      then do;			/* are they trying to demote?	       */
         msg = buf_size (b.cur.ast);
         msg = msg || "K->";
         msg = msg || buf_size (b.pend.ast);
         msg = msg || "K logic error";
         goto print_error;
      end;

      b.newb = b.b_;
      b.old.le, b.test.le = b.b_.r.le;
      b.old.re, b.test.re = b.b_.r.re;
      b.test.re = b.test.re + 1;	/* moving the data upward, so allow  */
				/*  1 more on high end since many    */
				/*  requests go until "this">"last". */
				/*  "this" can be outside of the     */
				/*  range and would not then get     */
				/*  relocated.		       */
/**** For right now r.le-1 is left stranded in gap. Can it happen?	       */
      len = b.old.re - b.old.le + 1;	/* calc how much is being moved      */
      b.new.re, b.newb.r.re = buf_max (b.pend.ast);
      b.new.le, b.newb.r.le = b.new.re - len + 1;
      if (b.cur.sn > 2) & ^b.pseudo	/* already have its own segment?     */
      then do;
         b.pend.sp = b.cur.sp;
         b.pend.sn = b.cur.sn;
         if (seg_sw = "pro")
         then goto do_move;		/* we will just expand in place      */
         b.new.le = b.b_.l.re + 1;
         b.new.re = b.new.le + len - 1;
         b.newb.r.le = buf_max (b.pend.ast) + 1;
         b.newb.l.le = 1;
         b.newb.l.re = b.new.re;
         substr (b_s, b.new.le, len) = substr (b_s, b.old.le, len);
         if db_ted then call ioa_$ioa_switch (db_output,
/****        1   2                3   4    5                6   7       8    */
	         "^a:(^p->b_s,b.new.le(^i),^i)=(^p->b_s,b.old.le(^i),^i),len=^i",
	         seg_sw, b.cur.sp, b.new.le, len, b.cur.sp, b.old.le, len,
	         b.new.le + len - 1);
				/* compressing the segment	       */
         goto no_move;
      end;
      if (seg_sw = "pro")
      then do;
         if (b.pend.ast = 5)		/* smallest size		       */
         then do;
	  i = index (dbase.inuse_1K, "0"b); /* any room in 1K pool?	       */
	  if (i = 0)
	  then do;		/* no, have to try next larger       */
	     b.pend.ast = 4;
	     b.new.re, b.newb.r.re = buf_max (b.pend.ast);
	     b.new.le, b.newb.r.le = b.new.re - len + 1;
	  end;
	  else do;		/* yes, we'll take one	       */
	     if (dbase.seg_p (1) = null ()) /* is there a 1/4K pool?       */
	     then call tedget_segment_ (dbase_p, dbase.seg_p (1), 1);
	     b.pend.sp = addr (seg_1K (i));
	     b.pend.sn = 1;
	     b.pend.pn = i;
	     substr (dbase.inuse_1K, i, 1) = "1"b; /* flag it used       */
	     if db_ted
	     then call ioa_$ioa_switch (db_output, "    : inuse_1K=^b", dbase.inuse_1K);
	     if ^b.pseudo
	     then goto no_move;
	  end;
         end;

         if (b.pend.ast = 4)		/* next smallest size	       */
         then do;
	  i = index (dbase.inuse_4K, "0"b); /* any room in 4K pool?	       */
	  if (i = 0)
	  then do;		/* no, have to try next larger       */
	     b.pend.ast = 3;
	     b.new.re, b.newb.r.re = buf_max (b.pend.ast);
	     b.new.le, b.newb.r.le = b.new.re - len + 1;
	  end;
	  else do;		/* yes, we'll take one	       */
	     if (dbase.seg_p (1) = null ()) /* is there a 1/4K pool?       */
	     then call tedget_segment_ (dbase_p, dbase.seg_p (1), 1);
	     b.pend.sp = addr (seg_4K (i));
	     b.pend.sn = 1;
	     b.pend.pn = i + 16;
	     substr (dbase.inuse_4K, i, 1) = "1"b;
	     if db_ted
	     then call ioa_$ioa_switch (db_output, "    : inuse_4K=^b", dbase.inuse_4K);
	     if (b.cur.ast = 0) & ^b.pseudo
	     then goto no_move;
	  end;
         end;

         if (b.pend.ast = 3)
         then do;
	  i = index (dbase.inuse_16K, "0"b); /* any room in 16K pool?    */
	  if (i = 0)
	  then do;		/* no, have to get full segment      */
	     b.pend.ast = 2;
	     b.new.re, b.newb.r.re = buf_max (b.pend.ast);
	     b.new.le, b.newb.r.le = b.new.re - len + 1;
	  end;
	  else do;		/* yes, we'll take one	       */
	     if (dbase.seg_p (2) = null ()) /* is there a 16K pool?	       */
	     then call tedget_segment_ (dbase_p, dbase.seg_p (2), 2);
	     b.pend.sp = addr (seg_16K (i));
	     b.pend.sn = 2;
	     b.pend.pn = i;
	     substr (dbase.inuse_16K, i, 1) = "1"b; /* flag it used       */
	     if db_ted
	     then call ioa_$ioa_switch (db_output, "    : inuse_16K=^b", dbase.inuse_16K);
	     if (b.cur.ast = 0) & ^b.pseudo
	     then goto no_move;
	  end;
         end;
      end;

      if (b.pend.sp = null ())	/* no current buffer space	       */
      then do;
         b.pend.pn = 1;
         call tedget_segment_ (dbase_p, b.pend.sp, b.pend.sn);
      end;

      if (b.cur.ast > 2) & ((b.cur.sn = 1) | (b.cur.sn = 2))
				/* got a 1K, 4K, or 16K already      */
	 | b.pseudo		/* ..or a fake one?		       */
      then do;			/* copy left-hand data into new one  */
         if (b.b_.l.re > 0)
         then substr (b.pend.sp -> b_s, 1, b.b_.l.re)
	         = substr (b_s, 1, b.b_.l.re);
      end;
      if (seg_sw = "p$s")
      then do;
         b.new.le = b.b_.l.re + 1;
         b.new.re = b.new.le + len - 1;
         b.newb.l.re = b.newb.l.re + len;
         b.newb.r.le = b.b_.r.re + 1;
      end;
do_move:
      if (len > 0)			/* if anything to move...	       */
      then do;			/*   do it		       */
/**** During this move, the strings can never overlay, but MRL is being used */
/****  to get the maximum bounds fault out of the way immediately.	       */
         call mrl_ (addr (b_c (b.old.le)), len,
	    addr (b.pend.sp -> b_c (b.new.le)), len);
      end;
no_move:
      call relocate;		/* 1) relocate refs to moved data    */
				/* 1a)(terminate ^read segment)      */
				/* 2) update b.maxl, b.cur	       */
				/* 3) update b.b_		       */
      if (seg_sw = "p$s")
      then call hcs_$truncate_seg
	      (b.cur.sp, divide (b.b_.l.re + 3, 4, 21, 0), 0);
      b.pseudo = ""b;		/* buffer is now for real	       */
      if db_ted
      then call tedshow_ (bp, "max cur < b_");
      return; %skip (2);
free_buffer: entry;
      if (b.cur.sn = 1) & (b.cur.ast = 5) /* free up old 1K buffer	       */
      then do;
         substr (dbase.inuse_1K, b.cur.pn, 1) = "0"b;
         seg_1K (b.cur.pn) = low (buf_max (5));
         if db_ted
         then call ioa_$ioa_switch (db_output, "inuse_1K=^b ^i=0", dbase.inuse_1K, b.cur.pn);
      end;
      else if (b.cur.sn = 1) & (b.cur.ast = 4) /* free up old 4K buffer    */
      then do;
         substr (dbase.inuse_4K, b.cur.pn, 1) = "0"b;
         seg_4K (b.cur.pn) = low (buf_max (4));
         if db_ted
         then call ioa_$ioa_switch (db_output, "inuse_4K=^b ^i=0", dbase.inuse_4K, b.cur.pn);
      end;
      else if (b.cur.sn = 2) & (b.cur.ast = 3) /* free up old 16K buffer   */
      then do;
         substr (dbase.inuse_16K, b.cur.pn, 1) = "0"b;
         seg_16K (b.cur.pn) = low (buf_max (3));
         if db_ted
         then call ioa_$ioa_switch (db_output, "inuse_16K=^b ^i=0", dbase.inuse_16K, b.cur.pn);
      end;
      else if (b.cur.sn > 2)
      then call tedfree_segment_ (dbase_p, b.cur.sn);
      return;

dcl i		fixed bin (21);
dcl len		fixed bin (21);


dcl buf_size	(0:5) char (6) var int static options (constant)
		init ("0", "255", "64", "16", "4", "1");
dcl 1 seg__	based (dbase.seg_p (1)),
      2 seg_1K	(16),
        3 xxx	char (4096),	/* 1K words		       */
      2 seg_4K	(12),
        3 xxx	char (16384);	/* 4K words		       */
dcl 1 seg_16K	(4) based (dbase.seg_p (2)),
      2 xxx	char (66536);	/* 16K words		       */

   end promote;
dcl buf_max	(0:5) fixed bin (21) int static options (constant)
		init (0, 1044480, 0262144, 0065536, 0016384, 0004096);
/****		      0        1        2        3        4        5     */ %page;
make_consistent: proc;

dcl (
/****are		fixed bin (21),	/*  right string offset	       */
    ale		fixed bin (21)	/*  left string offset	       */
    )		parm;


      if db_ted
      then call ioa_$ioa_switch (db_output, "make_consistent b(^a) ^i", b.name, b.state_b);
      goto rtn (b.state_b);		/* go finish what was interrupted    */

clean__up:
rtn (-2): b.state_b = -2;		/* clean up the temporaries	       */
      b.newb = tedcommon_$no_data;
      b.state_b = 0;
      return;


rtn (-1):				/* in the middle of tedget_buffer_   */
      b.b_ = b.newb;
      b.a_ = b.temp;
      goto clean__up;

rtn (0):
      return;			/* nothing interrupted	       */

/* Notes on how to sequence the lines
rtn (x):     b.state_b = x;
   setq jaf 0
   setq jaf (+ jaf 1)
   insert-string (decimal-rep jaf)
*/ %page;
relocate: entry;
      if (b.old.re ^= 0)		/* if there is an "old" location...  */
      then do;			/*   ...then must relocate	       */

/****	b.old.(l r)e	is where the old data was		       */
/****	b.new.(l r)e	is where it now is			       */
/**** All references within the old range are updated to to the new range    */
/**** If b.terminate then clean up a ^read segment.		       */

         b.N1 = reloc_first;		/* init the reloc loop index	       */
         b.N3 = b.new.le - b.old.le;	/* calc the adjustment needed	       */
next:
rtn (1): b.state_b = 1;
         b.N2 = b.N1 + 1;		/* increment this index (safely)     */
         if (b.N2 <= reloc_last)	/* still more to process?	       */
         then do;
rtn (2):	  b.state_b = 2;
	  b.N1 = b.N2;		/* update the loop index	       */
rtn (3):	  b.state_b = 3;
	  if adjust (buf_des (b.N1), bd_name (b.N1))
	  then goto next;
rtn (4):	  b.state_b = 4;
	  buf_des (b.N1) = b.rel_temp;
	  goto next;
         end;
rtn (5): b.state_b = 5;
         if (b.stackl ^= ""b)
         then do;
	  b.stack_o = b.stackl;
rel_svex:
rtn (6):	  b.state_b = 6;
	  if adjust (ptr (dbase.seg_p (3), b.stack_o) -> sv.ex, "so.ex")
	  then goto no_svex;
rtn (7):	  b.state_b = 7;
	  ptr (dbase.seg_p (3), b.stack_o) -> sv.ex = b.rel_temp;
no_svex:
rtn (8):	  b.state_b = 8;
	  if adjust (ptr (dbase.seg_p (3), b.stack_o) -> sv.a0, "so.a0")
	  then goto no_sva0;
rtn (9):	  b.state_b = 9;
	  ptr (dbase.seg_p (3), b.stack_o) -> sv.a0 = b.rel_temp;
no_sva0:
rtn (10):	  b.state_b = 10;
	  b.stack_o = ptr (dbase.seg_p (3), b.stack_o) -> sv.stackl;
rtn (11):	  b.state_b = 11;
	  if (b.stack_o ^= ""b)
	  then goto rel_svex;
         end;
rtn (12): b.state_b = 12;
         b.rel_temp = tedcommon_$no_data;
         if b.pseudo		/* if read-only data or ^read file   */
         then do;
	  if b.terminate
	  then do;
rtn (13):	     b.state_b = 13;
	     dbase_p = ptr (bp, 0);	/* manufacture -> database	       */
	     call hcs_$terminate_noname (b.cur.sp, 0); /* ignore code */
	     dbase.not_read_ct = max (0, dbase.not_read_ct - 1);
	     b.terminate = "0"b;
	     b.initiate = "0"b;
	  end;
         end;
      end;
update: entry;
      if (b.cur.ast ^= b.pend.ast)	/* are we changing segments with...  */
	 & (b.cur.sn ^= b.pend.sn)
      then do;			/*   ...this action?	       */
/**** free up old 4/16K buffer if there was one			       */
/**** set new value for b.maxl				       */
/**** b.pend --> b.cur					       */
rtn (14): b.state_b = 14;
         if ^b.pseudo
         then call free_buffer;
      end;
      b.pseudo = ""b;
rtn (15): b.state_b = 15;
      b.maxl = buf_max (b.pend.ast);
      b.cur = b.pend;
      b.b_ = b.newb;
      goto clean__up; %skip (2);
new_cur: entry;			/* used by tedpseudo_	       */
rtn (16): b.state_b = 16;
      b.maxl = b.newb.l.re;
      b.cur = b.pend;
      b.b_ = b.newb;
      b.ex = b.newb;
      goto clean__up;
adjust: proc (what, which) returns (bit (1));
dcl 1 what	like buf_des,
    which		char (*);

      b.rel_temp = what;		/* begin a new buf_des	       */
      if (unspec (b.rel_temp) = unspec (tedcommon_$no_data))
      then return ("1"b);

      if (b.test.le <= b.rel_temp.l.le)
	 & (b.rel_temp.l.le <= b.test.re)
      then b.rel_temp.l.le = b.rel_temp.l.le + b.N3;

      if (b.test.le <= b.rel_temp.l.re)
	 & (b.rel_temp.l.re <= b.test.re)
      then b.rel_temp.l.re = b.rel_temp.l.re + b.N3;

      if (b.test.le <= b.rel_temp.r.le)
	 & (b.rel_temp.r.le <= b.test.re)
      then b.rel_temp.r.le = b.rel_temp.r.le + b.N3;

      if (b.test.le <= b.rel_temp.r.re)
	 & (b.rel_temp.r.re <= b.test.re)
      then b.rel_temp.r.re = b.rel_temp.r.re + b.N3;

      if (unspec (buf_des (b.N1)) = unspec (b.rel_temp))
      then return ("1"b);

      if db_ted
      then call tedshow_ (bp, which, "rt");
      return ("0"b);

   end adjust;
dcl bd_name	(13) char (2) int static init (
		"b_", "nb", "ex", "a0", "a1", "a2", "cd", "gb", "na",
		"rt", "t0", "t1", "t2");
demote: entry (ale);

      if (b.cur.sn = 0)		/* if buffer already empty..	       */
      then return;			/* ..don't need to do anything.      */
      if b.pseudo			/* if read-only data or ^read file   */
      then do;
         if b.terminate
         then do;
rtn (17):	  b.state_b = 17;
	  call hcs_$terminate_noname (b.cur.sp, 0); /* ignore code */
	  dbase.not_read_ct = max (0, dbase.not_read_ct - 1);
	  b.terminate = "0"b;
	  b.initiate = "0"b;
         end;
      end;
      else do;
rtn (18): b.state_b = 18;
         call free_buffer;
      end;
rtn (19): b.state_b = 19;
      b.pseudo = ""b;
      b.uid = ""b;
      b.maxl, b.maxln = 0;
      b.cur = tedcommon_$no_seg;
      b.b_ = tedcommon_$no_data;
      b.a_ (0) = tedcommon_$no_data;
      goto clean__up;


new_dot: entry;

rtn (20): b.state_b = 20;
      b.a_ (0) = b.newa;
      b.newa = tedcommon_$no_data;
      goto clean__up;

   end make_consistent; %page;
/**** This routine isolates the line boundaries of the last byte used and    */
/****  makes these be the current location.			       */

iso_line: proc;			/* isolate the line defined by       */
				/*    b.a_.r.le (2)		       */

dcl (sb, se)	fixed bin (21);

      se = b.a_.r.le (2);		/* Take the end of range value.      */
      if (se = b.b_.l.re + 1)		/* value just after lower part       */
	 | (se = b.b_.l.le - 1)	/* ..or lower part empty	       */
      then se = b.b_.r.le;		/* ..move to upper.		       */
      if (se = b.b_.r.le - 1)		/* value just before upper part      */
/****    | (se = b.b_.r.re + 1)	/* ..or upper part empty	       */
      then se = b.b_.l.re;		/* ..move to lower.		       */
      b.a_.r.le (2) = se;		/* Take the end of range value.      */
      if db_ted
      then do;
         call tedshow_ (bp, "> iso a2 b_");
         call ioa_$ioa_switch (db_output, " iso: se=^i ", se);
      end;
      if (b.b_.l.re >= b.b_.l.le)	/* is there a lower part?	       */
      then do;
         if (b_c (b.b_.l.re) ^= NL)	/* does lower part not end in NL...  */
	    & (b.b_.r.re >= b.b_.r.le)/* ..and is there an upper part?     */
         then do;
/**** The hole gets moved to a line boundary. Data is moved upward.	       */
/****  N.B.: A file which does not end with NL could be all in lower part.   */
/****        such as after doing "$($)d"			       */
	  i = index (reverse (
	       substr (b_s, b.b_.l.le, b.b_.l.re - b.b_.l.le + 1)), NL);
	  if (i = 0)
	  then b.a_.l.re (1) = b.b_.l.le;
	  else b.a_.l.re (1) = b.b_.l.re - i + 2; /* adjust to just after  */
				/* ..the NL		       */
	  call openup;
	  se = b.a_.r.le (2);	/* reclaim working location	       */
         end;
      end;
      b.newa.l.re, b.newa.r.le = se;
      b.newa.l.ln, b.newa.r.ln = b.a_.r.ln (2);
      if (se < b.b_.l.le) | (b.b_.r.re < se)
	 | (b.b_.l.re < se) & (se < b.b_.r.le)
      then do;			/* If not within buffer limits..     */
         b.newa.l.re = b.b_.l.le;	/* ..set it undefined	       */
         b.newa.r.le = addr_undef;
      end;

      sb = b.newa.l.re;		/* set tentative limits	       */
      se = b.newa.r.le;
      if (se ^= addr_undef)
      then do;
         if (b_c (se) ^= NL)		/* If string-end not on a NL..       */
         then do;			/* ..get it there (if possible).     */
	  i = b.b_.l.re;
	  if (se > i)
	  then i = b.b_.r.re;
	  j = index (substr (b_s, se, i - se + 1), NL);
	  if (j = 0)		/* no NL found		       */
	  then if (b.b_.r.re >= b.b_.r.le) /* set to EOB		       */
	       then se = b.b_.r.re;	/* (upper part exists)	       */
	       else se = b.b_.l.re;	/* (no upper part)		       */
	  else se = se - 1 + j;	/* otherwise set to that NL	       */
         end;
         i = b.b_.l.le;		/* start at lower part	       */
         if (sb > b.b_.l.re)		/* If point is in upper part..       */
         then i = b.b_.r.le;		/* ..shift up there.	       */
         if (sb > i)
         then if (b_c (sb - 1) ^= NL)	/* If not at BOL, get there	       */
	    then do;
	       j = index (reverse (substr (b_s, i, sb - i)), NL);
	       if (j = 0)
	       then sb = i;
	       else sb = sb - j + 1;
	    end;
      end;
      b.newa.l.le = sb;
      b.newa.r.re = se;
      call new_dot;
      if db_ted
      then call tedshow_ (bp, "< a0");

      return;

   end iso_line; %page;
default$line_eval: proc;
      who = "le-"; bias = 1; extend = "0"b; cur_line = "1"b; goto work;

default$cur_line_extend: entry;
      who = "cle"; bias = 0; extend = "1"b; cur_line = "1"b; goto work;

default$cur_line: entry;
      who = "cl-"; bias = 0; extend = "0"b; cur_line = "1"b; goto work;

default$whole_buffer: entry;
      who = "wb-"; bias = 0; extend = "0"b; cur_line = ""b;

work:
      if ^b.present (1)		/* if no addresses provided	       */
      then do;
         if cur_line
         then b.a_ (1), b.a_ (2) = b.a_ (0);
         else do;
	  b.a_.l.ln (1) = 1;
	  b.a_.r.ln (2) = b.b_.r.ln;
	  if (b.b_.l.le > b.b_.l.re)	/* lower part empty		       */
	  then b.a_.l.le (1), b.a_.l.re (1) = b.b_.r.le;
	  else b.a_.l.le (1), b.a_.l.re (1) = b.b_.l.le;
	  if (b.b_.r.re < b.b_.r.le)
	  then b.a_.r.le (2), b.a_.r.re (2) = b.b_.l.re;
	  else b.a_.r.le (2), b.a_.r.re (2) = b.b_.r.re;
         end;
      end;
      else if ^b.present (2)		/* if only one addr,	       */
      then do;			/*  make second addr same as first   */
         b.a_ (2) = b.a_ (1);
      end;
      if db_addr
      then call tedshow_ (bp, ".", who, "adr");
      if (b.cur.sn = 0)
      then do;
         msg = "Abe) Buffer empty.";
         goto print_error;
      end;
      if (b.a_.r.re (2) = addr_undef)
      then do;
         msg = "A.u) ""."" undefined.";
         goto print_error;
      end;
      if (b.a_.l.le (1) = 0)
      then do;
         msg = "Abb) Addr- before buffer.";
         goto print_error;
      end;
      if (b.a_.l.le (1) > b.b_.r.re) | ^extend & (b.a_.r.le (2) > b.b_.r.re)
      then do;
         msg = "Aab) Addr- after buffer.";
         goto print_error;
      end;
      if (b.a_.l.re (1) > b.a_.r.le (2) + bias)
      then do;
         msg = "Awa) Addr- wrap-around.";
         goto print_error;
      end;
      return;

dcl cur_line	bit (1);
dcl bias		fixed bin;
dcl extend	bit (1);
dcl who		char (3);

   end default$line_eval; %page;
%include tedgvd;
dcl gv_work	char (2048);	/* memory for compilation result     */
%skip (3);
gv_msg_com:
      if (vgch ^= "")
      then do;
         req_str = req_str || "(sub-request ";
         req_str = req_str || vgds;
         req_str = req_str || ")";
      end;
      if (rl_c (rl_i) = NL)
      then rl_i = rl_i - 1;
      if (rl_i < rl_b)
      then rl_b = rl_i + 1;
      goto add_request; %skip (2);
end_cf: proc;

      if (cf.op ^= -255)
      then do;
         gvx.tot_len = gvx.tot_len + cf.siz;
         if db_gv | db_srch
         then do;
	  call tedshow_ (comptr, "cf");
         end;
      end;
start_cf: entry;
      gvx.ic = gvx.tot_len + 1;
      cfp = addr (gvx.word (gvx.ic));
      cf.op = -255;
      cf.len = 0;
      cf.siz = 5;

   end end_cf;
init_cfp: proc (area_p, space);

dcl area_p	ptr,		/* base of area being setup	       */
    space		char (*);		/* place for data to go	       */

      if (area_p = null ())
      then do;
         area_p, comptr = addr (space);
         gvx.max_len = size (space) - 5;
         gvx.tot_len, gvx.srch_len = 0;
      end;
      comptr = area_p;
      gvx.ic = 1;
      cfp = addr (gvx.word (1));
      if db_gv | db_srch
      then call ioa_$ioa_switch (db_output, "cfp=^p", cfp);

   end init_cfp; %page;
/****				        00000000011111111112222      */
/****				        12345678901234567890123      */
dcl op_mnem	char (22) int static init ("(pPKMkmsd=tTlLuU{aci >");

gv_compile: proc;			/* compile a g* request	       */
      call init_cfp (gvx_p, gv_work);
tedgv_: begin;
dcl it		fixed bin (21);
dcl (n1_sw, n2_sw)	bit (1);
dcl i		fixed bin (21);
dcl ch		char (1);
dcl n1		fixed bin (21);
dcl n2		fixed bin (21);
dcl adr_sw	bit (1);

         code = 0;
         rl_b = rl_i - 2;
         req_ch = rl_c (rl_b);
         vgch, vgds = "";
         NLlast = gvx.printing;
         if (substr (rl_s, rl_i, 2) = "==")
         then do;			/* wants to re-use it all	       */
	  rl_i = rl_l;
	  goto get_ready;
         end;
         else if (substr (rl_s, rl_i, 2) = "//")
         then do;			/* wants to re-use search	       */
	  if (substr (rl_s, rl_i + 2, 1) ^= " ")
	  then do;		/* But, he must give something to do */
	     msg = "Xse) Bad syntax for ";
	     goto gv_msg_com;
	  end;
	  if (gvx.tot_len = 0)	/* There must also be something      */
	  then do;		/*  remembered.		       */
	     rl_i = rl_l;		/* (will give the error at	       */
	     return;		/*  execution time)		       */
	  end;
	  gvx.tot_len = gvx.srch_len;
	  call start_cf;
				/* going to re-use search part       */
	  rl_i = rl_i + 3;
         end;
         else do;			/* completely new request	       */
	  gvx.tot_len,
	       gvx.srch_len = 0;	/* wipe out the remembered stuff     */
	  cf.op = -255;
	  cf.len = 0;
	  cf.siz = 5;
	  call ted_gv_p_;
	  gvx.srch_len = gvx.tot_len;
         end;
         if (rl_i >= rl_l)
         then do;
	  msg = "Gne) No execution part for";
	  rl_i = rl_l - 1;
	  goto gv_msg_com;
         end; %page;
/*	         . . . INSTRUCTION COMPILATION LOOP . . .		       */
/*			   for g* / v*			       */

         gvx.printing = ""b;
         gvx.mk_list = 0;
         do while (rl_i < rl_l);
	  vgch, vgds = rl_c (rl_i);
	  if ^caps
	  then if (vgch >= "A") & (vgch <= "Z")
	       then goto inv_req;
	  if (vgch = "!")
	  then do;
	     vgds = vgds || rl_c (rl_i + 1);
	     it = index ("pkmtlu", rl_c (rl_i + 1));
	     if (it = 0)
	     then goto inv_req;
	     rl_i = rl_i + 1;
				/* make char UPPER CASE	       */
	     unspec (vgch) = unspec (rl_c (rl_i)) & "111011111"b;
	  end;
	  it = index (op_mnem, vgch);
	  if (it = 0)
	  then do;
	     if vgch = """"		/* allow a comment on the end	       */
	     then do;
	        rl_i = rl_l;
	        goto compiled;
	     end;
inv_req:
	     msg = "Grq) Unknown sub-request for";
	     vgch = "";
	     goto gv_msg_com;
	  end;
	  rl_i = rl_i + 1;
re_com:
/**** Need to continually check for gvx overflow!!		       */

	  if (gvx.max_len < gvx.tot_len)
	  then do;
	  end;
	  call end_cf;
	  cf.op = it;
	  goto com (it); %page;
com (06):				/* k - kopy		       */
com (07):				/* m - move		       */
	  cfmk.link = gvx.mk_list;	/* buffer needs to be cleaned out    */
	  gvx.mk_list = gvx.tot_len + 1; /* ..before execution begins      */

com (04):				/* K - kopyappend		       */
com (05):				/* M - moveappend		       */
	  used = rl_l - rl_i + 1;
	  call tedget_buffer_ (dbase_p, addr (rl_c (rl_i)), used, tbp, msg);
	  rl_i = rl_i + used;
	  if (tbp = null ())
	  then goto rq_err_msg;
	  if tbp -> b.present (1)
	  then do;
	     msg = "Gma) No addrs allowed on destination.";
	     goto gv_msg_com;
	  end;
	  cfmk.cb_r = rel (tbp);
	  cfmk.siz = size (cfmk);
	  goto comdone; %skip (3);
com (08):				/* s -  substitute		       */
com (15):				/* u - lowercase translate	       */
com (16):				/* U - uppercase translate	       */
	  call scan;
	  cfx.cexpml = 100;		/* DO IT RIGHT!		       */
	  cfx.cexpl = 0;		/* zero length of remembered regexp  */
	  call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
	       addr (cfx.cexpml), "0"b, (dbase.lit_sw), msg, code);
	  if (code ^= 0)
	  then do;
	     rl_i = expr_b + expr_l;
	     goto print_error_rc;
	  end;

	  cfx.cexpml = cfx.cexpl + 12;
	  call add_length ((cfx.cexpml));
	  if (it = 8)
	  then do;
	     cf.siz = size (cf);
	     call end_cf;
	     call replace$compile;
	  end;
	  cf.siz = size (cf);
	  goto comdone; %skip (3);
com (13):				/* l - linefeed to user_output       */
com (14):				/* L - linefeed to error_output      */
	  call add_length (1);
	  cf.da = NL;
	  cf.siz = size (cf);
	  goto comdone_NL; %skip (2);
com (11):				/* t - type to user_output	       */
com (12):				/* T - type to error_output	       */
	  call scan;
	  call add_length ((expr_l));
	  cf.da = substr (rl_s, expr_b, expr_l);
	  cf.siz = size (cf);
	  goto comdone_NL; %page;
com (01):				/* ( - byte address		       */
	  n1, n2 = 0;
	  n1_sw, n2_sw = "0"b;
	  adr_sw = "1"b;
	  do rl_i = rl_i to rl_l;
	     ch = rl_c (rl_i);
	     if (ch = ",")		/* means end of 1st addr	       */
	     then do;
	        if n1_sw | ^n2_sw
	        then do;
misplaced:
		 msg = "Gmc) Misplaced ";
		 msg = msg || ch;
		 msg = msg || ".";
		 vgch = "";
		 goto gv_msg_com;
	        end;
	        n1 = n2;
	        n1_sw = "1"b;
	        n2 = 0;
	        n2_sw = "0"b;
	     end;
	     else if (ch = "/")	/* expression (NOT YET)	       */
	     then do;
	        if n2_sw
	        then goto misplaced;
	        n2_sw = "1"b;
	        goto gv_nosrch;
	     end;
	     else if (ch = ")")
	     then do;
	        if ^n2_sw
	        then goto misplaced;
	        if ^n1_sw
	        then n1 = n2;
				/* if (sign (n1) = sign (n2))	       */
				/* then if (n2 < n1)	       */
				/* then goto gv_wrap;	       */
	        rl_i = rl_i + 1;
				/* if (rl_c (rl_i) = "(")	       */
				/* then goto misplaced;	       */
	        cfa.ad1 = n1;
	        cfa.ad2 = n2;
	        cfa.siz = size (cfa);
	        goto comdone;
	     end;
	     else do;
	        n2 = 0;
	        if (ch = "$")	/* means END-OF-LINE (where NL is)   */
	        then do;
		 if n2_sw
		 then goto misplaced;
		 n2_sw = "1"b;
		 if (rl_c (rl_i + 1) = "-")
		 then do;
		    rl_i = rl_i + 1;
		    i = verify (substr (rl_s, rl_i), "-0123456789");
		    goto gv_adrnum;
		 end;
	        end;
	        else do;
		 i = verify (substr (rl_s, rl_i), "0123456789");
gv_adrnum:
		 if (i = 0)	/* EVERYTHING is digits (no request) */
		      | (i = 1)	/* no digits		       */
		 then do;
		    msg = "Gia) Invalid addr char.";
		    vgch = "";
		    goto gv_msg_com;
		 end;
		 i = i - 1;
		 n2 = fixed (substr (rl_s, rl_i, i));
		 rl_i = rl_i + i - 1;
	        end;
	        n2_sw = "1"b;
	     end;
	  end;			/* control can never get here	       */
	  signal condition (cant_get_here);
dcl cant_get_here	condition; %skip (4);
com (17):				/* { - evaluation		       */
	  rl_i = rl_i - 1;
	  i = index (substr (rl_s, rl_i), "}");
	  if (i = 0)
	  then do;
	     msg = "Gvd) Missing }.";
	     goto gv_msg_com;
	  end;
	  call add_length ((i));
	  cf.da = substr (rl_s, rl_i, i);
	  rl_i = rl_i + i;
	  cf.siz = size (cf);
	  goto comdone;
com (18):				/* a - append		       */
com (20):				/* i - insert		       */
com (19):				/* c - change		       */
	  if (rl_c (rl_i) ^= " ")
	  then goto gv_blank;
	  i = index (substr (rl_s, rl_i), "\f");
	  if (i = 0)
	  then i = index (substr (rl_s, rl_i), "\F");
	  if (i = 0)
	  then do;
	     msg = "Gei) Missing \F.";
	     goto gv_msg_com;
	  end;
	  i = i - 2;
	  call add_length ((i));
	  cf.da = substr (rl_s, rl_i + 1, i);
	  rl_i = rl_i + i + 3;
	  cf.siz = size (cf);
	  goto comdone;
com (22):				/* > */
	  if (rl_c (rl_i) = "(")
	  then do;
	     i = index (substr (rl_s, rl_i), ")");
	     if (i = 0)
	     then do;
	        msg = "Ggo) Missing ).";
	        goto gv_msg_com;
	     end;
	  end;
	  else if (rl_c (rl_i) = "-") | (rl_c (rl_i) = "+")
	  then i = 2;
	  else i = 1;
	  call add_length ((i));
	  cf.da = substr (rl_s, rl_i, i);
	  rl_i = rl_i + i;
	  cf.siz = size (cf);
	  goto comdone;
com (21):				/* SP			       */
	  cf.op = -255;
	  goto comdone;
com (10):				/* = - linenumber		       */
com (03):				/* P - print w/ linenumber	       */
com (02):				/* p - print		       */
	  cf.siz = size (cf);
comdone_NL:
	  gvx.printing = "1"b;
com (09):				/* d - delete		       */
comdone:
	  call end_cf;
         end;
compiled:
         cf.op, cf.len = 0;
         cf.siz = 3;
         call end_cf;
get_ready: begin;
dcl tbp		ptr;

	  tbp = bp;
	  i = gvx.mk_list;		/* clean out all m/k buffers	       */
	  do cfp = addr (gvx.word (i))
	       repeat (addr (gvx.word (i))) while (i > 0);
	     bp = ptr (dbase_p, cfmk.cb_r);
	     call delete$all;	/* iso_line ^needed		       */
	     i = cfmk.link;
	  end;
	  bp = tbp;
         end;
         return;

gv_1addr:
         msg = "G1a) Only 1 addr allowed.";
         goto gv_msg_com;
gv_wrap:
         msg = "Gwa) Addr wrap-around.";
         goto gv_msg_com;
gv_nosrch:
         msg = "Gxx) Search addr not supported.";
         goto gv_msg_com;
gv_blank:
         msg = "Gnb) No blank after ";
         goto gv_msg_com;
no_2nd_delim:
         msg = "Gd2) No 2nd delimiter.";
         rl_i = rl_i - 1;
         goto gv_msg_com; %page;
/* . . . PARSE . . . */


%include ted_gv_p_;
%include ted_gv_t_;

dcl tbp		ptr;
/****dcl req_ch	char (1);					       */

add_length: proc (incr);

dcl incr		fixed bin (21);

      cf.len = cf.len + incr;
      if (gvx.max_len < gvx.tot_len + divide (cf.len + 3, 4, 24, 0))
      then do;
         msg = "Gxx) Global statement too long.";
         goto add_request;
      end;

   end add_length;
      end tedgv_;


dcl gme2		fixed bin (21);


gv_dump: entry;
      call tedshow_ (comptr, "gvx");
      return;


gv_srch: entry;

dcl 1 gb		like b based (gbp);
dcl g_s		char (gb.b_.r.re) based (gb.cur.sp);
dcl g_c		(gb.b_.r.re) char (1) based (gb.cur.sp);

dcl gsb		fixed bin (21) defined (gb.a_.l.re (1));
dcl gse		fixed bin (21) defined (gb.a_.r.le (2));

common:
      call init_cfp (gvx_p, gv_work);
      if (gvx.tot_len = 0)
      then do;
         msg = "Gcu) No prior execution of";
         goto add_request;
      end;
      NLlast = gvx.printing & gvNL;
      if (db_gv & (b.a_.l.re (1) = 1))
      then call tedshow_ (comptr, "gvx");

dcl last_op	fixed bin;
dcl adr_sw	bit (1);
      last_op = 0;
      gvx.ic = 1;
      b.present (1), b.present (2) = "1"b;
      do while ("1"b);
         cfp = addr (gvx.word (gvx.ic));
         if (last_op ^= adr_op)
         then do;
	  gsb = 1;
	  gse = 0;
	  adr_sw = "1"b;
         end;
         if fix_addr (gsb) & fix_addr (gse)
         then do;
	  if (gsb > gse)		/* can't wrap-around, either	       */
	  then adr_sw = ""b;
         end;
         else adr_sw = ""b;
         if ^adr_sw			/* address does not exist,	       */
         then gse = 0;		/* ..skip next operation	       */

         last_op = cf.op;
         if db_gv then do;
	  call tedshow_ (comptr, "cf");
	  call ioa_$ioa_switch (db_output, "sw=^b ^i:^i", adr_sw, gsb, gse);
         end;
(subscriptrange): goto srch (cf.op);

srch (01):			/* ( address processing	       */
         gsb = cfa.ad1;
         gse = cfa.ad2;
         adr_sw = "1"b;
         goto srchdone_inc;

srch (-5):			/* evaluation test		       */
         call tedeval_ (dbase_p, addr (cft.da), (cft.len), bp, null (), 0,
	    result, msg, code);
         if (code ^= 0)
         then goto print_error;
         if (result = "0") | (result = "false")
         then gvx.ic = cft.f;
         else gvx.ic = cft.t;
         goto testdone;

srch (-6):			/* search test		       */
         call tedsrch_$search (addr (cft.cexpml), bp, b.a_.l.le (1),
	    b.a_.r.re (2), b.a_.l.re (1), b.a_.r.le (2), gme2, msg, code);
         if (code = 0)
         then gvx.ic = cft.t;
         else if (code = 1)
         then gvx.ic = cft.f;
         else goto print_error;
testdone:
         if (gvx.ic = 0)
         then return;
         goto srchdone; %skip (3);
srch (-7):			/* test done, was success	       */
				/* let's make the data available     */
         cllen = b.a_.r.re (2) - b.a_.l.le (1) + 1;
         clloc = b.a_.l.le (1);
         call tedpseudo_ (gbp, b.cur.sn, addr (b_c (clloc)), cllen);
         gbp -> b.gb.l.ln = b.gb.l.ln;
         old_bp = bp;
         bp = gbp;
         b.a_.l.le (1), b.a_.l.re (1) = b.b_.l.le;
         b.a_.r.le (2), b.a_.r.re (2) = b.b_.l.re;
         goto srchdone_inc; %skip (3);
fix_addr: proc (val) returns (bit (1)); /* 1-result exists  0-doesn't	       */

dcl val		fixed bin (21);	/* value to be adjusted	       */

dcl tv		fixed bin (21);	/* temp value		       */

      if (val < 1)			/* this means $ or $-N	       */
      then do;
         val = -val;		/* (I think better positive)	       */
				/* window never in effect here       */
         tv = b.b_.r.re - b.b_.r.le + 1;/* how big upper part?	       */
         if (val < tv)
         then do;
	  val = b.b_.r.re - val;
	  return ("1"b);		/* it is:  r.le <= val <= r.re       */
         end;
         val = val - tv;		/* how much "hangs over"?	       */
         val = b.b_.l.re - val;	/* go that far in lower part	       */
         return (val > 0);
      end;
      if (val <= b.b_.l.re)		/* assumes b.b_.l.le=1 ALWAYS	       */
      then return ("1"b);		/* it is: l.le <= val <= l.re	       */
      val = val - b.b_.l.re;		/* how much "hangs over"?	       */
      val = b.b_.r.le + val - 1;	/* go that far in upper part	       */
      return (val <= b.b_.r.re);

   end fix_addr; %skip (3);
dcl 1 ln_		int static,
      2 dec6	pic "zzzzz9",
      2 tab	char (1) init ("	"); %skip;
srch (10):			/* = - linenumber */
         if ^adr_sw
         then goto srchdone_inc;
         dec6 = b.gb.l.ln;
         call iox_$put_chars (iox_$user_output, addr (dec6), 6, 0);
         goto srchdone_inc; %skip (4);
srch (03):			/* P - print w/ linenumber	       */
         if ^adr_sw
         then goto srchdone_inc;
         dec6 = b.gb.l.ln;
         call iox_$put_chars (iox_$user_output, addr (dec6), 7, 0);

srch (02):			/* p - print */
         if adr_sw
         then call print;
         goto srchdone_inc; %skip (4);
/**** M and K (m and k) also are the same. Deleting the destination buffer   */
/****  was done before the request processing began.		       */
srch (04):			/* K - kopy-append */
srch (05):			/* M - move-append */
srch (06):			/* k - kopy */
srch (07):			/* m - move */
         if ^adr_sw
         then goto srchdone_inc;
         b.cd.l.re = gsb;		/* set source		       */
         b.cd.r.le = gse;
         tbp = ptr (dbase_p, cfmk.cb_r);
         tbp -> b.cd.r.re = tbp -> b.b_.r.re + 1; /* set destination       */
         call buffer_buffer_copy (gbp, tbp, "0"b);
         if (cf.op = 4) | (cf.op = 6)
         then goto srchdone_inc;

srch (09):			/* d - delete */
         if ^adr_sw
         then goto srchdone_inc;
         call delete;
         call iso_line;
         goto srchdone_inc; %skip (4);
/*-*/
srch (19):			/* c - change */
         if ^adr_sw
         then goto srchdone_inc;
         call delete;
         goto aci_com;
srch (18):			/* a - append */
         gsb = gse + 1;
srch (20):			/* i - insert */
         if ^adr_sw
         then goto srchdone_inc;
         call openup;
aci_com:
         call add_2l (""b, addr (cf.da), (cf.len), NLct_check);
         goto srchdone_inc; %skip (3);
dcl tp		ptr;
srch (08):			/* s -  substitute */
         tp = addr (cfx.cexpml);
         gvx.ic = gvx.ic + cfx.siz;	/* move past the search part	       */
         cfp = addr (gvx.word (gvx.ic));
         if adr_sw
         then call substitute (tp);
         do while (cf.op < 0);	/* skip any unused "replace" parts   */
	  gvx.ic = gvx.ic + cfx.siz;
	  cfp = addr (gvx.word (gvx.ic));
         end;
         goto srchdone; %skip (3);
srch (15):			/* u - lowercase translate */
         if ^adr_sw
         then goto srchdone_inc;
         call upper_lower (addr (cfx.cexpml), "0"b);
         goto srchdone_inc;
srch (16):			/* U - uppercase translate */
         if ^adr_sw
         then goto srchdone_inc;
         call upper_lower (addr (cfx.cexpml), "1"b);
         goto srchdone_inc; %skip (4);
srch (13):			/* l - linefeed to user_output */
srch (11):			/* t - type to user_output */
         tbp = iox_$user_output;
         goto gv_tT;

srch (14):			/* L - linefeed to error_output */
srch (12):			/* T - type to error_output */
         tbp = iox_$error_output;
gv_tT:
         if ^adr_sw
         then goto srchdone_inc;
         call iox_$put_chars (tbp, addr (cf.da), (cf.len), 0);
         goto srchdone_inc;

srch (17):			/* { - evaluation */
         if ^adr_sw
         then goto srchdone_inc;
         gb.present (1), gb.present (2) = "1"b;
/****		tedeval_ modifies 3rd arg, so (cf.len) is used.	       */
         call tedeval_ (dbase_p, addr (cf.da), (cf.len), gbp, null (), 0,
	    result, msg, code);
         if (code ^= 0)
         then goto print_error;
         if (result ^= "")
         then call ioa_ ("g* {...} has unexpected result of ""^a"".", result);
         goto srchdone_inc; %skip (4);
srch (22):			/* > -stop global if, goto */
         if ^adr_sw
         then goto srchdone_inc;
         call tedset_ptr_ (dbase_p, cf.da, code);
         if (code = 10)
         then goto rq_err;		/*  return ("1"b); */
         old_bp -> b.gb.l.le, old_bp -> b.gb.l.re
	    = old_bp -> b.gb.r.re;
         old_bp -> b.gb.l.le = old_bp -> b.gb.l.le + 1;
				/* STOP here		       */
         goto srch (0); %skip (3);
dcl (cllen, clloc)	fixed bin (21);
dcl old_bp	ptr;

srch (21):			/* \040 - never can happen	       */
srch (-1):			/* literal replacement	       */
srch (-2):			/* & replacement		       */
srch (-3):			/* x\= replacement		       */
srch (-4):			/* \g{...} replacement	       */
         signal condition (should_not_be_here);
         goto nx_line;

srchdone_inc:
         gvx.ic = gvx.ic + cf.siz;
srchdone:
      end;
srch (00):			/* end of program		       */
      bp = old_bp;
      gb.noref = "1"b;
      if ^gb.mod_sw
      then return;			/* no change made		       */
      llen = gb.b_.l.re - gb.b_.l.le + 1; /* how long is left part	       */
      rlen = gb.b_.r.re - gb.b_.r.le + 1; /* how long is right part	       */
      if (rlen + llen ^= cllen)
      then goto srch_mod;
      if (llen > 0)			/* is left part different than it    */
      then do;			/* ..was when we started?	       */
         if substr (b_s, clloc, llen) ^= substr (g_s, gb.b_.l.le, llen)
         then goto srch_mod;
      end;
dcl (llen, rlen)	fixed bin (21);
      if (rlen > 0)			/* is right part different than it   */
      then do;			/* ..was when we started?	       */
         if substr (b_s, clloc + llen, rlen) ^= substr (g_s, gb.b_.r.le, rlen)
         then goto srch_mod;
      end;
      return;			/* no effective change made	       */
srch_mod:
      b.mod_sw = "1"b;		/* make sure modification is known   */
				/* ..(add_2l might not get done)     */
      b.a_.l.re (1) = b.a_.l.le (1);
      call openup;			/* insert "post" data	       */
      if (b.maxln > -1)
      then b.maxln = b.maxln - 1;	/* taking a line out	       */
      if (llen > 0)
      then call add_2l (ted_safe, addr (g_c (gb.b_.l.le)), llen, NLct_check);
      if (rlen > 0)
      then call add_2l (ted_safe, addr (g_c (gb.b_.r.le)), rlen, NLct_check);
      b.b_.r.le = b.b_.r.le + cllen;	/* get rid of "pre" data	       */
      b.a_.r.le (2) = b.b_.l.re;	/* ..get rid of dangling addr	       */
      return;
   end gv_compile; %page;
/* . . . EXTERNAL ENTRIES . . . */

dcl (addcharno, addr, addrel, byte, char, codeptr, convert, copy, divide,
    fixed, hbound, index, length, lbound, low, ltrim, max, min, null, ptr,
    rank, rel, reverse, rtrim, search, size, string, substr, translate,
    unspec, verify
    )		builtin;

/**** <<<<----- dcl_tedpromote_.incl.pl1 tedpromote_		       */
tedpromote_:			/* get a larger data buffer	       */
   entry (abp, al);
/****dcl (
/****abp		ptr,		/* -> buffer to promote	       */
/****al		fixed bin (21)	/* amount not fitting	       */
/****)		parm;		/* ----->>>>		       */

      bp = abp;
      dbase_p = ptr (bp, 0);
      call promote (al);
      return;

/**** <<<<----- dcl_tedcloseup_.incl.pl1 tedcloseup_		       */
tedcloseup_:			/* move all buffer data to lower     */
   entry (abp);
/****dcl (
/****abp		ptr		/* -> to buffer to convert	       */
/****)		parm;		/* ----->>>>		       */

      dbase_p = ptr (abp, 0);
      bp = abp;
      call promote$seg;
      return;


/**** <<<<----- dcl_tedpseudo_.incl.pl1 tedpseudo_		       */
tedpseudo_:			/* make a pseudo (read-only) buffer  */
   entry (abp, asn, asp, al);
dcl (
    abp		ptr,		/* -> to buffer to convert	       */
    asn		fixed bin,	/* segno of data (-1 if ^read)       */
    asp		ptr,		/* -> the data		       */
    al		fixed bin (21)	/* the length of it		       */
    )		parm;		/* ----->>>>		       */

      bp = abp;
      dbase_p = ptr (bp, 0);
      if db_ted
      then call ioa_$ioa_switch (db_output, "pseudo b(^a) ^i)^p ^i", b.name, asn, asp, al);
      if (b.cur.sn ^= 0)		/* if something here, scrap it       */
      then call delete$all;		/* iso_line not needed	       */
      b.maxln = NLct_unknown;
      b.pend.sp = asp;
      b.pend.sn = asn;
      b.pend.pn, b.pend.ast, b.pend.mbz = 0;
      b.newb = tedcommon_$no_data;
      b.newb.l.le = 1;
      b.newb.l.re, b.newb.r.re = al;
      b.newb.r.le = al + 1;		/* upper part is empty	       */
      b.pseudo = "1"b;
      call new_cur;			/* set new values for bl/br/al/ar    */
      if db_ted
      then call tedshow_ (bp, "bcb");

      return;			/* pseudo_buf */ %page;
act: entry;			/* handle the old form of active     */
				/*  function accessing.	       */

dcl act_name	char (5) int static init ("(act)");
dcl marker	char (1);
dcl arg_max	fixed bin;
dcl arg_l		fixed bin (21);

      marker = byte (11);		/* VT - not likely in argument data  */

      call tedget_buffer_ (null (), addr (act_name), length (act_name), bp,
	 msg);
      if (bp = null ())
      then do;
         call ioa_ ("Not in ted");
         return;
      end;
      dbase_p = ptr (bp, 0);
      call delete$all;		/* iso_line not needed	       */
      call cu_$arg_count (arg_max, code);
      j = 1;
      do argno = 1 to arg_max;
         call cu_$arg_ptr (argno, ttp, arg_l, code);
         if (argno ^= 1)		/* place marker between args	       */
         then call add_2l ("0"b, addr (marker), 1, 0);
         call add_2l ("0"b, ttp, arg_l, 0);
      end;

      return /* ted_act */; %page;
blank:				/* set blank mode		       */
   entry;
				/* +++++ <<>> */
      com_blank = "1"b;
      com1_blank = "1"b;
      return;

noblank:				/* set ^blank mode		       */
   entry;
				/* +++++ <<>> */
      com_blank = "0"b;
      com1_blank = "0"b;
      return;

partblank:			/* set partblank mode	       */
   entry;
				/* +++++ <<>> */
      com_blank = "0"b;
      com1_blank = "1"b;
      return;

passthru:				/* disable PI then signal it	       */
   entry;
				/* +++++ <<>> */
      pi_passthru = "1"b;
      signal condition (program_interrupt);
      return;

clear_chars_moved: entry (clear_name);
dcl clear_name	char (*);
      cm_val = -1;
dcl cm_val	fixed bin (30) init (0);

show_chars_moved: entry;

show_again:
      hold_db_output = db_output;
      if (db_output = null ())	/* make sure there is a switch for   */
      then db_output = iox_$user_output;/* ..debugging output	       */
      if (chars_moved >= 0)
      then do;
         char_pic = chars_moved;
         call ioa_$ioa_switch (db_output, "^a chars moved", char_pic);
         total_chars_moved = total_chars_moved + chars_moved;
      end;
      chars_moved = cm_val;
      if (cm_val = 0)
      then return;
      if (total_chars_moved >= 0)
      then do;
         char_pic = total_chars_moved;
         call ioa_$ioa_switch (db_output, "^10a^a chars moved", clear_name, char_pic);
      end;
      chars_moved = -1;
      total_chars_moved = 0;
      db_output = hold_db_output;	/* put back old value	       */
      return;
dcl char_pic	pic "zzz,zzz,zzz,zz9";
dcl (chars_moved	init (-1),
    total_chars_moved init (0)
    )		fixed bin (30) int static;

lnn: entry; ln_sw = "1"b; return;
lnf: entry; ln_sw = ""b; return;
dcl ln_sw		bit (1) int static init (""b);

lgn: entry;			/* turn on long switches	       */
      dbs = "1"b;
      i = 2;
      goto set_db;

lgf: entry;			/* turn off long switchs	       */
      dbs = "0"b;
      i = 2;
      goto set_db;

dbn: entry;			/* turn on debugging switches	       */

dcl dbs		bit (1);
      dbs = "1"b;
      i = 1;
      goto set_db;
dbf: entry;			/* turn off debugging switchs	       */
      dbs = "0"b;
      i = 1;
dcl dim		builtin;
dcl arg		char (arg_l) based (ttp);
set_db:
      call cu_$arg_ptr (1, ttp, arg_l, code);
      if (code ^= 0)
      then dbsw (*, i) = dbs;
      else do;
         do j = 1 to dim (swname, 1);
	  if (swname (j) = arg)
	  then do;
	     dbsw (j, i) = dbs;
	     return;
	  end;
         end;
         if (arg = "*") | (arg = "**")
         then dbsw (*, i) = dbs;
         else begin;
				/* dcl string	builtin;					       */
	     call com_err_ (0, "ted$db", "Valid args: ^a", string (swname));
	  end;
      end;
      return;

dcl 1 db_lg	(12) based (addr (tedcommon_$etc.sws)),
      2 dbsw	(2) bit (1) aligned;
dcl swname	(13) char (5) unal int static init (
		"ted  ", "addr ", "eval ", "sort ",
		"gv   ", "util ", "srch ", "glob ",
		"trac ", "Ed   ", "     ", "     ", "catch");

dcl AZ		char (26) int static init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl BS_C		char (1) int static init (""); /* \c */
dcl DBA		char (32) var;
dcl HT		char (1) int static init ("	");
dcl NLct_check	fixed bin (21) int static init (-2);
dcl NLct_unknown	fixed bin (21) int static init (-1);
dcl NLlast	bit (1);
dcl Psw		bit (1);
dcl SP		char (1) int static init (" ");
dcl SP_HT		char (2) int static init (" 	"); /* #160*/
dcl addr_undef	fixed bin int static options (constant) init (-1);
dcl af_bp		ptr;
dcl af_value	char (ted_data.return_string_l) var
		based (ted_data.return_string_p);
dcl after_l	fixed bin (21);
dcl alt_sw	bit (1);
dcl app_sw	bit (1);
dcl archive_$get_component entry (ptr, fixed bin (24), char (*), ptr,
		fixed bin (24), fixed bin (35));
dcl argname	char (7);
dcl argno		fixed bin;
dcl az		char (26) int static init ("abcdefghijklmnopqrstuvwxyz");
dcl b0_bp		ptr;
dcl b_depth	fixed bin;	/* depth of buffer remember stack */
dcl b_stack	(10) ptr;		/* buff remember stack (!b request)  */
dcl bc		fixed bin (24);
dcl ch		char (1);
dcl cleanup	condition;
dcl code		fixed bin (35);
dcl concealsw	bit (1);
dcl continue_to_signal_ entry (fixed bin (35));
dcl delim		char (1);
dcl enl		fixed bin (21);
dcl err_req	char (16) var;
dcl error_table_$inconsistent fixed bin (35) ext static;
dcl error_table_$insufficient_access fixed bin (35) ext static;
dcl error_table_$moderr external fixed bin (35);
dcl error_table_$noentry fixed bin (35) ext static;
dcl error_table_$no_component fixed bin (35) ext static;
dcl error_table_$unsupported_operation fixed bin (35) ext static;
dcl error_table_$zero_length_seg fixed bin (35) ext static;
dcl expr_b	fixed bin (21);	/* beginning of expression	       */
dcl expr_l	fixed bin (21);	/* length of expression	       */
dcl fcbp		ptr;
dcl file_c	(file_l) char (1) based (file_p);
dcl file_l	fixed bin (21);
dcl file_p	ptr;
dcl file_s	char (file_l) based (file_p);
dcl fo_sw		bit (1);
dcl gbp		ptr;		/* -> g* pseudo buffer	       */
dcl go_sw		bit (1);
dcl got_quit	bit (1);
dcl gvx_p		ptr;
dcl header_l	fixed bin (21);
dcl hold_de	fixed bin;
dcl i		fixed bin (21);
dcl ii		fixed bin (21);
dcl il		fixed bin (21);
dcl intsw		bit (1);
dcl iocb_ptr	ptr;
dcl j		fixed bin (21);
dcl jb		fixed bin (21);
dcl k		fixed bin (21);
dcl level		fixed bin (35) init (0);
dcl maxseg	fixed bin (21);
dcl me		fixed bin (21);
dcl me2		fixed bin (21);
dcl mi		fixed bin (21);
dcl ml		fixed bin (21);
dcl mrl_		entry (ptr, fixed bin (21), ptr, fixed bin (21));
dcl mustreprotect	bit (1);
dcl not_sw	bit (1);
dcl on_quit	bit (1);
dcl pdname	char (32) int static init (" ");
dcl pi_label	label;
dcl pi_passthru	bit (1) int static;
dcl pi_sw		fixed bin;
dcl program_interrupt condition;
dcl qedx_mode	bit (1);
dcl quit		condition;
dcl req_ch	char (1);
dcl req_chx	char (4) var;
dcl req_not	char (1);
dcl req_str	char (36) var;
dcl result	char (500) var;
dcl save_mod	bit (1);
dcl select	char (16);
				/**/ dcl should_not_be_here condition;
dcl sort_p	(3) ptr;		/* sorting work/work/output segs     */
dcl sort_sn	(3) fixed bin;	/* sequence #'s of them	       */
				/*dcl str		char (262143) based aligned;			       */
dcl sub_type	char (12) var;
dcl subf1		char (4);
dcl subf2		char (3);
dcl subfile_name	char (32) var;
dcl sub_p		ptr;
dcl subsw		bit (1);
dcl svlen		fixed bin (21);
dcl svpath	char (204);	/* temp storage of pathname	       */
dcl sys_info$max_seg_size fixed bin (35) ext static;
dcl tbi		fixed bin;
dcl tbp		ptr;
dcl tc		char (1);
dcl ted_fo_err	condition;
dcl ted_mode	fixed bin;
dcl ted_safe	bit (1) aligned;
dcl tedcleanup_	entry (ptr);
dcl tederror_table_$zero_length_buffer fixed bin (35) ext static;
dcl trustsw	bit (1);
dcl ttp		ptr;
dcl used		fixed bin (21);
dcl vgch		char (1);
dcl vgds		char (2) var;
dcl wct		fixed bin;
dcl which_mode	char (5);
dcl write_l	fixed bin (21);	/* length of file		       */
dcl wsw		bit (1);		/* 0- reading, 1- writing	       */
dcl xfe		fixed bin (21);
dcl xfi		fixed bin (21);
dcl xsw		bit (1);
dcl (sbp, dbp)	ptr;
%skip (3);
dcl command_query_	entry () options (variable);
dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*),
		fixed bin (35));
dcl get_group_id_	entry () returns (char (32));
dcl get_pdir_	entry () returns (char (168));
dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24),
		fixed bin (2), ptr, fixed bin (35));
dcl hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr,
		fixed bin (35));
dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin,
		fixed bin (35));
dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl terminate_file_ entry (ptr, fixed bin (21), bit (*), fixed bin (35));
dcl hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin,
		fixed bin (35));
dcl cu_$cp	entry (ptr, fixed bin (21), fixed bin (35));
dcl cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl cu_$arg_list_ptr entry (ptr);
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl ioa_		entry () options (variable);
dcl ioa_$ioa_switch entry () options (variable);
dcl ioa_$nnl	entry () options (variable);
dcl com_err_	entry () options (variable);
dcl NL		char (1) int static init ("
");


dcl 1 seg_acl	aligned,		/* structure for adding one acl      */
      2 userid	char (32),
      2 access	bit (36),
      2 ex_access	bit (36),
      2 status	fixed bin (35);

dcl 1 delete_acl	aligned,		/* structure for deleting one acl    */
      2 userid	char (32),
      2 status	fixed bin (35);

dcl 1 fd		like b.file_d;
dcl hold_db_output	ptr;
dcl answer	char (10) var;

dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*),
		fixed bin (35));
dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr,
		fixed bin (35));
dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1),
		fixed bin (2), fixed bin (24), fixed bin (35));

dcl iox_$attach_iocb entry (ptr, char (*)) returns (fixed bin (35));
dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl iox_$close	entry (ptr, fixed bin (35));
dcl iox_$control	entry (ptr, char (*), ptr, fixed bin (35));
dcl iox_$detach_iocb entry (ptr, fixed bin (35));
dcl iox_$error_output ptr ext static;
dcl iox_$find_iocb	entry (char (*), ptr, fixed bin (35));
dcl iox_$move_attach entry (ptr, ptr, fixed bin (35));
dcl iox_$open	entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl iox_$put_chars	entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl iox_$user_output ptr ext static;
dcl string_sw	bit (1) defined (b.present (0));
dcl hold_db_ted	bit (1) aligned;

dcl 1 CB		(dbase.bufnum) like b based (dbase.cba_p); %page;

%include ted_;
%include ted_support;
%include tedcommon_;
%include tedbase;
%include tedbcb;
%include tedstk;
%include tederror_;
%include mc;
%include query_info;
%include terminate_file;
%include branch_status;
dcl tedaddr_	entry (		/* process request addresses	       */
		ptr,		/* -> database		       */
		ptr,		/* -> string containing address      */
		fixed bin (21),	/*   length of it		  [IN] */
				/* If <0 then recursive call	       */
				/*   how much was used up	 [OUT] */
		ptr,		/* -> buffer control block  [IN/OUT] */
		char (168) var,	/* place to hold err message if any  */
		fixed bin (35),	/* status code		       */
				/*   0- null address	       */
				/*   1- address found	       */
				/*   8- error, msg tells what        */
		);


dcl tedcall_	entry (		/* call a buffer		       */
		ptr,		/* -> database		       */
		fixed bin (35)
		);

dcl tedcount_lines_ entry (		/* return # lines in string	       */
		ptr,		/* -> buffer in which to count       */
		fixed bin (21),	/* where string begins in segment    */
		fixed bin (21),	/* where string ends in segment      */
		fixed bin (21)	/* # lines		 [OUT] */
		);


dcl tedcheck_buffer_state_ entry (
		ptr,		/* -> database		       */
		ptr,		/* -> buffer control block	       */
		char (168) var	/* error message, if any	       */
		);


dcl tedcheck_buffers_ entry (		/* check for modified buffers        */
		ptr,		/* -> database		       */
		fixed bin		/* number of modified buffers found  */
		);

dcl tedcheck_entryname_ entry (char (*), fixed bin (35));
dcl tedend_buffer_	entry (		/* pop buffer recursion 1 level      */
		ptr,		/* -> database		       */
		fixed bin (35)	/* 1- already at level 0, 0- ok      */
		);

dcl tedeval_	entry (		/* process evaluations	       */
		ptr,		/* -> database		       */
		ptr,		/* -> evaluation string	       */
		fixed bin (21),	/*   length thereof 	  [IN] */
				/*   amount used up 	 [OUT] */
		ptr,		/* -> buffer control block	       */
		ptr,		/* -> matched string in \g{...}      */
				/*    null otherwise	       */
		fixed bin (21),	/*  length of string in \g{...}      */
				/* <0 in \{...}, 0 otherwise	       */
		char (500) var,	/* output string, if any	       */
		char (168) var,	/* error message, if any	       */
		fixed bin (35)	/* return code		       */
		);


dcl tedfree_segment_ entry (		/* give back a work segment	       */
		ptr,		/* -> database		       */
		fixed bin		/* sequence # of segment to free     */
		);

dcl tedget_existing_buffer_ entry (	/* find a named buffer	       */
		ptr,		/* -> database		       */
		ptr,		/* -> string containing buffer name  */
		fixed bin (21),	/*   length of string	  [IN] */
				/*   how much was used	 [OUT] */
		ptr,		/* buffer control block (OUT)        */
		char (168) var	/* error message text	       */
		);

dcl tedget_buffer_	entry (		/* find (or create) a buffer	       */
		ptr,		/* -> database		       */
		ptr,		/* -> string containing buffer name  */
		fixed bin (21),	/*   length of string	  [IN] */
				/*   how much was used	 [OUT] */
		ptr,		/* buffer control block (OUT)        */
		char (168) var	/* error message text	       */
		);


dcl tedget_segment_ entry (		/* get a segment to work in	       */
		ptr,		/* -> database		       */
		ptr,		/* -> gotten segment	 [OUT] */
		fixed bin,	/* sequence # of it         [IN/OUT] */
				/* if >0 upon entry, it will then    */
				/*  fill that entry in seg_p array   */
				/* otherwise it will take any one    */
		);


dcl tedhold_	entry (ptr);
dcl tedinit_	entry (		/* create a ted environment	       */
		ptr,		/* -> ted_ input structure	       */
		ptr,		/* -> dbase		 (OUT) */
		fixed bin (35)	/* status code		       */
		);

dcl tedlist_buffers_ entry (		/* show the status of buffers        */
		ptr,		/* -> database		       */
		char (16),	/* name of buffer to show	       */
		bit (1),		/* 0- listing inactive environment   */
				/* 1- listing active one	       */
		bit (1)		/* 1- validate b.maxln	       */
		);

dcl tedpseudo_	entry (		/* make a pseudo (read-only) buffer  */
		ptr,		/* -> to buffer to convert	       */
		fixed bin,	/* segno of data (-1 if ^read)       */
		ptr,		/* -> the data		       */
		fixed bin (21)	/* the length of it 	       */
		);


dcl tedread_ptr_	entry (		/* read a line from input stream     */
		ptr,		/* -> database		       */
		ptr,		/* -> input buffer		       */
		fixed bin (21),	/* last char in use in buffer        */
		fixed bin (21),	/* last char useable in buffer       */
		fixed bin (21),	/* last char filled in buffer  [OUT] */
		char (5)		/* mode in which read is being done  */
		);

dcl tedresetread_	entry (ptr);
dcl tedset_ck_ptr_	entry (ptr);
dcl tedset_ptr_	entry (		/* find label in local buffer        */
		ptr,		/* -> database		       */
		char (*),		/* label to find		       */
		fixed bin (35)	/* return code		       */
		);

dcl tedshow_	entry options (variable);
dcl tedshow_$init	entry;
dcl tedsort_	entry (		/* sort in a buffer 	       */
		ptr,		/* -> key specifications	       */
		fixed bin (21),	/*   length thereof 	       */
		ptr,		/* -> string to be sorted	       */
		fixed bin (21),	/*   length thereof 	       */
		(3) ptr,		/* working segments 	       */
				/*  (1) temp seg		       */
				/*  (2) temp seg		       */
				/*  (3) output seg		       */
		fixed bin (21),	/* length of result 	 [OUT] */
		char (168) var,	/* error details		       */
		fixed bin (35)	/* return code		 [OUT] */
		);

dcl tedsort_$show	entry (		/* print special collating sequence  */
				/* no arguments		       */
		);

dcl tedsort_$set	entry (		/* set special collating sequence    */
		char (*)		/* user's specification	       */
		);

/*dcl tedsort_$compare entry (	/* compare strings w/ spec collate  * /
		ptr,		/* points to seg containin/g strings* /
		ptr,		/* points to R array	      * /
		bit (3)		/* the 3 bits represent <=>	      * /
		);					       */

dcl gvNL		bit (1);
   end ted_;
 



		    ted_command_.pl1                10/07/88  1311.2rew 10/07/88  1306.9      148509


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-08-03,RWaters), approve(88-08-03,MCR7950), audit(88-09-29,Huen),
     install(88-10-07,MR12.2-1146):
     Bug fixes for MR12.2.
                                                   END HISTORY COMMENTS */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

/*							       */
/*  _|_              |    /|					       */
/*   |      _      _ |   / |					       */
/*   |     / \    / \|  |__|_					       */
/*   |    (__/   (   |     |					       */
/*   \_    \_/    \_/|     |					       */
/*							       */
/*							       */

/* ted is an editor based on qedx.  There have been extensive modifications.
   ted	06/01/72	J Falksen
   ted3	01/01/73	J Falksen
   ted4	11/01/74	J Falksen
   ted2.0 07/14/76	J Falksen
   ted2.5 05/15/80  jaf
   ted2.6 02/20/81  jaf
   ted3.0 01/15/82  jaf
   ted3.2 07/08/88  RW
*/
ted: proc;
      td.ted_mode = NORMAL;
      goto init;

qedx: entry;

      td.tedname = "qedx";
      td.ted_mode = NORMAL;
      opt_sw = "0"b;
      goto initq;

ted_opt: entry;
      td.tedname = "ted_opt";
      td.ted_mode = -1;
      opt_sw = "1"b;
      goto initq;
/**** format: off						       */
dcl 1 keywords	int static options (constant),
   2 k10, 3 f bin init(01), 3 c char(12)init("-Jset"),        /* out-of-date */
   2 k11, 3 f bin init(02), 3 c char(12)init("-Jshow"),       /* out-of-date */
   2 k12, 3 f bin init(07), 3 c char(12)init("-abort"),
   2 k13, 3 f bin init(03), 3 c char(12)init("-ag"),
   2 k14, 3 f bin init(03), 3 c char(12)init("-arguments"),
   2 k15, 3 f bin init(05), 3 c char(12)init("-blank"),       /* out-of-date */
   2 k16, 3 f bin init(06), 3 c char(12)init("-break"),       /* out-of-date */
   2 k17, 3 f bin init(07), 3 c char(12)init("-com"),
   2 k18, 3 f bin init(26), 3 c char(12)init("-db"),
   2 k19, 3 f bin init(26), 3 c char(12)init("-debug"),
   2 k20, 3 f bin init(08), 3 c char(12)init("-label"),	  /* out-of-date */
   2 k21, 3 f bin init(10), 3 c char(12)init("-no_blank"),    /* out-of-date */
   2 k22, 3 f bin init(11), 3 c char(12)init("-no_break"),    /* out-of-date */
   2 k23, 3 f bin init(12), 3 c char(12)init("-no_label"),    /* out-of-date */
   2 k24, 3 f bin init(25), 3 c char(12)init("-no_read"),     /* out-of-date */
   2 k25, 3 f bin init(13), 3 c char(12)init("-no_trace"),    /* out-of-date */
   2 k26, 3 f bin init(24), 3 c char(12)init("-opt"),
   2 k27, 3 f bin init(24), 3 c char(12)init("-option"),
   2 k28, 3 f bin init(14), 3 c char(12)init("-part_blank"),  /* out-of-date */
   2 k29, 3 f bin init(15), 3 c char(12)init("-pathname"),
   2 k30, 3 f bin init(16), 3 c char(12)init("-pause"),
   2 k31, 3 f bin init(15), 3 c char(12)init("-pn"),
   2 k33, 3 f bin init(27), 3 c char(12)init("-request"),
   2 k34, 3 f bin init(17), 3 c char(12)init("-reset"),
   2 k35, 3 f bin init(18), 3 c char(12)init("-restart"),
   2 k32, 3 f bin init(27), 3 c char(12)init("-rq"),
   2 k36, 3 f bin init(19), 3 c char(12)init("-safe"),
   2 k37, 3 f bin init(23), 3 c char(12)init("-st"),
   2 k38, 3 f bin init(23), 3 c char(12)init("-status"),
   2 k39, 3 f bin init(28), 3 c char(12)init("-td"),
   2 k40, 3 f bin init(28), 3 c char(12)init("-temp_dir"),
   2 k41, 3 f bin init(20), 3 c char(12)init("-trace"), 	  /* out-of-date */
   2 k42, 3 f bin init(21), 3 c char(12)init("-trace_edit"),  /* out-of-date */
   2 k43, 3 f bin init(22), 3 c char(12)init("-trace_input"); /* out-of-date */
/**** format: on						       */

dcl 1 param	(34) based (addr (keywords)),
      2 f		bin,
      2 c		char (12);

safe: entry;
      td.ted_mode = SAFE;
      goto init;

com: entry;
      td.ted_mode = COM;
      goto init;

restart: entry;
      td.ted_mode = RESTART;
      goto init;


dcl debug_sw	bit (1);

dcl ted_data_p	ptr;

dcl 1 td		like ted_data;
dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl tedsort_$set	entry (char (*));
dcl tedsort_$show	entry;
dcl tedbreak_	entry;

dcl ted_com	char (1020) var;

/* RW 88 */
dcl message	char (64); /* Some are longer than 32 */

dcl arg		char (arg_l) based (arg_p);
dcl arg_l		fixed bin (21);
dcl arg_p		ptr;
dcl argno		fixed bin;
dcl bf_msg	bit (1);
dcl code		fixed bin (35);
dcl com_p		ptr;
dcl com_l		fixed bin (24);
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cu_$arg_list_ptr entry returns (ptr);
dcl error_table_$action_not_performed fixed bin (35) ext static;
dcl error_table_$badopt fixed bin (35) ext static;
dcl first		fixed bin (24);
dcl i		fixed bin (24);
dcl last		fixed bin (24);
dcl opt		char (256) var init ("");
dcl opt_sw	bit (1);
dcl pn		char (256) var init ("");
dcl req		char (500) var init ("");
dcl state		fixed bin;
dcl subfile_name	char (32) var;
dcl NL		char (1) int static init ("
");

dcl cu_$af_arg_count entry (fixed bin, fixed bin (35));
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl af_value	char (td.return_string_l) var based (td.return_string_p);
dcl af_sw		bit (1);
dcl ioa_		entry () options (variable);
dcl tedreset_ entry options (variable);
dcl get_default_wdir_ entry () returns (char (168) aligned);
dcl err_		entry () options (variable) automatic;
dcl com_err_	entry () options (variable);
dcl active_fnc_err_ entry () options (variable);

dcl (addr, addrel, divide, hbound, index, length, null, substr) builtin;%page;
init:
      td.tedname = "ted";
      opt_sw = "0"b;
initq:
      if ""b			/* can be patched on if needed       */
      then call send_message_("ted","Multics",td.tedname||"_"||ted_vers,0);
dcl send_message_	entry (char(*), char(*), char(*), fixed bin(35));
      td.temp_dir = "";
      td.version = ted_data_version_1;
      req = "";
      com_p = null ();
      call cu_$af_arg_count (td.arg_list_n, code);
      if (code ^= 0)
      then do;			/* not an active function */
         td.return_string_p = null ();
         td.return_string_l = 0;
         err_ = com_err_;
         af_sw = "0"b;
      end;
      else do;
         call cu_$af_return_arg (0, td.return_string_p, td.return_string_l,
	  code);
         af_value = "";
         err_ = active_fnc_err_;
         af_sw = "1"b;
      end;

      if (td.ted_mode = RESTART) & af_sw
      then goto af_err;

      if opt_sw & (td.arg_list_n = 0)
      then do;
         call ioa_ ("Usage:	ted     """" -ctl- -args-
	ted     ted_com -ctl- -args-
	ted     -reset -level-
	ted     -restart
	ted     -pause
	ted     -status
	ted_opt -ctl-");
         call ioa_ ("Ctlargs:	-safe|-abort, -arguments args, -request XXX,
	-option XXX, -debug, -pathname xxx");
         return;
      end;
      ted_com = "";
      td.arg_list_1 = td.arg_list_n + 1;
      argno = 0;
      code = 0;
      debug_sw = "0"b;
      state = 0;
      do argno = 1 to td.arg_list_n;
         call cu_$arg_ptr (argno, arg_p, arg_l, code);
         if (code = 0)
         then do;
	  goto word_rtn (state);

word_rtn (0):			/* nothing pending		       */
	  if (substr (arg, 1, 1) = "-")
	  then do;		/* binary search the keyword table   */
	     first = 1;
	     last = hbound (param, 1);
	     do while (first <= last);
	        i = divide (first + last, 2, 17, 0);
	        if (param (i).c = arg)
	        then goto key_rtn (param (i).f);
	        if (param (i).c > arg)
	        then last = i - 1;
	        else first = i + 1;
	     end;
	     message = "^a";
	     code = error_table_$badopt;
	     goto comerr;
key_rtn (01):			/* set collating sequence for Jsort */
	     if af_sw
	     then do;
af_err:
	        message = "Control arg not usable with active function.";
	        code = error_table_$action_not_performed;
	        goto comerr;
	     end;
	     state = 1;
	     goto need_value;
word_rtn (1):
	     call tedsort_$set (arg);
	     return;

key_rtn (02):			/* show collating sequence for Jsort */
	     if af_sw
	     then goto af_err;
	     call tedsort_$show;
	     return;

key_rtn (03):			/* everything after this is args     */
	     if opt_sw
	     then goto not_allowed;
	     td.arg_list_1 = argno + 1;
	     argno = td.arg_list_n + 1;  /* force end-of-loop	       */
	     goto done_key;

key_rtn (04):			/* brief message format	       */
	     bf_msg = "1"b;
	     goto done_key;

key_rtn (05):			/* blank			       */
	     opt = opt || ",blank";
	     goto done_key;

key_rtn (06):			/* allow breaks		       */
	     opt = opt || ",break";
	     goto done_key;

key_rtn (07):			/* executing ted_com	       */
	     if (td.ted_mode ^= NORMAL)
	     then goto mod_err;
	     td.ted_mode = COM;
	     goto done_key;

key_rtn (08):			/* show labels when executed	       */
	     opt = opt || ",label";
	     goto done_key;

key_rtn (09):			/* long message format	       */
	     bf_msg = "0"b;
	     goto done_key;

key_rtn (10):			/* no_blank		       */
	     opt = opt || ",^break";
	     goto done_key;

key_rtn (11):			/* turn off breaks		       */
	     opt = opt || ",^break";
	     goto done_key;

key_rtn (12):			/* dont show labels		       */
	     opt = opt || ",^label";
	     goto done_key;

key_rtn (13):			/* trace off		       */
	     opt = opt || ",^trace";
	     goto done_key;

key_rtn (14):			/* part_blank		       */
	     opt = opt || ",partblank";
	     goto done_key;

key_rtn (15):			/* read file for editing	       */
	     if opt_sw
	     then goto not_allowed;
	     state = 2;
	     goto need_value;
word_rtn (2):
	     pn = arg;
	     goto done_word;

key_rtn (16):			/* act like a break NOW	       */
	     if af_sw
	     then goto af_err;
	     call tedbreak_;

/* NEVER RETURNS */

key_rtn (17):			/* reset			       */
	     if af_sw
	     then goto af_err;
	     if (argno = td.arg_list_n)
	     then do;		/* no argument follows	       */
	        call tedreset_;
	        return;
	     end;
	     state = 3;
	     goto done_key;
word_rtn (3):
	     call tedreset_ (arg);
	     return;

key_rtn (18):			/* restart		       */
	     if af_sw
	     then goto af_err;
	     if (td.ted_mode ^= NORMAL)
	     then goto mod_err;
	     td.ted_mode = RESTART;
	     goto done_key;

key_rtn (19):			/* safe			       */
	     if (td.ted_mode ^= NORMAL)
	     then goto mod_err;
	     td.ted_mode = SAFE;
	     goto done_key;

key_rtn (20):			/* trace on		       */
	     opt = opt || ",trace";
	     goto done_key;

key_rtn (21):			/* trace edit		       */
	     opt = opt || ",edit";
	     goto done_key;

key_rtn (22):			/* trace input		       */
	     opt = opt || ",input";
	     goto done_key;

key_rtn (23):			/* status st */
	     if af_sw
	     then goto af_err;
				/* nothing doing */
	     call tedstatus_(get_default_wdir_ (), code);
	     return;

key_rtn (24):			/* option */
	     state = 4;
	     goto need_value;
word_rtn (4):
	     opt = opt || ",";
	     opt = opt || arg;
	     goto done_word;

key_rtn (25):			/* no_read */
	     opt = opt || ",^read";
	     goto done_key;

key_rtn (26):			/* debug */
	     debug_sw = "1"b;
	     goto done_key;

key_rtn (27):			/* request */
	     state = 5;
	     goto need_value;
word_rtn (5):
	     req = req || arg;
	     req = req || NL;
	     goto done_word;

key_rtn (28):			/* temp_dir */
	     if (td.ted_mode ^= NORMAL)
	     then goto mod_err;
	     td.ted_mode = SAFE;
	     state = 6;
	     goto done_key;
word_rtn (6):
	     call absolute_pathname_ (arg, td.temp_dir, code);
	     if (code ^= 0)
	     then goto comerr;
	     goto done_word;
need_value:
	     message = arg;
	     goto done_key;

done_word:
	     state = 0;
done_key:
	  end;
	  else do;
	     if opt_sw
	     then do;
	        call err_ (0, td.tedname, "Only options are allowed");
	        return;
	     end;
	     if (com_p = null ())
	     then do;
	        com_p = arg_p;
	        com_l = arg_l;
	     end;
	     else do;
	        td.arg_list_1 = argno;
	        argno = td.arg_list_n + 1;
	     end;
	  end;
         end;
      end;
      if (state ^= 0)
      then do;
         call err_ (0, td.tedname, "Missing value for ^a.", message);
         return;
      end;
/* the order of things in execute string:
  -opt {optonly} -pn -req {ted_com} -abort -db
/* note that the option is executed FIRST			       */
      if opt ^= ""
      then ted_com = ted_com ||"o " || substr (opt, 2) || NL;

      if opt_sw
      then ted_com = ted_com || " q" || NL;

      if (pn ^= "")
      then do;
         ted_com = ted_com || "^>(-pn) r ";
         ted_com = ted_com || pn;
         ted_com = ted_com || "
>+2
:(-pn) {""ted: ""||fs(em,5);} Q
""
";
      end;

      if (req ^= "")
      then ted_com = ted_com || req;

      if (com_p ^= null ())
      then do;
         arg_p = com_p;
         arg_l = com_l;
         if (arg ^= "")
         then do;
	  ted_com = ted_com || "b(exec)  r "; /* set up input	       */
				/*  lines to read in and execute     */
				/*  macro			       */
	  subfile_name = "";
	  if (td.tedname = "ted")
	  then do;
	     i = index (arg, "|");
	     if (i ^= 0)
	     then do;
	        subfile_name = substr (arg, i);
	        arg_l = i - 1;
	     end;
	  end;
	  ted_com = ted_com || arg;	/* .. */
	  if (arg_l < 5)
	  then goto add_name;
	  if substr (arg, (arg_l - 4), 5) ^= ".qedx"
				/* add suffix to path if necessary   */
	  then if (substr (arg, (arg_l - 3), 4) ^= ".ted")
	       then do;
add_name:
		ted_com = ted_com || ".";
		ted_com = ted_com || td.tedname;
	       end;
	  ted_com = ted_com || subfile_name;

	  ted_com = ted_com || "
b0
\B(exec)
";
         end;
      end;

      if (td.ted_mode = COM)
      then do;
         ted_com = ted_com || "t|";
         ted_com = ted_com || td.tedname;
         ted_com = ted_com || ": exiting| l Q
";
      end;

      if debug_sw
      then ted_com = ted_com || "t|Edit.| l
";

      td.ted_com_p = addrel (addr (ted_com), 1);
      td.ted_com_l = length (ted_com);
      td.arg_list_p = cu_$arg_list_ptr ();
      td.input_p, td.output_p = null ();
      if (td.temp_dir = "") & ((td.ted_mode = SAFE) | (td.ted_mode = RESTART))
      then td.temp_dir = get_default_wdir_ ();
      call tedshow_$init; dcl tedshow_$init entry;
      if db_sw then call ioa_ ("ted_com:^/^a", ted_com);
      call ted__ (addr (td), code);
dcl ted__		entry(ptr,fixed bin(35));
      if (code ^= 0)
      then call err_(code, td.tedname);
      return;

dcl db_sw		bit (1) int static init ("0"b);
dbn: entry; db_sw="1"b; return;
dbf: entry; db_sw="0"b; return;
/*   /* . . . ERROR MESSAGE ROUTINES . . . */

not_allowed:
      message = "^a not allowed.";
      goto comerr;

mod_err:
      if opt_sw
      then goto not_allowed;
      message = "^a duplicates prior option.";
      goto comerr;

comerr:
      call err_ (code, td.tedname, message, arg);
      return;


%include ted_;
%include tedbase;
%include tedcommon_;
%include tedbcb;
/*dcl tedget_existing_buffer_ entry (	/* find a named buffer	      * /
		ptr,		/* -> database		      * /
		ptr,		/* -> string containing buffer name * /
		fixed bin (21),	/*   length of string	  [IN]* /
				/*   how much was used	 [OUT]* /
		ptr,		/* buffer control block (OUT)       * /
		char (168)var	/* error message text	      * /
		);					       */

/*dcl tedget_buffer_	entry (	/* find (or create) a buffer	      * /
		ptr,		/* -> database		      * /
		ptr,		/* -> string containing buffer name * /
		fixed bin (21),	/*   length of string	  [IN]* /
				/*   how much was used	 [OUT]* /
		ptr,		/* buffer control block (OUT)       * /
		char (168)var	/* error message text	      * /
		);					       */


dcl tedstatus_	entry (		/* display saved environments        */
		char (*), 	/* name of temp dir 	       */
		fixed bin (35)	/* status code		       */
		);


   end ted;
   



		    ted_eval_t_.alm                 11/23/82  1129.5rew 11/22/82  1533.4      999927


" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
	equ	STRD,0
	equ	LOOK,1
	equ	STRDS,2
	equ	LOOKS,3
	equ	APLY,4
	equ	APLY1,5
	equ	APLYS,6
	equ	SKIP,7
	equ	ADJUST,8
	equ	NSRD,9
	equ	NSRDS,10
	equ	T0,0
	equ	ST0,0
"
"
" TERMINALS table (TL TC)
"
	use	utc
TC:	zero	0,TCs*4
	segdef	TC
	equ	T0,0
	use	utl
TL:	zero	0,TLs
	segdef	TL
"
" TERMINAL 1
	use	utc
	set	Tsl,*-TC-1
	aci	"<int"
	aci	"eger"
	aci	">   "
	use	utl
	equ	T1,*-TL
	zero	Tsl*4+1,9
"
" TERMINAL 2
	use	utc
	set	Tsl,*-TC-1
	aci	"<str"
	aci	"ing>"
	use	utl
	equ	T2,*-TL
	zero	Tsl*4+1,8
"
" TERMINAL 3
	use	utc
	set	Tsl,*-TC-1
	aci	"]   "
	use	utl
	equ	T3,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 4
	use	utc
	set	Tsl,*-TC-1
	aci	",   "
	use	utl
	equ	T4,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 5
	use	utc
	set	Tsl,*-TC-1
	aci	"{   "
	use	utl
	equ	T5,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 6
	use	utc
	set	Tsl,*-TC-1
	aci	"}   "
	use	utl
	equ	T6,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 7
	use	utc
	set	Tsl,*-TC-1
	aci	"(   "
	use	utl
	equ	T7,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 8
	use	utc
	set	Tsl,*-TC-1
	aci	")   "
	use	utl
	equ	T8,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 9
	use	utc
	set	Tsl,*-TC-1
	aci	":   "
	use	utl
	equ	T9,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 10
	use	utc
	set	Tsl,*-TC-1
	aci	";   "
	use	utl
	equ	T10,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 11
	use	utc
	set	Tsl,*-TC-1
	aci	":=  "
	use	utl
	equ	T11,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 12
	use	utc
	set	Tsl,*-TC-1
	aci	"*   "
	use	utl
	equ	T12,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 13
	use	utc
	set	Tsl,*-TC-1
	aci	"/   "
	use	utl
	equ	T13,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 14
	use	utc
	set	Tsl,*-TC-1
	aci	"|   "
	use	utl
	equ	T14,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 15
	use	utc
	set	Tsl,*-TC-1
	aci	"+   "
	use	utl
	equ	T15,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 16
	use	utc
	set	Tsl,*-TC-1
	aci	"-   "
	use	utl
	equ	T16,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 17
	use	utc
	set	Tsl,*-TC-1
	aci	"<   "
	use	utl
	equ	T17,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 18
	use	utc
	set	Tsl,*-TC-1
	aci	">   "
	use	utl
	equ	T18,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 19
	use	utc
	set	Tsl,*-TC-1
	aci	"=   "
	use	utl
	equ	T19,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 20
	use	utc
	set	Tsl,*-TC-1
	aci	"<=  "
	use	utl
	equ	T20,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 21
	use	utc
	set	Tsl,*-TC-1
	aci	">=  "
	use	utl
	equ	T21,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 22
	use	utc
	set	Tsl,*-TC-1
	aci	"^=  "
	use	utl
	equ	T22,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 23
	use	utc
	set	Tsl,*-TC-1
	aci	"a[  "
	use	utl
	equ	T23,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 24
	use	utc
	set	Tsl,*-TC-1
	aci	"k[  "
	use	utl
	equ	T24,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 25
	use	utc
	set	Tsl,*-TC-1
	aci	"K[  "
	use	utl
	equ	T25,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 26
	use	utc
	set	Tsl,*-TC-1
	aci	"Ks  "
	use	utl
	equ	T26,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 27
	use	utc
	set	Tsl,*-TC-1
	aci	"be  "
	use	utl
	equ	T27,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 28
	use	utc
	set	Tsl,*-TC-1
	aci	"bn  "
	use	utl
	equ	T28,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 29
	use	utc
	set	Tsl,*-TC-1
	aci	"fl  "
	use	utl
	equ	T29,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 30
	use	utc
	set	Tsl,*-TC-1
	aci	"fs  "
	use	utl
	equ	T30,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 31
	use	utc
	set	Tsl,*-TC-1
	aci	"lb  "
	use	utl
	equ	T31,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 32
	use	utc
	set	Tsl,*-TC-1
	aci	"le  "
	use	utl
	equ	T32,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 33
	use	utc
	set	Tsl,*-TC-1
	aci	"sb  "
	use	utl
	equ	T33,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 34
	use	utc
	set	Tsl,*-TC-1
	aci	"se  "
	use	utl
	equ	T34,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 35
	use	utc
	set	Tsl,*-TC-1
	aci	"da  "
	use	utl
	equ	T35,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 36
	use	utc
	set	Tsl,*-TC-1
	aci	"dk  "
	use	utl
	equ	T36,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 37
	use	utc
	set	Tsl,*-TC-1
	aci	"dK  "
	use	utl
	equ	T37,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 38
	use	utc
	set	Tsl,*-TC-1
	aci	"dn  "
	use	utl
	equ	T38,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 39
	use	utc
	set	Tsl,*-TC-1
	aci	"en  "
	use	utl
	equ	T39,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 40
	use	utc
	set	Tsl,*-TC-1
	aci	"sn  "
	use	utl
	equ	T40,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 41
	use	utc
	set	Tsl,*-TC-1
	aci	"fak "
	use	utl
	equ	T41,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 42
	use	utc
	set	Tsl,*-TC-1
	aci	"fka "
	use	utl
	equ	T42,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 43
	use	utc
	set	Tsl,*-TC-1
	aci	"em  "
	use	utl
	equ	T43,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 44
	use	utc
	set	Tsl,*-TC-1
	aci	"fi  "
	use	utl
	equ	T44,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 45
	use	utc
	set	Tsl,*-TC-1
	aci	"fir "
	use	utl
	equ	T45,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 46
	use	utc
	set	Tsl,*-TC-1
	aci	"fv  "
	use	utl
	equ	T46,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 47
	use	utc
	set	Tsl,*-TC-1
	aci	"fvr "
	use	utl
	equ	T47,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 48
	use	utc
	set	Tsl,*-TC-1
	aci	"ff  "
	use	utl
	equ	T48,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 49
	use	utc
	set	Tsl,*-TC-1
	aci	"ffr "
	use	utl
	equ	T49,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 50
	use	utc
	set	Tsl,*-TC-1
	aci	"fln "
	use	utl
	equ	T50,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 51
	use	utc
	set	Tsl,*-TC-1
	aci	"sk  "
	use	utl
	equ	T51,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 52
	use	utc
	set	Tsl,*-TC-1
	aci	"J   "
	use	utl
	equ	T52,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 53
	use	utc
	set	Tsl,*-TC-1
	aci	"Kl  "
	use	utl
	equ	T53,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 54
	use	utc
	set	Tsl,*-TC-1
	aci	"Kb  "
	use	utl
	equ	T54,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 55
	use	utc
	set	Tsl,*-TC-1
	aci	"if  "
	use	utl
	equ	T55,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 56
	use	utc
	set	Tsl,*-TC-1
	aci	"ex  "
	use	utl
	equ	T56,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 57
	use	utc
	set	Tsl,*-TC-1
	aci	"ag  "
	use	utl
	equ	T57,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 58
	use	utc
	set	Tsl,*-TC-1
	aci	"cs  "
	use	utl
	equ	T58,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 59
	use	utc
	set	Tsl,*-TC-1
	aci	"<set"
	aci	">   "
	use	utl
	equ	T59,*-TL
	zero	Tsl*4+1,5
"
" TERMINAL 60
	use	utc
	set	Tsl,*-TC-1
	aci	"pn  "
	use	utl
	equ	T60,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 61
	use	utc
	set	Tsl,*-TC-1
	aci	"p[  "
	use	utl
	equ	T61,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 62
	use	utc
	set	Tsl,*-TC-1
	aci	"fmx "
	use	utl
	equ	T62,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 63
	use	utc
	set	Tsl,*-TC-1
	aci	"fmn "
	use	utl
	equ	T63,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 64
	use	utc
	set	Tsl,*-TC-1
	aci	"frs "
	use	utl
	equ	T64,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 65
	use	utc
	set	Tsl,*-TC-1
	aci	"||  "
	use	utl
	equ	T65,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 66
	use	utc
	set	Tsl,*-TC-1
	aci	"<var"
	aci	">   "
	use	utl
	equ	T66,*-TL
	zero	Tsl*4+1,5
"
" TERMINAL 67
	use	utc
	set	Tsl,*-TC-1
	aci	"d   "
	use	utl
	equ	T67,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 68
	use	utc
	set	Tsl,*-TC-1
	aci	"mct "
	use	utl
	equ	T68,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 69
	use	utc
	set	Tsl,*-TC-1
	aci	"emt "
	use	utl
	equ	T69,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 70
	use	utc
	set	Tsl,*-TC-1
	aci	"emc "
	use	utl
	equ	T70,*-TL
	zero	Tsl*4+1,3
"
" TERMINAL 71
	use	utc
	set	Tsl,*-TC-1
	aci	"<u+>"
	use	utl
	equ	T71,*-TL
	zero	Tsl*4+1,4
"
" TERMINAL 72
	use	utc
	set	Tsl,*-TC-1
	aci	"<u->"
	use	utl
	equ	T72,*-TL
	zero	Tsl*4+1,4
"
	use	utc
	equ	TCs,"-TC-1
	use	utl
	equ	TLs,*-TL-1

	use	text
"
"
" DPDA table
DPDA:	zero	0,DPDAs
	segdef	DPDA
"
" STATE 1
	equ	ST1,*-DPDA
	zero	STRD,LN1
	zero	T5,ST14	"{
	zero	T56,ST65	"ex
	equ	LN1,*-DPDA-ST1-1
"
" STATE 4
	equ	ST4,*-DPDA
	zero	APLY1,LN4
	zero	0,0   pd ld
	zero	2,1   rule/alt
	zero	1,ST12 prod/val
	equ	LN4,*-DPDA-ST4-1
"
" STATE 8
	equ	ST8,*-DPDA
	zero	APLY1,LN8
	zero	0,0   pd ld
	zero	-1,1   rule/alt
	zero	1,ST12 prod/val
	equ	LN8,*-DPDA-ST8-1
"
" STATE 12
	equ	ST12,*-DPDA
	zero	STRD,LN12
	zero	T0,ST0	"EOI
	equ	LN12,*-DPDA-ST12-1
"
" STATE 14
	equ	ST14,*-DPDA
	zero	STRD,LN14
	zero	T1,ST385	"<integer>
	zero	T2,ST389	"<string>
	zero	T6,ST453	"}
	zero	T7,ST457	"(
	zero	T23,ST503	"a[
	zero	T24,ST504	"k[
	zero	T25,ST505	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T35,ST538	"da
	zero	T36,ST540	"dk
	zero	T37,ST542	"dK
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T66,ST615	"<var>
	zero	T67,ST679	"d
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN14,*-DPDA-ST14-1
"
" STATE 65
	equ	ST65,*-DPDA
	zero	STRD,LN65
	zero	T7,ST732	"(
	equ	LN65,*-DPDA-ST65-1
"
" STATE 67
	equ	ST67,*-DPDA
	zero	STRD,LN67
	zero	T7,ST733	"(
	equ	LN67,*-DPDA-ST67-1
"
" STATE 69
	equ	ST69,*-DPDA
	zero	STRD,LN69
	zero	T7,ST734	"(
	equ	LN69,*-DPDA-ST69-1
"
" STATE 71
	equ	ST71,*-DPDA
	zero	APLY,LN71
	zero	0,0   pd ld
	zero	-61,1   rule/alt
	zero	16,ST78 prod/val
	zero	ST735,ST1387
	zero	ST736,ST1391
	zero	ST737,ST1395
	equ	LN71,*-DPDA-ST71-1
"
" STATE 78
	equ	ST78,*-DPDA
	zero	APLY,LN78
	zero	0,0   pd ld
	zero	-60,1   rule/alt
	zero	15,ST84 prod/val
	zero	ST738,ST1399
	zero	ST739,ST1464
	equ	LN78,*-DPDA-ST78-1
"
" STATE 84
	equ	ST84,*-DPDA
	zero	NSRD,LN84
	zero	T1,-ST3908	"<integer>
	zero	T2,-ST3908	"<string>
	zero	T3,-ST3908	"]
	zero	T4,-ST3908	",
	zero	T6,-ST3908	"}
	zero	T7,-ST3908	"(
	zero	T8,-ST3908	")
	zero	T9,-ST3908	":
	zero	T10,-ST3908	".
	zero	T12,-ST3904	"*
	zero	T13,-ST3904	"/
	zero	T14,-ST3904	"|
	zero	T15,-ST3908	"+
	zero	T16,-ST3908	"-
	zero	T17,-ST3908	"<
	zero	T18,-ST3908	">
	zero	T19,-ST3908	"=
	zero	T20,-ST3908	"<=
	zero	T21,-ST3908	">=
	zero	T22,-ST3908	"^=
	zero	T23,-ST3908	"a[
	zero	T24,-ST3908	"k[
	zero	T25,-ST3908	"K[
	zero	T26,-ST3908	"Ks
	zero	T27,-ST3908	"be
	zero	T28,-ST3908	"bn
	zero	T29,-ST3908	"fl
	zero	T30,-ST3908	"fs
	zero	T31,-ST3908	"lb
	zero	T32,-ST3908	"le
	zero	T33,-ST3908	"sb
	zero	T34,-ST3908	"se
	zero	T38,-ST3908	"dn
	zero	T39,-ST3908	"en
	zero	T40,-ST3908	"sn
	zero	T41,-ST3908	"fak
	zero	T42,-ST3908	"fka
	zero	T43,-ST3908	"em
	zero	T44,-ST3908	"fi
	zero	T45,-ST3908	"fir
	zero	T46,-ST3908	"fv
	zero	T47,-ST3908	"fvr
	zero	T48,-ST3908	"ff
	zero	T49,-ST3908	"ffr
	zero	T50,-ST3908	"fln
	zero	T51,-ST3908	"sk
	zero	T52,-ST3908	"J
	zero	T53,-ST3908	"Kl
	zero	T54,-ST3908	"Kb
	zero	T55,-ST3908	"if
	zero	T57,-ST3908	"ag
	zero	T58,-ST3908	"cs
	zero	T60,-ST3908	"pn
	zero	T61,-ST3908	"p[
	zero	T62,-ST3908	"fmx
	zero	T63,-ST3908	"fmn
	zero	T64,-ST3908	"frs
	zero	T65,-ST3908	"||
	zero	T66,-ST3908	"<var>
	zero	T68,-ST3908	"mct
	zero	T69,-ST3908	"emt
	zero	T70,-ST3908	"emc
	zero	T71,-ST3908	"<u+>
	zero	T72,-ST3908	"<u->
	equ	LN84,*-DPDA-ST84-1
"
" STATE 149
	equ	ST149,*-DPDA
	zero	NSRD,LN149
	zero	T1,-ST3962	"<integer>
	zero	T2,-ST3962	"<string>
	zero	T3,-ST3962	"]
	zero	T4,-ST3962	",
	zero	T6,-ST3962	"}
	zero	T7,-ST3962	"(
	zero	T8,-ST3962	")
	zero	T9,-ST3962	":
	zero	T10,-ST3962	".
	zero	T15,-ST3959	"+
	zero	T16,-ST3959	"-
	zero	T17,-ST3962	"<
	zero	T18,-ST3962	">
	zero	T19,-ST3962	"=
	zero	T20,-ST3962	"<=
	zero	T21,-ST3962	">=
	zero	T22,-ST3962	"^=
	zero	T23,-ST3962	"a[
	zero	T24,-ST3962	"k[
	zero	T25,-ST3962	"K[
	zero	T26,-ST3962	"Ks
	zero	T27,-ST3962	"be
	zero	T28,-ST3962	"bn
	zero	T29,-ST3962	"fl
	zero	T30,-ST3962	"fs
	zero	T31,-ST3962	"lb
	zero	T32,-ST3962	"le
	zero	T33,-ST3962	"sb
	zero	T34,-ST3962	"se
	zero	T38,-ST3962	"dn
	zero	T39,-ST3962	"en
	zero	T40,-ST3962	"sn
	zero	T41,-ST3962	"fak
	zero	T42,-ST3962	"fka
	zero	T43,-ST3962	"em
	zero	T44,-ST3962	"fi
	zero	T45,-ST3962	"fir
	zero	T46,-ST3962	"fv
	zero	T47,-ST3962	"fvr
	zero	T48,-ST3962	"ff
	zero	T49,-ST3962	"ffr
	zero	T50,-ST3962	"fln
	zero	T51,-ST3962	"sk
	zero	T52,-ST3962	"J
	zero	T53,-ST3962	"Kl
	zero	T54,-ST3962	"Kb
	zero	T55,-ST3962	"if
	zero	T57,-ST3962	"ag
	zero	T58,-ST3962	"cs
	zero	T60,-ST3962	"pn
	zero	T61,-ST3962	"p[
	zero	T62,-ST3962	"fmx
	zero	T63,-ST3962	"fmn
	zero	T64,-ST3962	"frs
	zero	T65,-ST3962	"||
	zero	T66,-ST3962	"<var>
	zero	T68,-ST3962	"mct
	zero	T69,-ST3962	"emt
	zero	T70,-ST3962	"emc
	zero	T71,-ST3962	"<u+>
	zero	T72,-ST3962	"<u->
	equ	LN149,*-DPDA-ST149-1
"
" STATE 211
	equ	ST211,*-DPDA
	zero	NSRD,LN211
	zero	T6,-ST4015	"}
	zero	T9,-ST4012	":
	zero	T10,-ST4012	".
	equ	LN211,*-DPDA-ST211-1
"
" STATE 215
	equ	ST215,*-DPDA
	zero	NSRD,LN215
	zero	T1,-ST4020	"<integer>
	zero	T2,-ST4020	"<string>
	zero	T6,-ST4076	"}
	zero	T7,-ST4020	"(
	zero	T9,-ST4020	":
	zero	T10,-ST4020	".
	zero	T17,-ST4020	"<
	zero	T18,-ST4020	">
	zero	T19,-ST4020	"=
	zero	T20,-ST4020	"<=
	zero	T21,-ST4020	">=
	zero	T22,-ST4020	"^=
	zero	T23,-ST4020	"a[
	zero	T24,-ST4020	"k[
	zero	T25,-ST4020	"K[
	zero	T26,-ST4020	"Ks
	zero	T27,-ST4020	"be
	zero	T28,-ST4020	"bn
	zero	T29,-ST4020	"fl
	zero	T30,-ST4020	"fs
	zero	T31,-ST4020	"lb
	zero	T32,-ST4020	"le
	zero	T33,-ST4020	"sb
	zero	T34,-ST4020	"se
	zero	T38,-ST4020	"dn
	zero	T39,-ST4020	"en
	zero	T40,-ST4020	"sn
	zero	T41,-ST4020	"fak
	zero	T42,-ST4020	"fka
	zero	T43,-ST4020	"em
	zero	T44,-ST4020	"fi
	zero	T45,-ST4020	"fir
	zero	T46,-ST4020	"fv
	zero	T47,-ST4020	"fvr
	zero	T48,-ST4020	"ff
	zero	T49,-ST4020	"ffr
	zero	T50,-ST4020	"fln
	zero	T51,-ST4020	"sk
	zero	T52,-ST4020	"J
	zero	T53,-ST4020	"Kl
	zero	T54,-ST4020	"Kb
	zero	T55,-ST4020	"if
	zero	T57,-ST4020	"ag
	zero	T58,-ST4020	"cs
	zero	T60,-ST4020	"pn
	zero	T61,-ST4020	"p[
	zero	T62,-ST4020	"fmx
	zero	T63,-ST4020	"fmn
	zero	T64,-ST4020	"frs
	zero	T65,-ST4020	"||
	zero	T66,-ST4020	"<var>
	zero	T68,-ST4020	"mct
	zero	T69,-ST4020	"emt
	zero	T70,-ST4020	"emc
	zero	T71,-ST4020	"<u+>
	zero	T72,-ST4020	"<u->
	equ	LN215,*-DPDA-ST215-1
"
" STATE 272
	equ	ST272,*-DPDA
	zero	APLY,LN272
	zero	0,0   pd ld
	zero	-64,1   rule/alt
	zero	17,ST71 prod/val
	zero	ST687,ST1276
	zero	ST731,ST1280
	equ	LN272,*-DPDA-ST272-1
"
" STATE 278
	equ	ST278,*-DPDA
	zero	STRD,LN278
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN278,*-DPDA-ST278-1
"
" STATE 324
	equ	ST324,*-DPDA
	zero	STRDS,ST278

"
" STATE 325
	equ	ST325,*-DPDA
	zero	NSRD,LN325
	zero	T6,-ST4082	"}
	zero	T10,-ST4080	".
	equ	LN325,*-DPDA-ST325-1
"
" STATE 328
	equ	ST328,*-DPDA
	zero	STRD,LN328
	zero	T6,ST968	"}
	equ	LN328,*-DPDA-ST328-1
"
" STATE 330
	equ	ST330,*-DPDA
	zero	APLY1,LN330
	zero	0,0   pd ld
	zero	-8,1   rule/alt
	zero	3,ST334 prod/val
	equ	LN330,*-DPDA-ST330-1
"
" STATE 334
	equ	ST334,*-DPDA
	zero	STRD,LN334
	zero	T1,ST385	"<integer>
	zero	T2,ST389	"<string>
	zero	T6,ST978	"}
	zero	T7,ST457	"(
	zero	T23,ST503	"a[
	zero	T24,ST504	"k[
	zero	T25,ST505	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T35,ST538	"da
	zero	T36,ST540	"dk
	zero	T37,ST542	"dK
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T66,ST615	"<var>
	zero	T67,ST679	"d
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN334,*-DPDA-ST334-1
"
" STATE 385
	equ	ST385,*-DPDA
	zero	APLY1,LN385
	zero	0,0   pd ld
	zero	68,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN385,*-DPDA-ST385-1
"
" STATE 389
	equ	ST389,*-DPDA
	zero	NSRD,LN389
	zero	T1,-ST812	"<integer>
	zero	T2,-ST812	"<string>
	zero	T6,-ST812	"}
	zero	T7,-ST812	"(
	zero	T8,-ST812	")
	zero	T9,-ST812	":
	zero	T10,-ST812	".
	zero	T11,-ST4086	":=
	zero	T12,-ST812	"*
	zero	T13,-ST812	"/
	zero	T14,-ST812	"|
	zero	T15,-ST812	"+
	zero	T16,-ST812	"-
	zero	T17,-ST812	"<
	zero	T18,-ST812	">
	zero	T19,-ST812	"=
	zero	T20,-ST812	"<=
	zero	T21,-ST812	">=
	zero	T22,-ST812	"^=
	zero	T23,-ST812	"a[
	zero	T24,-ST812	"k[
	zero	T25,-ST812	"K[
	zero	T26,-ST812	"Ks
	zero	T27,-ST812	"be
	zero	T28,-ST812	"bn
	zero	T29,-ST812	"fl
	zero	T30,-ST812	"fs
	zero	T31,-ST812	"lb
	zero	T32,-ST812	"le
	zero	T33,-ST812	"sb
	zero	T34,-ST812	"se
	zero	T38,-ST812	"dn
	zero	T39,-ST812	"en
	zero	T40,-ST812	"sn
	zero	T41,-ST812	"fak
	zero	T42,-ST812	"fka
	zero	T43,-ST812	"em
	zero	T44,-ST812	"fi
	zero	T45,-ST812	"fir
	zero	T46,-ST812	"fv
	zero	T47,-ST812	"fvr
	zero	T48,-ST812	"ff
	zero	T49,-ST812	"ffr
	zero	T50,-ST812	"fln
	zero	T51,-ST812	"sk
	zero	T52,-ST812	"J
	zero	T53,-ST812	"Kl
	zero	T54,-ST812	"Kb
	zero	T55,-ST812	"if
	zero	T57,-ST812	"ag
	zero	T58,-ST812	"cs
	zero	T60,-ST812	"pn
	zero	T61,-ST812	"p[
	zero	T62,-ST812	"fmx
	zero	T63,-ST812	"fmn
	zero	T64,-ST812	"frs
	zero	T65,-ST812	"||
	zero	T66,-ST812	"<var>
	zero	T68,-ST812	"mct
	zero	T69,-ST812	"emt
	zero	T70,-ST812	"emc
	zero	T71,-ST812	"<u+>
	zero	T72,-ST812	"<u->
	equ	LN389,*-DPDA-ST389-1
"
" STATE 453
	equ	ST453,*-DPDA
	zero	APLY1,LN453
	zero	1,1   pd ld
	zero	6,1   rule/alt
	zero	2,ST8 prod/val
	equ	LN453,*-DPDA-ST453-1
"
" STATE 457
	equ	ST457,*-DPDA
	zero	STRD,LN457
	zero	T1,ST385	"<integer>
	zero	T2,ST389	"<string>
	zero	T7,ST457	"(
	zero	T23,ST503	"a[
	zero	T24,ST504	"k[
	zero	T25,ST505	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T66,ST615	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN457,*-DPDA-ST457-1
"
" STATE 503
	equ	ST503,*-DPDA
	zero	STRDS,ST278

"
" STATE 504
	equ	ST504,*-DPDA
	zero	STRDS,ST278

"
" STATE 505
	equ	ST505,*-DPDA
	zero	STRDS,ST278

"
" STATE 506
	equ	ST506,*-DPDA
	zero	APLY1,LN506
	zero	0,0   pd ld
	zero	28,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN506,*-DPDA-ST506-1
"
" STATE 510
	equ	ST510,*-DPDA
	zero	APLY1,LN510
	zero	0,0   pd ld
	zero	76,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN510,*-DPDA-ST510-1
"
" STATE 514
	equ	ST514,*-DPDA
	zero	APLY1,LN514
	zero	0,0   pd ld
	zero	39,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN514,*-DPDA-ST514-1
"
" STATE 518
	equ	ST518,*-DPDA
	zero	STRD,LN518
	zero	T7,ST1189	"(
	equ	LN518,*-DPDA-ST518-1
"
" STATE 520
	equ	ST520,*-DPDA
	zero	STRD,LN520
	zero	T7,ST1190	"(
	equ	LN520,*-DPDA-ST520-1
"
" STATE 522
	equ	ST522,*-DPDA
	zero	APLY1,LN522
	zero	0,0   pd ld
	zero	72,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN522,*-DPDA-ST522-1
"
" STATE 526
	equ	ST526,*-DPDA
	zero	APLY1,LN526
	zero	0,0   pd ld
	zero	75,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN526,*-DPDA-ST526-1
"
" STATE 530
	equ	ST530,*-DPDA
	zero	APLY1,LN530
	zero	0,0   pd ld
	zero	73,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN530,*-DPDA-ST530-1
"
" STATE 534
	equ	ST534,*-DPDA
	zero	APLY1,LN534
	zero	0,0   pd ld
	zero	74,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN534,*-DPDA-ST534-1
"
" STATE 538
	equ	ST538,*-DPDA
	zero	STRD,LN538
	zero	T10,ST1191	".
	equ	LN538,*-DPDA-ST538-1
"
" STATE 540
	equ	ST540,*-DPDA
	zero	STRD,LN540
	zero	T10,ST1195	".
	equ	LN540,*-DPDA-ST540-1
"
" STATE 542
	equ	ST542,*-DPDA
	zero	STRD,LN542
	zero	T10,ST1199	".
	equ	LN542,*-DPDA-ST542-1
"
" STATE 544
	equ	ST544,*-DPDA
	zero	APLY1,LN544
	zero	0,0   pd ld
	zero	40,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN544,*-DPDA-ST544-1
"
" STATE 548
	equ	ST548,*-DPDA
	zero	APLY1,LN548
	zero	0,0   pd ld
	zero	41,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN548,*-DPDA-ST548-1
"
" STATE 552
	equ	ST552,*-DPDA
	zero	APLY1,LN552
	zero	0,0   pd ld
	zero	42,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN552,*-DPDA-ST552-1
"
" STATE 556
	equ	ST556,*-DPDA
	zero	STRD,LN556
	zero	T7,ST1203	"(
	equ	LN556,*-DPDA-ST556-1
"
" STATE 558
	equ	ST558,*-DPDA
	zero	STRD,LN558
	zero	T7,ST1204	"(
	equ	LN558,*-DPDA-ST558-1
"
" STATE 560
	equ	ST560,*-DPDA
	zero	APLY1,LN560
	zero	0,0   pd ld
	zero	44,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN560,*-DPDA-ST560-1
"
" STATE 564
	equ	ST564,*-DPDA
	zero	STRD,LN564
	zero	T7,ST1205	"(
	equ	LN564,*-DPDA-ST564-1
"
" STATE 566
	equ	ST566,*-DPDA
	zero	STRD,LN566
	zero	T7,ST1206	"(
	equ	LN566,*-DPDA-ST566-1
"
" STATE 568
	equ	ST568,*-DPDA
	zero	STRD,LN568
	zero	T7,ST1207	"(
	equ	LN568,*-DPDA-ST568-1
"
" STATE 570
	equ	ST570,*-DPDA
	zero	STRD,LN570
	zero	T7,ST1208	"(
	equ	LN570,*-DPDA-ST570-1
"
" STATE 572
	equ	ST572,*-DPDA
	zero	STRD,LN572
	zero	T7,ST1209	"(
	equ	LN572,*-DPDA-ST572-1
"
" STATE 574
	equ	ST574,*-DPDA
	zero	STRD,LN574
	zero	T7,ST1210	"(
	equ	LN574,*-DPDA-ST574-1
"
" STATE 576
	equ	ST576,*-DPDA
	zero	STRD,LN576
	zero	T7,ST1211	"(
	equ	LN576,*-DPDA-ST576-1
"
" STATE 578
	equ	ST578,*-DPDA
	zero	APLY1,LN578
	zero	0,0   pd ld
	zero	43,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN578,*-DPDA-ST578-1
"
" STATE 582
	equ	ST582,*-DPDA
	zero	APLY1,LN582
	zero	0,0   pd ld
	zero	29,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN582,*-DPDA-ST582-1
"
" STATE 586
	equ	ST586,*-DPDA
	zero	APLY1,LN586
	zero	0,0   pd ld
	zero	30,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN586,*-DPDA-ST586-1
"
" STATE 590
	equ	ST590,*-DPDA
	zero	STRD,LN590
	zero	T7,ST1215	"(
	equ	LN590,*-DPDA-ST590-1
"
" STATE 592
	equ	ST592,*-DPDA
	zero	APLY1,LN592
	zero	0,0   pd ld
	zero	70,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN592,*-DPDA-ST592-1
"
" STATE 596
	equ	ST596,*-DPDA
	zero	APLY1,LN596
	zero	0,0   pd ld
	zero	31,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN596,*-DPDA-ST596-1
"
" STATE 600
	equ	ST600,*-DPDA
	zero	APLY1,LN600
	zero	0,0   pd ld
	zero	69,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN600,*-DPDA-ST600-1
"
" STATE 604
	equ	ST604,*-DPDA
	zero	STRDS,ST278

"
" STATE 605
	equ	ST605,*-DPDA
	zero	APLY1,LN605
	zero	0,0   pd ld
	zero	77,1   rule/alt
	zero	18,ST69 prod/val
	equ	LN605,*-DPDA-ST605-1
"
" STATE 609
	equ	ST609,*-DPDA
	zero	APLY1,LN609
	zero	0,0   pd ld
	zero	78,1   rule/alt
	zero	19,ST67 prod/val
	equ	LN609,*-DPDA-ST609-1
"
" STATE 613
	equ	ST613,*-DPDA
	zero	STRD,LN613
	zero	T7,ST1264	"(
	equ	LN613,*-DPDA-ST613-1
"
" STATE 615
	equ	ST615,*-DPDA
	zero	NSRD,LN615
	zero	T1,-ST860	"<integer>
	zero	T2,-ST860	"<string>
	zero	T6,-ST860	"}
	zero	T7,-ST860	"(
	zero	T8,-ST860	")
	zero	T9,-ST860	":
	zero	T10,-ST860	".
	zero	T11,-ST4088	":=
	zero	T12,-ST860	"*
	zero	T13,-ST860	"/
	zero	T14,-ST860	"|
	zero	T15,-ST860	"+
	zero	T16,-ST860	"-
	zero	T17,-ST860	"<
	zero	T18,-ST860	">
	zero	T19,-ST860	"=
	zero	T20,-ST860	"<=
	zero	T21,-ST860	">=
	zero	T22,-ST860	"^=
	zero	T23,-ST860	"a[
	zero	T24,-ST860	"k[
	zero	T25,-ST860	"K[
	zero	T26,-ST860	"Ks
	zero	T27,-ST860	"be
	zero	T28,-ST860	"bn
	zero	T29,-ST860	"fl
	zero	T30,-ST860	"fs
	zero	T31,-ST860	"lb
	zero	T32,-ST860	"le
	zero	T33,-ST860	"sb
	zero	T34,-ST860	"se
	zero	T38,-ST860	"dn
	zero	T39,-ST860	"en
	zero	T40,-ST860	"sn
	zero	T41,-ST860	"fak
	zero	T42,-ST860	"fka
	zero	T43,-ST860	"em
	zero	T44,-ST860	"fi
	zero	T45,-ST860	"fir
	zero	T46,-ST860	"fv
	zero	T47,-ST860	"fvr
	zero	T48,-ST860	"ff
	zero	T49,-ST860	"ffr
	zero	T50,-ST860	"fln
	zero	T51,-ST860	"sk
	zero	T52,-ST860	"J
	zero	T53,-ST860	"Kl
	zero	T54,-ST860	"Kb
	zero	T55,-ST860	"if
	zero	T57,-ST860	"ag
	zero	T58,-ST860	"cs
	zero	T60,-ST860	"pn
	zero	T61,-ST860	"p[
	zero	T62,-ST860	"fmx
	zero	T63,-ST860	"fmn
	zero	T64,-ST860	"frs
	zero	T65,-ST860	"||
	zero	T66,-ST860	"<var>
	zero	T68,-ST860	"mct
	zero	T69,-ST860	"emt
	zero	T70,-ST860	"emc
	zero	T71,-ST860	"<u+>
	zero	T72,-ST860	"<u->
	equ	LN615,*-DPDA-ST615-1
"
" STATE 679
	equ	ST679,*-DPDA
	zero	STRD,LN679
	zero	T7,ST1269	"(
	equ	LN679,*-DPDA-ST679-1
"
" STATE 681
	equ	ST681,*-DPDA
	zero	STRD,LN681
	zero	T7,ST1270	"(
	equ	LN681,*-DPDA-ST681-1
"
" STATE 683
	equ	ST683,*-DPDA
	zero	STRD,LN683
	zero	T7,ST1272	"(
	equ	LN683,*-DPDA-ST683-1
"
" STATE 685
	equ	ST685,*-DPDA
	zero	STRD,LN685
	zero	T7,ST1274	"(
	equ	LN685,*-DPDA-ST685-1
"
" STATE 687
	equ	ST687,*-DPDA
	zero	STRD,LN687
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	equ	LN687,*-DPDA-ST687-1
"
" STATE 731
	equ	ST731,*-DPDA
	zero	STRDS,ST687

"
" STATE 732
	equ	ST732,*-DPDA
	zero	STRDS,ST278

"
" STATE 733
	equ	ST733,*-DPDA
	zero	STRDS,ST278

"
" STATE 734
	equ	ST734,*-DPDA
	zero	STRDS,ST278

"
" STATE 735
	equ	ST735,*-DPDA
	zero	STRDS,ST278

"
" STATE 736
	equ	ST736,*-DPDA
	zero	STRDS,ST278

"
" STATE 737
	equ	ST737,*-DPDA
	zero	STRDS,ST278

"
" STATE 738
	equ	ST738,*-DPDA
	zero	STRDS,ST278

"
" STATE 739
	equ	ST739,*-DPDA
	zero	STRDS,ST278

"
" STATE 740
	equ	ST740,*-DPDA
	zero	APLY,LN740
	zero	1,1   pd ld
	zero	9,2   rule/alt
	zero	4,ST330 prod/val
	zero	ST334,ST974
	equ	LN740,*-DPDA-ST740-1
"
" STATE 745
	equ	ST745,*-DPDA
	zero	APLYS,LN745
	zero	1,1   pd ld
	zero	10,2   rule/alt
	zero	4,ST740 prod/val
	equ	LN745,*-DPDA-ST745-1
"
" STATE 749
	equ	ST749,*-DPDA
	zero	NSRD,LN749
	zero	T1,-ST4091	"<integer>
	zero	T2,-ST4091	"<string>
	zero	T3,-ST4091	"]
	zero	T4,-ST4091	",
	zero	T6,-ST4091	"}
	zero	T7,-ST4091	"(
	zero	T8,-ST4091	")
	zero	T9,-ST4091	":
	zero	T10,-ST4091	".
	zero	T15,-ST4090	"+
	zero	T16,-ST4090	"-
	zero	T17,-ST4091	"<
	zero	T18,-ST4091	">
	zero	T19,-ST4091	"=
	zero	T20,-ST4091	"<=
	zero	T21,-ST4091	">=
	zero	T22,-ST4091	"^=
	zero	T23,-ST4091	"a[
	zero	T24,-ST4091	"k[
	zero	T25,-ST4091	"K[
	zero	T26,-ST4091	"Ks
	zero	T27,-ST4091	"be
	zero	T28,-ST4091	"bn
	zero	T29,-ST4091	"fl
	zero	T30,-ST4091	"fs
	zero	T31,-ST4091	"lb
	zero	T32,-ST4091	"le
	zero	T33,-ST4091	"sb
	zero	T34,-ST4091	"se
	zero	T38,-ST4091	"dn
	zero	T39,-ST4091	"en
	zero	T40,-ST4091	"sn
	zero	T41,-ST4091	"fak
	zero	T42,-ST4091	"fka
	zero	T43,-ST4091	"em
	zero	T44,-ST4091	"fi
	zero	T45,-ST4091	"fir
	zero	T46,-ST4091	"fv
	zero	T47,-ST4091	"fvr
	zero	T48,-ST4091	"ff
	zero	T49,-ST4091	"ffr
	zero	T50,-ST4091	"fln
	zero	T51,-ST4091	"sk
	zero	T52,-ST4091	"J
	zero	T53,-ST4091	"Kl
	zero	T54,-ST4091	"Kb
	zero	T55,-ST4091	"if
	zero	T57,-ST4091	"ag
	zero	T58,-ST4091	"cs
	zero	T60,-ST4091	"pn
	zero	T61,-ST4091	"p[
	zero	T62,-ST4091	"fmx
	zero	T63,-ST4091	"fmn
	zero	T64,-ST4091	"frs
	zero	T65,-ST4091	"||
	zero	T66,-ST4091	"<var>
	zero	T68,-ST4091	"mct
	zero	T69,-ST4091	"emt
	zero	T70,-ST4091	"emc
	zero	T71,-ST4091	"<u+>
	zero	T72,-ST4091	"<u->
	equ	LN749,*-DPDA-ST749-1
"
" STATE 811
	equ	ST811,*-DPDA
	zero	STRDS,ST278

"
" STATE 812
	equ	ST812,*-DPDA
	zero	APLY1,LN812
	zero	0,0   pd ld
	zero	32,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN812,*-DPDA-ST812-1
"
" STATE 816
	equ	ST816,*-DPDA
	zero	APLYS,LN816
	zero	1,1   pd ld
	zero	9,1   rule/alt
	zero	4,ST740 prod/val
	equ	LN816,*-DPDA-ST816-1
"
" STATE 820
	equ	ST820,*-DPDA
	zero	APLYS,LN820
	zero	1,1   pd ld
	zero	10,1   rule/alt
	zero	4,ST740 prod/val
	equ	LN820,*-DPDA-ST820-1
"
" STATE 824
	equ	ST824,*-DPDA
	zero	APLY,LN824
	zero	0,0   pd ld
	zero	53,5   rule/alt
	zero	13,ST811 prod/val
	zero	ST852,ST1725
	equ	LN824,*-DPDA-ST824-1
"
" STATE 829
	equ	ST829,*-DPDA
	zero	APLYS,LN829
	zero	0,0   pd ld
	zero	53,6   rule/alt
	zero	13,ST824 prod/val
	equ	LN829,*-DPDA-ST829-1
"
" STATE 833
	equ	ST833,*-DPDA
	zero	APLYS,LN833
	zero	0,0   pd ld
	zero	53,1   rule/alt
	zero	13,ST824 prod/val
	equ	LN833,*-DPDA-ST833-1
"
" STATE 837
	equ	ST837,*-DPDA
	zero	APLYS,LN837
	zero	0,0   pd ld
	zero	53,4   rule/alt
	zero	13,ST824 prod/val
	equ	LN837,*-DPDA-ST837-1
"
" STATE 841
	equ	ST841,*-DPDA
	zero	APLYS,LN841
	zero	0,0   pd ld
	zero	53,3   rule/alt
	zero	13,ST824 prod/val
	equ	LN841,*-DPDA-ST841-1
"
" STATE 845
	equ	ST845,*-DPDA
	zero	APLYS,LN845
	zero	0,0   pd ld
	zero	53,2   rule/alt
	zero	13,ST824 prod/val
	equ	LN845,*-DPDA-ST845-1
"
" STATE 849
	equ	ST849,*-DPDA
	zero	STRDS,ST278

"
" STATE 850
	equ	ST850,*-DPDA
	zero	STRDS,ST278

"
" STATE 851
	equ	ST851,*-DPDA
	zero	STRDS,ST278

"
" STATE 852
	equ	ST852,*-DPDA
	zero	STRD,LN852
	zero	T17,ST824	"<
	zero	T18,ST829	">
	zero	T19,ST833	"=
	zero	T20,ST837	"<=
	zero	T21,ST841	">=
	zero	T22,ST845	"^=
	equ	LN852,*-DPDA-ST852-1
"
" STATE 859
	equ	ST859,*-DPDA
	zero	STRDS,ST278

"
" STATE 860
	equ	ST860,*-DPDA
	zero	APLY1,LN860
	zero	0,0   pd ld
	zero	38,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN860,*-DPDA-ST860-1
"
" STATE 864
	equ	ST864,*-DPDA
	zero	NSRD,LN864
	zero	T1,-ST4095	"<integer>
	zero	T2,-ST4095	"<string>
	zero	T6,-ST4142	"}
	zero	T7,-ST4095	"(
	zero	T8,-ST4142	")
	zero	T10,-ST4142	".
	zero	T23,-ST4095	"a[
	zero	T24,-ST4095	"k[
	zero	T25,-ST4095	"K[
	zero	T26,-ST4095	"Ks
	zero	T27,-ST4095	"be
	zero	T28,-ST4095	"bn
	zero	T29,-ST4095	"fl
	zero	T30,-ST4095	"fs
	zero	T31,-ST4095	"lb
	zero	T32,-ST4095	"le
	zero	T33,-ST4095	"sb
	zero	T34,-ST4095	"se
	zero	T38,-ST4095	"dn
	zero	T39,-ST4095	"en
	zero	T40,-ST4095	"sn
	zero	T41,-ST4095	"fak
	zero	T42,-ST4095	"fka
	zero	T43,-ST4095	"em
	zero	T44,-ST4095	"fi
	zero	T45,-ST4095	"fir
	zero	T46,-ST4095	"fv
	zero	T47,-ST4095	"fvr
	zero	T48,-ST4095	"ff
	zero	T49,-ST4095	"ffr
	zero	T50,-ST4095	"fln
	zero	T51,-ST4095	"sk
	zero	T53,-ST4095	"Kl
	zero	T54,-ST4095	"Kb
	zero	T55,-ST4095	"if
	zero	T57,-ST4095	"ag
	zero	T58,-ST4095	"cs
	zero	T60,-ST4095	"pn
	zero	T61,-ST4095	"p[
	zero	T62,-ST4095	"fmx
	zero	T63,-ST4095	"fmn
	zero	T64,-ST4095	"frs
	zero	T65,-ST4095	"||
	zero	T66,-ST4095	"<var>
	zero	T68,-ST4095	"mct
	zero	T69,-ST4095	"emt
	zero	T70,-ST4095	"emc
	zero	T71,-ST4095	"<u+>
	zero	T72,-ST4095	"<u->
	equ	LN864,*-DPDA-ST864-1
"
" STATE 914
	equ	ST914,*-DPDA
	zero	NSRD,LN914
	zero	T1,-ST4147	"<integer>
	zero	T2,-ST4147	"<string>
	zero	T6,-ST4148	"}
	zero	T7,-ST4147	"(
	zero	T8,-ST4148	")
	zero	T10,-ST4148	".
	zero	T23,-ST4147	"a[
	zero	T24,-ST4147	"k[
	zero	T25,-ST4147	"K[
	zero	T26,-ST4147	"Ks
	zero	T27,-ST4147	"be
	zero	T28,-ST4147	"bn
	zero	T29,-ST4147	"fl
	zero	T30,-ST4147	"fs
	zero	T31,-ST4147	"lb
	zero	T32,-ST4147	"le
	zero	T33,-ST4147	"sb
	zero	T34,-ST4147	"se
	zero	T38,-ST4147	"dn
	zero	T39,-ST4147	"en
	zero	T40,-ST4147	"sn
	zero	T41,-ST4147	"fak
	zero	T42,-ST4147	"fka
	zero	T43,-ST4147	"em
	zero	T44,-ST4147	"fi
	zero	T45,-ST4147	"fir
	zero	T46,-ST4147	"fv
	zero	T47,-ST4147	"fvr
	zero	T48,-ST4147	"ff
	zero	T49,-ST4147	"ffr
	zero	T50,-ST4147	"fln
	zero	T51,-ST4147	"sk
	zero	T53,-ST4147	"Kl
	zero	T54,-ST4147	"Kb
	zero	T55,-ST4147	"if
	zero	T57,-ST4147	"ag
	zero	T58,-ST4147	"cs
	zero	T60,-ST4147	"pn
	zero	T61,-ST4147	"p[
	zero	T62,-ST4147	"fmx
	zero	T63,-ST4147	"fmn
	zero	T64,-ST4147	"frs
	zero	T65,-ST4147	"||
	zero	T66,-ST4147	"<var>
	zero	T68,-ST4147	"mct
	zero	T69,-ST4147	"emt
	zero	T70,-ST4147	"emc
	zero	T71,-ST4147	"<u+>
	zero	T72,-ST4147	"<u->
	equ	LN914,*-DPDA-ST914-1
"
" STATE 964
	equ	ST964,*-DPDA
	zero	APLYS,LN964
	zero	1,1   pd ld
	zero	12,1   rule/alt
	zero	4,ST740 prod/val
	equ	LN964,*-DPDA-ST964-1
"
" STATE 968
	equ	ST968,*-DPDA
	zero	APLY1,LN968
	zero	2,2   pd ld
	zero	4,1   rule/alt
	zero	2,ST8 prod/val
	equ	LN968,*-DPDA-ST968-1
"
" STATE 972
	equ	ST972,*-DPDA
	zero	STRD,LN972
	zero	T6,ST1788	"}
	equ	LN972,*-DPDA-ST972-1
"
" STATE 974
	equ	ST974,*-DPDA
	zero	APLY1,LN974
	zero	1,1   pd ld
	zero	-7,1   rule/alt
	zero	3,ST334 prod/val
	equ	LN974,*-DPDA-ST974-1
"
" STATE 978
	equ	ST978,*-DPDA
	zero	APLY1,LN978
	zero	2,2   pd ld
	zero	5,1   rule/alt
	zero	2,ST8 prod/val
	equ	LN978,*-DPDA-ST978-1
"
" STATE 982
	equ	ST982,*-DPDA
	zero	APLY1,LN982
	zero	1,1   pd ld
	zero	24,1   rule/alt
	zero	8,ST278 prod/val
	equ	LN982,*-DPDA-ST982-1
"
" STATE 986
	equ	ST986,*-DPDA
	zero	STRD,LN986
	zero	T8,ST1792	")
	equ	LN986,*-DPDA-ST986-1
"
" STATE 988
	equ	ST988,*-DPDA
	zero	STRD,LN988
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST1796	")
	zero	T17,ST824	"<
	zero	T18,ST829	">
	zero	T19,ST833	"=
	zero	T20,ST837	"<=
	zero	T21,ST841	">=
	zero	T22,ST845	"^=
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T52,ST852	"J
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN988,*-DPDA-ST988-1
"
" STATE 1043
	equ	ST1043,*-DPDA
	zero	STRD,LN1043
	zero	T8,ST1800	")
	equ	LN1043,*-DPDA-ST1043-1
"
" STATE 1045
	equ	ST1045,*-DPDA
	zero	STRD,LN1045
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T3,ST1804	"]
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN1045,*-DPDA-ST1045-1
"
" STATE 1093
	equ	ST1093,*-DPDA
	zero	STRD,LN1093
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T3,ST1868	"]
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN1093,*-DPDA-ST1093-1
"
" STATE 1141
	equ	ST1141,*-DPDA
	zero	STRD,LN1141
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T3,ST1932	"]
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN1141,*-DPDA-ST1141-1
"
" STATE 1189
	equ	ST1189,*-DPDA
	zero	STRDS,ST278

"
" STATE 1190
	equ	ST1190,*-DPDA
	zero	STRDS,ST278

"
" STATE 1191
	equ	ST1191,*-DPDA
	zero	APLYS,LN1191
	zero	1,1   pd ld
	zero	13,1   rule/alt
	zero	4,ST740 prod/val
	equ	LN1191,*-DPDA-ST1191-1
"
" STATE 1195
	equ	ST1195,*-DPDA
	zero	APLYS,LN1195
	zero	1,1   pd ld
	zero	14,1   rule/alt
	zero	4,ST740 prod/val
	equ	LN1195,*-DPDA-ST1195-1
"
" STATE 1199
	equ	ST1199,*-DPDA
	zero	APLYS,LN1199
	zero	1,1   pd ld
	zero	15,1   rule/alt
	zero	4,ST740 prod/val
	equ	LN1199,*-DPDA-ST1199-1
"
" STATE 1203
	equ	ST1203,*-DPDA
	zero	STRDS,ST278

"
" STATE 1204
	equ	ST1204,*-DPDA
	zero	STRDS,ST278

"
" STATE 1205
	equ	ST1205,*-DPDA
	zero	STRDS,ST278

"
" STATE 1206
	equ	ST1206,*-DPDA
	zero	STRDS,ST278

"
" STATE 1207
	equ	ST1207,*-DPDA
	zero	STRDS,ST278

"
" STATE 1208
	equ	ST1208,*-DPDA
	zero	STRDS,ST278

"
" STATE 1209
	equ	ST1209,*-DPDA
	zero	STRDS,ST278

"
" STATE 1210
	equ	ST1210,*-DPDA
	zero	STRDS,ST278

"
" STATE 1211
	equ	ST1211,*-DPDA
	zero	STRD,LN1211
	zero	T27,ST2476	"be
	zero	T31,ST2478	"lb
	zero	T32,ST2480	"le
	equ	LN1211,*-DPDA-ST1211-1
"
" STATE 1215
	equ	ST1215,*-DPDA
	zero	STRDS,ST278

"
" STATE 1216
	equ	ST1216,*-DPDA
	zero	STRD,LN1216
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T3,ST2538	"]
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN1216,*-DPDA-ST1216-1
"
" STATE 1264
	equ	ST1264,*-DPDA
	zero	STRDS,ST278

"
" STATE 1265
	equ	ST1265,*-DPDA
	zero	APLY1,LN1265
	zero	1,1   pd ld
	zero	23,1   rule/alt
	zero	7,ST324 prod/val
	equ	LN1265,*-DPDA-ST1265-1
"
" STATE 1269
	equ	ST1269,*-DPDA
	zero	STRDS,ST278

"
" STATE 1270
	equ	ST1270,*-DPDA
	zero	STRD,LN1270
	zero	T8,ST2638	")
	equ	LN1270,*-DPDA-ST1270-1
"
" STATE 1272
	equ	ST1272,*-DPDA
	zero	STRD,LN1272
	zero	T8,ST2642	")
	equ	LN1272,*-DPDA-ST1272-1
"
" STATE 1274
	equ	ST1274,*-DPDA
	zero	STRD,LN1274
	zero	T8,ST2646	")
	equ	LN1274,*-DPDA-ST1274-1
"
" STATE 1276
	equ	ST1276,*-DPDA
	zero	APLYS,LN1276
	zero	1,1   pd ld
	zero	62,1   rule/alt
	zero	16,ST71 prod/val
	equ	LN1276,*-DPDA-ST1276-1
"
" STATE 1280
	equ	ST1280,*-DPDA
	zero	APLYS,LN1280
	zero	1,1   pd ld
	zero	63,1   rule/alt
	zero	16,ST71 prod/val
	equ	LN1280,*-DPDA-ST1280-1
"
" STATE 1284
	equ	ST1284,*-DPDA
	zero	STRD,LN1284
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST2650	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN1284,*-DPDA-ST1284-1
"
" STATE 1332
	equ	ST1332,*-DPDA
	zero	STRD,LN1332
	zero	T4,ST2654	",
	zero	T8,ST2655	")
	equ	LN1332,*-DPDA-ST1332-1
"
" STATE 1335
	equ	ST1335,*-DPDA
	zero	NSRD,LN1335
	zero	T1,-ST4152	"<integer>
	zero	T2,-ST4152	"<string>
	zero	T4,-ST4153	",
	zero	T7,-ST4152	"(
	zero	T8,-ST4153	")
	zero	T23,-ST4152	"a[
	zero	T24,-ST4152	"k[
	zero	T25,-ST4152	"K[
	zero	T26,-ST4152	"Ks
	zero	T27,-ST4152	"be
	zero	T28,-ST4152	"bn
	zero	T29,-ST4152	"fl
	zero	T30,-ST4152	"fs
	zero	T31,-ST4152	"lb
	zero	T32,-ST4152	"le
	zero	T33,-ST4152	"sb
	zero	T34,-ST4152	"se
	zero	T38,-ST4152	"dn
	zero	T39,-ST4152	"en
	zero	T40,-ST4152	"sn
	zero	T41,-ST4152	"fak
	zero	T42,-ST4152	"fka
	zero	T43,-ST4152	"em
	zero	T44,-ST4152	"fi
	zero	T45,-ST4152	"fir
	zero	T46,-ST4152	"fv
	zero	T47,-ST4152	"fvr
	zero	T48,-ST4152	"ff
	zero	T49,-ST4152	"ffr
	zero	T50,-ST4152	"fln
	zero	T51,-ST4152	"sk
	zero	T53,-ST4152	"Kl
	zero	T54,-ST4152	"Kb
	zero	T55,-ST4152	"if
	zero	T57,-ST4152	"ag
	zero	T58,-ST4152	"cs
	zero	T60,-ST4152	"pn
	zero	T61,-ST4152	"p[
	zero	T62,-ST4152	"fmx
	zero	T63,-ST4152	"fmn
	zero	T64,-ST4152	"frs
	zero	T65,-ST4152	"||
	zero	T66,-ST4152	"<var>
	zero	T68,-ST4152	"mct
	zero	T69,-ST4152	"emt
	zero	T70,-ST4152	"emc
	zero	T71,-ST4152	"<u+>
	zero	T72,-ST4152	"<u->
	equ	LN1335,*-DPDA-ST1335-1
"
" STATE 1384
	equ	ST1384,*-DPDA
	zero	STRD,LN1384
	zero	T4,ST2654	",
	zero	T8,ST2659	")
	equ	LN1384,*-DPDA-ST1384-1
"
" STATE 1387
	equ	ST1387,*-DPDA
	zero	APLYS,LN1387
	zero	2,2   pd ld
	zero	57,1   rule/alt
	zero	15,ST78 prod/val
	equ	LN1387,*-DPDA-ST1387-1
"
" STATE 1391
	equ	ST1391,*-DPDA
	zero	APLYS,LN1391
	zero	2,2   pd ld
	zero	58,1   rule/alt
	zero	15,ST78 prod/val
	equ	LN1391,*-DPDA-ST1391-1
"
" STATE 1395
	equ	ST1395,*-DPDA
	zero	APLYS,LN1395
	zero	2,2   pd ld
	zero	59,1   rule/alt
	zero	15,ST78 prod/val
	equ	LN1395,*-DPDA-ST1395-1
"
" STATE 1399
	equ	ST1399,*-DPDA
	zero	NSRD,LN1399
	zero	T1,-ST4159	"<integer>
	zero	T2,-ST4159	"<string>
	zero	T3,-ST4159	"]
	zero	T4,-ST4159	",
	zero	T6,-ST4159	"}
	zero	T7,-ST4159	"(
	zero	T8,-ST4159	")
	zero	T9,-ST4159	":
	zero	T10,-ST4159	".
	zero	T12,-ST4158	"*
	zero	T13,-ST4158	"/
	zero	T14,-ST4158	"|
	zero	T15,-ST4159	"+
	zero	T16,-ST4159	"-
	zero	T17,-ST4159	"<
	zero	T18,-ST4159	">
	zero	T19,-ST4159	"=
	zero	T20,-ST4159	"<=
	zero	T21,-ST4159	">=
	zero	T22,-ST4159	"^=
	zero	T23,-ST4159	"a[
	zero	T24,-ST4159	"k[
	zero	T25,-ST4159	"K[
	zero	T26,-ST4159	"Ks
	zero	T27,-ST4159	"be
	zero	T28,-ST4159	"bn
	zero	T29,-ST4159	"fl
	zero	T30,-ST4159	"fs
	zero	T31,-ST4159	"lb
	zero	T32,-ST4159	"le
	zero	T33,-ST4159	"sb
	zero	T34,-ST4159	"se
	zero	T38,-ST4159	"dn
	zero	T39,-ST4159	"en
	zero	T40,-ST4159	"sn
	zero	T41,-ST4159	"fak
	zero	T42,-ST4159	"fka
	zero	T43,-ST4159	"em
	zero	T44,-ST4159	"fi
	zero	T45,-ST4159	"fir
	zero	T46,-ST4159	"fv
	zero	T47,-ST4159	"fvr
	zero	T48,-ST4159	"ff
	zero	T49,-ST4159	"ffr
	zero	T50,-ST4159	"fln
	zero	T51,-ST4159	"sk
	zero	T52,-ST4159	"J
	zero	T53,-ST4159	"Kl
	zero	T54,-ST4159	"Kb
	zero	T55,-ST4159	"if
	zero	T57,-ST4159	"ag
	zero	T58,-ST4159	"cs
	zero	T60,-ST4159	"pn
	zero	T61,-ST4159	"p[
	zero	T62,-ST4159	"fmx
	zero	T63,-ST4159	"fmn
	zero	T64,-ST4159	"frs
	zero	T65,-ST4159	"||
	zero	T66,-ST4159	"<var>
	zero	T68,-ST4159	"mct
	zero	T69,-ST4159	"emt
	zero	T70,-ST4159	"emc
	zero	T71,-ST4159	"<u+>
	zero	T72,-ST4159	"<u->
	equ	LN1399,*-DPDA-ST1399-1
"
" STATE 1464
	equ	ST1464,*-DPDA
	zero	NSRD,LN1464
	zero	T1,-ST4164	"<integer>
	zero	T2,-ST4164	"<string>
	zero	T3,-ST4164	"]
	zero	T4,-ST4164	",
	zero	T6,-ST4164	"}
	zero	T7,-ST4164	"(
	zero	T8,-ST4164	")
	zero	T9,-ST4164	":
	zero	T10,-ST4164	".
	zero	T12,-ST4163	"*
	zero	T13,-ST4163	"/
	zero	T14,-ST4163	"|
	zero	T15,-ST4164	"+
	zero	T16,-ST4164	"-
	zero	T17,-ST4164	"<
	zero	T18,-ST4164	">
	zero	T19,-ST4164	"=
	zero	T20,-ST4164	"<=
	zero	T21,-ST4164	">=
	zero	T22,-ST4164	"^=
	zero	T23,-ST4164	"a[
	zero	T24,-ST4164	"k[
	zero	T25,-ST4164	"K[
	zero	T26,-ST4164	"Ks
	zero	T27,-ST4164	"be
	zero	T28,-ST4164	"bn
	zero	T29,-ST4164	"fl
	zero	T30,-ST4164	"fs
	zero	T31,-ST4164	"lb
	zero	T32,-ST4164	"le
	zero	T33,-ST4164	"sb
	zero	T34,-ST4164	"se
	zero	T38,-ST4164	"dn
	zero	T39,-ST4164	"en
	zero	T40,-ST4164	"sn
	zero	T41,-ST4164	"fak
	zero	T42,-ST4164	"fka
	zero	T43,-ST4164	"em
	zero	T44,-ST4164	"fi
	zero	T45,-ST4164	"fir
	zero	T46,-ST4164	"fv
	zero	T47,-ST4164	"fvr
	zero	T48,-ST4164	"ff
	zero	T49,-ST4164	"ffr
	zero	T50,-ST4164	"fln
	zero	T51,-ST4164	"sk
	zero	T52,-ST4164	"J
	zero	T53,-ST4164	"Kl
	zero	T54,-ST4164	"Kb
	zero	T55,-ST4164	"if
	zero	T57,-ST4164	"ag
	zero	T58,-ST4164	"cs
	zero	T60,-ST4164	"pn
	zero	T61,-ST4164	"p[
	zero	T62,-ST4164	"fmx
	zero	T63,-ST4164	"fmn
	zero	T64,-ST4164	"frs
	zero	T65,-ST4164	"||
	zero	T66,-ST4164	"<var>
	zero	T68,-ST4164	"mct
	zero	T69,-ST4164	"emt
	zero	T70,-ST4164	"emc
	zero	T71,-ST4164	"<u+>
	zero	T72,-ST4164	"<u->
	equ	LN1464,*-DPDA-ST1464-1
"
" STATE 1529
	equ	ST1529,*-DPDA
	zero	NSRD,LN1529
	zero	T1,-ST4168	"<integer>
	zero	T2,-ST4168	"<string>
	zero	T4,-ST4169	",
	zero	T6,-ST4169	"}
	zero	T7,-ST4168	"(
	zero	T8,-ST4169	")
	zero	T9,-ST4169	":
	zero	T10,-ST4169	".
	zero	T23,-ST4168	"a[
	zero	T24,-ST4168	"k[
	zero	T25,-ST4168	"K[
	zero	T26,-ST4168	"Ks
	zero	T27,-ST4168	"be
	zero	T28,-ST4168	"bn
	zero	T29,-ST4168	"fl
	zero	T30,-ST4168	"fs
	zero	T31,-ST4168	"lb
	zero	T32,-ST4168	"le
	zero	T33,-ST4168	"sb
	zero	T34,-ST4168	"se
	zero	T38,-ST4168	"dn
	zero	T39,-ST4168	"en
	zero	T40,-ST4168	"sn
	zero	T41,-ST4168	"fak
	zero	T42,-ST4168	"fka
	zero	T43,-ST4168	"em
	zero	T44,-ST4168	"fi
	zero	T45,-ST4168	"fir
	zero	T46,-ST4168	"fv
	zero	T47,-ST4168	"fvr
	zero	T48,-ST4168	"ff
	zero	T49,-ST4168	"ffr
	zero	T50,-ST4168	"fln
	zero	T51,-ST4168	"sk
	zero	T53,-ST4168	"Kl
	zero	T54,-ST4168	"Kb
	zero	T55,-ST4168	"if
	zero	T57,-ST4168	"ag
	zero	T58,-ST4168	"cs
	zero	T60,-ST4168	"pn
	zero	T61,-ST4168	"p[
	zero	T62,-ST4168	"fmx
	zero	T63,-ST4168	"fmn
	zero	T64,-ST4168	"frs
	zero	T65,-ST4168	"||
	zero	T66,-ST4168	"<var>
	zero	T68,-ST4168	"mct
	zero	T69,-ST4168	"emt
	zero	T70,-ST4168	"emc
	zero	T71,-ST4168	"<u+>
	zero	T72,-ST4168	"<u->
	equ	LN1529,*-DPDA-ST1529-1
"
" STATE 1581
	equ	ST1581,*-DPDA
	zero	STRD,LN1581
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T3,ST2663	"]
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN1581,*-DPDA-ST1581-1
"
" STATE 1629
	equ	ST1629,*-DPDA
	zero	STRD,LN1629
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T3,ST2667	"]
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN1629,*-DPDA-ST1629-1
"
" STATE 1677
	equ	ST1677,*-DPDA
	zero	STRD,LN1677
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T3,ST2671	"]
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN1677,*-DPDA-ST1677-1
"
" STATE 1725
	equ	ST1725,*-DPDA
	zero	STRDS,ST278

"
" STATE 1726
	equ	ST1726,*-DPDA
	zero	NSRD,LN1726
	zero	T1,-ST4176	"<integer>
	zero	T2,-ST4176	"<string>
	zero	T3,-ST4176	"]
	zero	T4,-ST4176	",
	zero	T6,-ST4176	"}
	zero	T7,-ST4176	"(
	zero	T8,-ST4176	")
	zero	T9,-ST4176	":
	zero	T10,-ST4176	".
	zero	T15,-ST4175	"+
	zero	T16,-ST4175	"-
	zero	T17,-ST4176	"<
	zero	T18,-ST4176	">
	zero	T19,-ST4176	"=
	zero	T20,-ST4176	"<=
	zero	T21,-ST4176	">=
	zero	T22,-ST4176	"^=
	zero	T23,-ST4176	"a[
	zero	T24,-ST4176	"k[
	zero	T25,-ST4176	"K[
	zero	T26,-ST4176	"Ks
	zero	T27,-ST4176	"be
	zero	T28,-ST4176	"bn
	zero	T29,-ST4176	"fl
	zero	T30,-ST4176	"fs
	zero	T31,-ST4176	"lb
	zero	T32,-ST4176	"le
	zero	T33,-ST4176	"sb
	zero	T34,-ST4176	"se
	zero	T38,-ST4176	"dn
	zero	T39,-ST4176	"en
	zero	T40,-ST4176	"sn
	zero	T41,-ST4176	"fak
	zero	T42,-ST4176	"fka
	zero	T43,-ST4176	"em
	zero	T44,-ST4176	"fi
	zero	T45,-ST4176	"fir
	zero	T46,-ST4176	"fv
	zero	T47,-ST4176	"fvr
	zero	T48,-ST4176	"ff
	zero	T49,-ST4176	"ffr
	zero	T50,-ST4176	"fln
	zero	T51,-ST4176	"sk
	zero	T52,-ST4176	"J
	zero	T53,-ST4176	"Kl
	zero	T54,-ST4176	"Kb
	zero	T55,-ST4176	"if
	zero	T57,-ST4176	"ag
	zero	T58,-ST4176	"cs
	zero	T60,-ST4176	"pn
	zero	T61,-ST4176	"p[
	zero	T62,-ST4176	"fmx
	zero	T63,-ST4176	"fmn
	zero	T64,-ST4176	"frs
	zero	T65,-ST4176	"||
	zero	T66,-ST4176	"<var>
	zero	T68,-ST4176	"mct
	zero	T69,-ST4176	"emt
	zero	T70,-ST4176	"emc
	zero	T71,-ST4176	"<u+>
	zero	T72,-ST4176	"<u->
	equ	LN1726,*-DPDA-ST1726-1
"
" STATE 1788
	equ	ST1788,*-DPDA
	zero	APLY1,LN1788
	zero	3,3   pd ld
	zero	3,1   rule/alt
	zero	2,ST8 prod/val
	equ	LN1788,*-DPDA-ST1788-1
"
" STATE 1792
	equ	ST1792,*-DPDA
	zero	APLYS,LN1792
	zero	2,2   pd ld
	zero	65,2   rule/alt
	zero	17,ST272 prod/val
	equ	LN1792,*-DPDA-ST1792-1
"
" STATE 1796
	equ	ST1796,*-DPDA
	zero	APLYS,LN1796
	zero	2,2   pd ld
	zero	65,1   rule/alt
	zero	17,ST272 prod/val
	equ	LN1796,*-DPDA-ST1796-1
"
" STATE 1800
	equ	ST1800,*-DPDA
	zero	APLYS,LN1800
	zero	2,2   pd ld
	zero	65,3   rule/alt
	zero	17,ST272 prod/val
	equ	LN1800,*-DPDA-ST1800-1
"
" STATE 1804
	equ	ST1804,*-DPDA
	zero	NSRD,LN1804
	zero	T1,-ST2663	"<integer>
	zero	T2,-ST2663	"<string>
	zero	T6,-ST2663	"}
	zero	T7,-ST2663	"(
	zero	T8,-ST2663	")
	zero	T9,-ST2663	":
	zero	T10,-ST2663	".
	zero	T11,-ST4180	":=
	zero	T12,-ST2663	"*
	zero	T13,-ST2663	"/
	zero	T14,-ST2663	"|
	zero	T15,-ST2663	"+
	zero	T16,-ST2663	"-
	zero	T17,-ST2663	"<
	zero	T18,-ST2663	">
	zero	T19,-ST2663	"=
	zero	T20,-ST2663	"<=
	zero	T21,-ST2663	">=
	zero	T22,-ST2663	"^=
	zero	T23,-ST2663	"a[
	zero	T24,-ST2663	"k[
	zero	T25,-ST2663	"K[
	zero	T26,-ST2663	"Ks
	zero	T27,-ST2663	"be
	zero	T28,-ST2663	"bn
	zero	T29,-ST2663	"fl
	zero	T30,-ST2663	"fs
	zero	T31,-ST2663	"lb
	zero	T32,-ST2663	"le
	zero	T33,-ST2663	"sb
	zero	T34,-ST2663	"se
	zero	T38,-ST2663	"dn
	zero	T39,-ST2663	"en
	zero	T40,-ST2663	"sn
	zero	T41,-ST2663	"fak
	zero	T42,-ST2663	"fka
	zero	T43,-ST2663	"em
	zero	T44,-ST2663	"fi
	zero	T45,-ST2663	"fir
	zero	T46,-ST2663	"fv
	zero	T47,-ST2663	"fvr
	zero	T48,-ST2663	"ff
	zero	T49,-ST2663	"ffr
	zero	T50,-ST2663	"fln
	zero	T51,-ST2663	"sk
	zero	T52,-ST2663	"J
	zero	T53,-ST2663	"Kl
	zero	T54,-ST2663	"Kb
	zero	T55,-ST2663	"if
	zero	T57,-ST2663	"ag
	zero	T58,-ST2663	"cs
	zero	T60,-ST2663	"pn
	zero	T61,-ST2663	"p[
	zero	T62,-ST2663	"fmx
	zero	T63,-ST2663	"fmn
	zero	T64,-ST2663	"frs
	zero	T65,-ST2663	"||
	zero	T66,-ST2663	"<var>
	zero	T68,-ST2663	"mct
	zero	T69,-ST2663	"emt
	zero	T70,-ST2663	"emc
	zero	T71,-ST2663	"<u+>
	zero	T72,-ST2663	"<u->
	equ	LN1804,*-DPDA-ST1804-1
"
" STATE 1868
	equ	ST1868,*-DPDA
	zero	NSRD,LN1868
	zero	T1,-ST2667	"<integer>
	zero	T2,-ST2667	"<string>
	zero	T6,-ST2667	"}
	zero	T7,-ST2667	"(
	zero	T8,-ST2667	")
	zero	T9,-ST2667	":
	zero	T10,-ST2667	".
	zero	T11,-ST4182	":=
	zero	T12,-ST2667	"*
	zero	T13,-ST2667	"/
	zero	T14,-ST2667	"|
	zero	T15,-ST2667	"+
	zero	T16,-ST2667	"-
	zero	T17,-ST2667	"<
	zero	T18,-ST2667	">
	zero	T19,-ST2667	"=
	zero	T20,-ST2667	"<=
	zero	T21,-ST2667	">=
	zero	T22,-ST2667	"^=
	zero	T23,-ST2667	"a[
	zero	T24,-ST2667	"k[
	zero	T25,-ST2667	"K[
	zero	T26,-ST2667	"Ks
	zero	T27,-ST2667	"be
	zero	T28,-ST2667	"bn
	zero	T29,-ST2667	"fl
	zero	T30,-ST2667	"fs
	zero	T31,-ST2667	"lb
	zero	T32,-ST2667	"le
	zero	T33,-ST2667	"sb
	zero	T34,-ST2667	"se
	zero	T38,-ST2667	"dn
	zero	T39,-ST2667	"en
	zero	T40,-ST2667	"sn
	zero	T41,-ST2667	"fak
	zero	T42,-ST2667	"fka
	zero	T43,-ST2667	"em
	zero	T44,-ST2667	"fi
	zero	T45,-ST2667	"fir
	zero	T46,-ST2667	"fv
	zero	T47,-ST2667	"fvr
	zero	T48,-ST2667	"ff
	zero	T49,-ST2667	"ffr
	zero	T50,-ST2667	"fln
	zero	T51,-ST2667	"sk
	zero	T52,-ST2667	"J
	zero	T53,-ST2667	"Kl
	zero	T54,-ST2667	"Kb
	zero	T55,-ST2667	"if
	zero	T57,-ST2667	"ag
	zero	T58,-ST2667	"cs
	zero	T60,-ST2667	"pn
	zero	T61,-ST2667	"p[
	zero	T62,-ST2667	"fmx
	zero	T63,-ST2667	"fmn
	zero	T64,-ST2667	"frs
	zero	T65,-ST2667	"||
	zero	T66,-ST2667	"<var>
	zero	T68,-ST2667	"mct
	zero	T69,-ST2667	"emt
	zero	T70,-ST2667	"emc
	zero	T71,-ST2667	"<u+>
	zero	T72,-ST2667	"<u->
	equ	LN1868,*-DPDA-ST1868-1
"
" STATE 1932
	equ	ST1932,*-DPDA
	zero	NSRD,LN1932
	zero	T1,-ST2671	"<integer>
	zero	T2,-ST2671	"<string>
	zero	T6,-ST2671	"}
	zero	T7,-ST2671	"(
	zero	T8,-ST2671	")
	zero	T9,-ST2671	":
	zero	T10,-ST2671	".
	zero	T11,-ST4184	":=
	zero	T12,-ST2671	"*
	zero	T13,-ST2671	"/
	zero	T14,-ST2671	"|
	zero	T15,-ST2671	"+
	zero	T16,-ST2671	"-
	zero	T17,-ST2671	"<
	zero	T18,-ST2671	">
	zero	T19,-ST2671	"=
	zero	T20,-ST2671	"<=
	zero	T21,-ST2671	">=
	zero	T22,-ST2671	"^=
	zero	T23,-ST2671	"a[
	zero	T24,-ST2671	"k[
	zero	T25,-ST2671	"K[
	zero	T26,-ST2671	"Ks
	zero	T27,-ST2671	"be
	zero	T28,-ST2671	"bn
	zero	T29,-ST2671	"fl
	zero	T30,-ST2671	"fs
	zero	T31,-ST2671	"lb
	zero	T32,-ST2671	"le
	zero	T33,-ST2671	"sb
	zero	T34,-ST2671	"se
	zero	T38,-ST2671	"dn
	zero	T39,-ST2671	"en
	zero	T40,-ST2671	"sn
	zero	T41,-ST2671	"fak
	zero	T42,-ST2671	"fka
	zero	T43,-ST2671	"em
	zero	T44,-ST2671	"fi
	zero	T45,-ST2671	"fir
	zero	T46,-ST2671	"fv
	zero	T47,-ST2671	"fvr
	zero	T48,-ST2671	"ff
	zero	T49,-ST2671	"ffr
	zero	T50,-ST2671	"fln
	zero	T51,-ST2671	"sk
	zero	T52,-ST2671	"J
	zero	T53,-ST2671	"Kl
	zero	T54,-ST2671	"Kb
	zero	T55,-ST2671	"if
	zero	T57,-ST2671	"ag
	zero	T58,-ST2671	"cs
	zero	T60,-ST2671	"pn
	zero	T61,-ST2671	"p[
	zero	T62,-ST2671	"fmx
	zero	T63,-ST2671	"fmn
	zero	T64,-ST2671	"frs
	zero	T65,-ST2671	"||
	zero	T66,-ST2671	"<var>
	zero	T68,-ST2671	"mct
	zero	T69,-ST2671	"emt
	zero	T70,-ST2671	"emc
	zero	T71,-ST2671	"<u+>
	zero	T72,-ST2671	"<u->
	equ	LN1932,*-DPDA-ST1932-1
"
" STATE 1996
	equ	ST1996,*-DPDA
	zero	STRD,LN1996
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST2730	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN1996,*-DPDA-ST1996-1
"
" STATE 2044
	equ	ST2044,*-DPDA
	zero	STRD,LN2044
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST2734	",
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2044,*-DPDA-ST2044-1
"
" STATE 2092
	equ	ST2092,*-DPDA
	zero	STRD,LN2092
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST2735	",
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2092,*-DPDA-ST2092-1
"
" STATE 2140
	equ	ST2140,*-DPDA
	zero	STRD,LN2140
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST2736	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2140,*-DPDA-ST2140-1
"
" STATE 2188
	equ	ST2188,*-DPDA
	zero	STRD,LN2188
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST2740	",
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2188,*-DPDA-ST2188-1
"
" STATE 2236
	equ	ST2236,*-DPDA
	zero	STRD,LN2236
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST2741	",
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2236,*-DPDA-ST2236-1
"
" STATE 2284
	equ	ST2284,*-DPDA
	zero	STRD,LN2284
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST2742	",
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2284,*-DPDA-ST2284-1
"
" STATE 2332
	equ	ST2332,*-DPDA
	zero	STRD,LN2332
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST2789	",
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2332,*-DPDA-ST2332-1
"
" STATE 2380
	equ	ST2380,*-DPDA
	zero	STRD,LN2380
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST2836	",
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2380,*-DPDA-ST2380-1
"
" STATE 2428
	equ	ST2428,*-DPDA
	zero	STRD,LN2428
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST2883	",
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2428,*-DPDA-ST2428-1
"
" STATE 2476
	equ	ST2476,*-DPDA
	zero	STRD,LN2476
	zero	T8,ST2930	")
	equ	LN2476,*-DPDA-ST2476-1
"
" STATE 2478
	equ	ST2478,*-DPDA
	zero	STRD,LN2478
	zero	T8,ST2934	")
	equ	LN2478,*-DPDA-ST2478-1
"
" STATE 2480
	equ	ST2480,*-DPDA
	zero	STRD,LN2480
	zero	T8,ST2938	")
	equ	LN2480,*-DPDA-ST2480-1
"
" STATE 2482
	equ	ST2482,*-DPDA
	zero	STRD,LN2482
	zero	T4,ST2942	",
	equ	LN2482,*-DPDA-ST2482-1
"
" STATE 2484
	equ	ST2484,*-DPDA
	zero	STRD,LN2484
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T17,ST824	"<
	zero	T18,ST829	">
	zero	T19,ST833	"=
	zero	T20,ST837	"<=
	zero	T21,ST841	">=
	zero	T22,ST845	"^=
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T52,ST852	"J
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2484,*-DPDA-ST2484-1
"
" STATE 2538
	equ	ST2538,*-DPDA
	zero	APLY1,LN2538
	zero	2,2   pd ld
	zero	27,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2538,*-DPDA-ST2538-1
"
" STATE 2542
	equ	ST2542,*-DPDA
	zero	STRD,LN2542
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST2943	",
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2542,*-DPDA-ST2542-1
"
" STATE 2590
	equ	ST2590,*-DPDA
	zero	STRD,LN2590
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST2944	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2590,*-DPDA-ST2590-1
"
" STATE 2638
	equ	ST2638,*-DPDA
	zero	APLY1,LN2638
	zero	2,2   pd ld
	zero	71,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2638,*-DPDA-ST2638-1
"
" STATE 2642
	equ	ST2642,*-DPDA
	zero	APLY1,LN2642
	zero	2,2   pd ld
	zero	45,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2642,*-DPDA-ST2642-1
"
" STATE 2646
	equ	ST2646,*-DPDA
	zero	APLY1,LN2646
	zero	2,2   pd ld
	zero	46,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2646,*-DPDA-ST2646-1
"
" STATE 2650
	equ	ST2650,*-DPDA
	zero	APLY1,LN2650
	zero	3,3   pd ld
	zero	50,1   rule/alt
	zero	11,ST4 prod/val
	equ	LN2650,*-DPDA-ST2650-1
"
" STATE 2654
	equ	ST2654,*-DPDA
	zero	STRDS,ST278

"
" STATE 2655
	equ	ST2655,*-DPDA
	zero	APLY1,LN2655
	zero	3,3   pd ld
	zero	80,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2655,*-DPDA-ST2655-1
"
" STATE 2659
	equ	ST2659,*-DPDA
	zero	APLY1,LN2659
	zero	3,3   pd ld
	zero	79,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2659,*-DPDA-ST2659-1
"
" STATE 2663
	equ	ST2663,*-DPDA
	zero	APLY1,LN2663
	zero	2,2   pd ld
	zero	66,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2663,*-DPDA-ST2663-1
"
" STATE 2667
	equ	ST2667,*-DPDA
	zero	APLY1,LN2667
	zero	2,2   pd ld
	zero	25,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2667,*-DPDA-ST2667-1
"
" STATE 2671
	equ	ST2671,*-DPDA
	zero	APLY1,LN2671
	zero	2,2   pd ld
	zero	26,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2671,*-DPDA-ST2671-1
"
" STATE 2675
	equ	ST2675,*-DPDA
	zero	NSRD,LN2675
	zero	T1,-ST4186	"<integer>
	zero	T2,-ST4186	"<string>
	zero	T4,-ST4187	",
	zero	T6,-ST4187	"}
	zero	T7,-ST4186	"(
	zero	T8,-ST4187	")
	zero	T9,-ST4187	":
	zero	T10,-ST4187	".
	zero	T23,-ST4186	"a[
	zero	T24,-ST4186	"k[
	zero	T25,-ST4186	"K[
	zero	T26,-ST4186	"Ks
	zero	T27,-ST4186	"be
	zero	T28,-ST4186	"bn
	zero	T29,-ST4186	"fl
	zero	T30,-ST4186	"fs
	zero	T31,-ST4186	"lb
	zero	T32,-ST4186	"le
	zero	T33,-ST4186	"sb
	zero	T34,-ST4186	"se
	zero	T38,-ST4186	"dn
	zero	T39,-ST4186	"en
	zero	T40,-ST4186	"sn
	zero	T41,-ST4186	"fak
	zero	T42,-ST4186	"fka
	zero	T43,-ST4186	"em
	zero	T44,-ST4186	"fi
	zero	T45,-ST4186	"fir
	zero	T46,-ST4186	"fv
	zero	T47,-ST4186	"fvr
	zero	T48,-ST4186	"ff
	zero	T49,-ST4186	"ffr
	zero	T50,-ST4186	"fln
	zero	T51,-ST4186	"sk
	zero	T53,-ST4186	"Kl
	zero	T54,-ST4186	"Kb
	zero	T55,-ST4186	"if
	zero	T57,-ST4186	"ag
	zero	T58,-ST4186	"cs
	zero	T60,-ST4186	"pn
	zero	T61,-ST4186	"p[
	zero	T62,-ST4186	"fmx
	zero	T63,-ST4186	"fmn
	zero	T64,-ST4186	"frs
	zero	T65,-ST4186	"||
	zero	T66,-ST4186	"<var>
	zero	T68,-ST4186	"mct
	zero	T69,-ST4186	"emt
	zero	T70,-ST4186	"emc
	zero	T71,-ST4186	"<u+>
	zero	T72,-ST4186	"<u->
	equ	LN2675,*-DPDA-ST2675-1
"
" STATE 2727
	equ	ST2727,*-DPDA
	zero	STRDS,ST278

"
" STATE 2728
	equ	ST2728,*-DPDA
	zero	STRDS,ST278

"
" STATE 2729
	equ	ST2729,*-DPDA
	zero	STRDS,ST278

"
" STATE 2730
	equ	ST2730,*-DPDA
	zero	APLY1,LN2730
	zero	3,3   pd ld
	zero	83,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2730,*-DPDA-ST2730-1
"
" STATE 2734
	equ	ST2734,*-DPDA
	zero	STRDS,ST278

"
" STATE 2735
	equ	ST2735,*-DPDA
	zero	STRDS,ST278

"
" STATE 2736
	equ	ST2736,*-DPDA
	zero	APLY1,LN2736
	zero	3,3   pd ld
	zero	67,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2736,*-DPDA-ST2736-1
"
" STATE 2740
	equ	ST2740,*-DPDA
	zero	STRDS,ST278

"
" STATE 2741
	equ	ST2741,*-DPDA
	zero	STRDS,ST278

"
" STATE 2742
	equ	ST2742,*-DPDA
	zero	STRD,LN2742
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T59,ST3387	"<set>
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2742,*-DPDA-ST2742-1
"
" STATE 2789
	equ	ST2789,*-DPDA
	zero	STRD,LN2789
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T59,ST3437	"<set>
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2789,*-DPDA-ST2789-1
"
" STATE 2836
	equ	ST2836,*-DPDA
	zero	STRD,LN2836
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T59,ST3487	"<set>
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2836,*-DPDA-ST2836-1
"
" STATE 2883
	equ	ST2883,*-DPDA
	zero	STRD,LN2883
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T59,ST3537	"<set>
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN2883,*-DPDA-ST2883-1
"
" STATE 2930
	equ	ST2930,*-DPDA
	zero	APLY1,LN2930
	zero	3,3   pd ld
	zero	94,3   rule/alt
	zero	9,ST272 prod/val
	equ	LN2930,*-DPDA-ST2930-1
"
" STATE 2934
	equ	ST2934,*-DPDA
	zero	APLY1,LN2934
	zero	3,3   pd ld
	zero	94,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN2934,*-DPDA-ST2934-1
"
" STATE 2938
	equ	ST2938,*-DPDA
	zero	APLY1,LN2938
	zero	3,3   pd ld
	zero	94,2   rule/alt
	zero	9,ST272 prod/val
	equ	LN2938,*-DPDA-ST2938-1
"
" STATE 2942
	equ	ST2942,*-DPDA
	zero	STRDS,ST278

"
" STATE 2943
	equ	ST2943,*-DPDA
	zero	STRDS,ST278

"
" STATE 2944
	equ	ST2944,*-DPDA
	zero	STRD,LN2944
	zero	T10,ST3636	".
	equ	LN2944,*-DPDA-ST2944-1
"
" STATE 2946
	equ	ST2946,*-DPDA
	zero	NSRD,LN2946
	zero	T1,-ST4191	"<integer>
	zero	T2,-ST4191	"<string>
	zero	T4,-ST4192	",
	zero	T7,-ST4191	"(
	zero	T8,-ST4192	")
	zero	T23,-ST4191	"a[
	zero	T24,-ST4191	"k[
	zero	T25,-ST4191	"K[
	zero	T26,-ST4191	"Ks
	zero	T27,-ST4191	"be
	zero	T28,-ST4191	"bn
	zero	T29,-ST4191	"fl
	zero	T30,-ST4191	"fs
	zero	T31,-ST4191	"lb
	zero	T32,-ST4191	"le
	zero	T33,-ST4191	"sb
	zero	T34,-ST4191	"se
	zero	T38,-ST4191	"dn
	zero	T39,-ST4191	"en
	zero	T40,-ST4191	"sn
	zero	T41,-ST4191	"fak
	zero	T42,-ST4191	"fka
	zero	T43,-ST4191	"em
	zero	T44,-ST4191	"fi
	zero	T45,-ST4191	"fir
	zero	T46,-ST4191	"fv
	zero	T47,-ST4191	"fvr
	zero	T48,-ST4191	"ff
	zero	T49,-ST4191	"ffr
	zero	T50,-ST4191	"fln
	zero	T51,-ST4191	"sk
	zero	T53,-ST4191	"Kl
	zero	T54,-ST4191	"Kb
	zero	T55,-ST4191	"if
	zero	T57,-ST4191	"ag
	zero	T58,-ST4191	"cs
	zero	T60,-ST4191	"pn
	zero	T61,-ST4191	"p[
	zero	T62,-ST4191	"fmx
	zero	T63,-ST4191	"fmn
	zero	T64,-ST4191	"frs
	zero	T65,-ST4191	"||
	zero	T66,-ST4191	"<var>
	zero	T68,-ST4191	"mct
	zero	T69,-ST4191	"emt
	zero	T70,-ST4191	"emc
	zero	T71,-ST4191	"<u+>
	zero	T72,-ST4191	"<u->
	equ	LN2946,*-DPDA-ST2946-1
"
" STATE 2995
	equ	ST2995,*-DPDA
	zero	NSRD,LN2995
	zero	T1,-ST4196	"<integer>
	zero	T2,-ST4196	"<string>
	zero	T6,-ST4197	"}
	zero	T7,-ST4196	"(
	zero	T8,-ST4197	")
	zero	T10,-ST4197	".
	zero	T23,-ST4196	"a[
	zero	T24,-ST4196	"k[
	zero	T25,-ST4196	"K[
	zero	T26,-ST4196	"Ks
	zero	T27,-ST4196	"be
	zero	T28,-ST4196	"bn
	zero	T29,-ST4196	"fl
	zero	T30,-ST4196	"fs
	zero	T31,-ST4196	"lb
	zero	T32,-ST4196	"le
	zero	T33,-ST4196	"sb
	zero	T34,-ST4196	"se
	zero	T38,-ST4196	"dn
	zero	T39,-ST4196	"en
	zero	T40,-ST4196	"sn
	zero	T41,-ST4196	"fak
	zero	T42,-ST4196	"fka
	zero	T43,-ST4196	"em
	zero	T44,-ST4196	"fi
	zero	T45,-ST4196	"fir
	zero	T46,-ST4196	"fv
	zero	T47,-ST4196	"fvr
	zero	T48,-ST4196	"ff
	zero	T49,-ST4196	"ffr
	zero	T50,-ST4196	"fln
	zero	T51,-ST4196	"sk
	zero	T53,-ST4196	"Kl
	zero	T54,-ST4196	"Kb
	zero	T55,-ST4196	"if
	zero	T57,-ST4196	"ag
	zero	T58,-ST4196	"cs
	zero	T60,-ST4196	"pn
	zero	T61,-ST4196	"p[
	zero	T62,-ST4196	"fmx
	zero	T63,-ST4196	"fmn
	zero	T64,-ST4196	"frs
	zero	T65,-ST4196	"||
	zero	T66,-ST4196	"<var>
	zero	T68,-ST4196	"mct
	zero	T69,-ST4196	"emt
	zero	T70,-ST4196	"emc
	zero	T71,-ST4196	"<u+>
	zero	T72,-ST4196	"<u->
	equ	LN2995,*-DPDA-ST2995-1
"
" STATE 3045
	equ	ST3045,*-DPDA
	zero	NSRD,LN3045
	zero	T1,-ST4201	"<integer>
	zero	T2,-ST4201	"<string>
	zero	T6,-ST4202	"}
	zero	T7,-ST4201	"(
	zero	T8,-ST4202	")
	zero	T10,-ST4202	".
	zero	T23,-ST4201	"a[
	zero	T24,-ST4201	"k[
	zero	T25,-ST4201	"K[
	zero	T26,-ST4201	"Ks
	zero	T27,-ST4201	"be
	zero	T28,-ST4201	"bn
	zero	T29,-ST4201	"fl
	zero	T30,-ST4201	"fs
	zero	T31,-ST4201	"lb
	zero	T32,-ST4201	"le
	zero	T33,-ST4201	"sb
	zero	T34,-ST4201	"se
	zero	T38,-ST4201	"dn
	zero	T39,-ST4201	"en
	zero	T40,-ST4201	"sn
	zero	T41,-ST4201	"fak
	zero	T42,-ST4201	"fka
	zero	T43,-ST4201	"em
	zero	T44,-ST4201	"fi
	zero	T45,-ST4201	"fir
	zero	T46,-ST4201	"fv
	zero	T47,-ST4201	"fvr
	zero	T48,-ST4201	"ff
	zero	T49,-ST4201	"ffr
	zero	T50,-ST4201	"fln
	zero	T51,-ST4201	"sk
	zero	T53,-ST4201	"Kl
	zero	T54,-ST4201	"Kb
	zero	T55,-ST4201	"if
	zero	T57,-ST4201	"ag
	zero	T58,-ST4201	"cs
	zero	T60,-ST4201	"pn
	zero	T61,-ST4201	"p[
	zero	T62,-ST4201	"fmx
	zero	T63,-ST4201	"fmn
	zero	T64,-ST4201	"frs
	zero	T65,-ST4201	"||
	zero	T66,-ST4201	"<var>
	zero	T68,-ST4201	"mct
	zero	T69,-ST4201	"emt
	zero	T70,-ST4201	"emc
	zero	T71,-ST4201	"<u+>
	zero	T72,-ST4201	"<u->
	equ	LN3045,*-DPDA-ST3045-1
"
" STATE 3095
	equ	ST3095,*-DPDA
	zero	NSRD,LN3095
	zero	T1,-ST4206	"<integer>
	zero	T2,-ST4206	"<string>
	zero	T6,-ST4207	"}
	zero	T7,-ST4206	"(
	zero	T8,-ST4207	")
	zero	T10,-ST4207	".
	zero	T23,-ST4206	"a[
	zero	T24,-ST4206	"k[
	zero	T25,-ST4206	"K[
	zero	T26,-ST4206	"Ks
	zero	T27,-ST4206	"be
	zero	T28,-ST4206	"bn
	zero	T29,-ST4206	"fl
	zero	T30,-ST4206	"fs
	zero	T31,-ST4206	"lb
	zero	T32,-ST4206	"le
	zero	T33,-ST4206	"sb
	zero	T34,-ST4206	"se
	zero	T38,-ST4206	"dn
	zero	T39,-ST4206	"en
	zero	T40,-ST4206	"sn
	zero	T41,-ST4206	"fak
	zero	T42,-ST4206	"fka
	zero	T43,-ST4206	"em
	zero	T44,-ST4206	"fi
	zero	T45,-ST4206	"fir
	zero	T46,-ST4206	"fv
	zero	T47,-ST4206	"fvr
	zero	T48,-ST4206	"ff
	zero	T49,-ST4206	"ffr
	zero	T50,-ST4206	"fln
	zero	T51,-ST4206	"sk
	zero	T53,-ST4206	"Kl
	zero	T54,-ST4206	"Kb
	zero	T55,-ST4206	"if
	zero	T57,-ST4206	"ag
	zero	T58,-ST4206	"cs
	zero	T60,-ST4206	"pn
	zero	T61,-ST4206	"p[
	zero	T62,-ST4206	"fmx
	zero	T63,-ST4206	"fmn
	zero	T64,-ST4206	"frs
	zero	T65,-ST4206	"||
	zero	T66,-ST4206	"<var>
	zero	T68,-ST4206	"mct
	zero	T69,-ST4206	"emt
	zero	T70,-ST4206	"emc
	zero	T71,-ST4206	"<u+>
	zero	T72,-ST4206	"<u->
	equ	LN3095,*-DPDA-ST3095-1
"
" STATE 3145
	equ	ST3145,*-DPDA
	zero	STRD,LN3145
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST3640	",
	zero	T7,ST457	"(
	zero	T8,ST3641	")
	zero	T9,ST3645	":
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3145,*-DPDA-ST3145-1
"
" STATE 3195
	equ	ST3195,*-DPDA
	zero	STRD,LN3195
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3646	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3195,*-DPDA-ST3195-1
"
" STATE 3243
	equ	ST3243,*-DPDA
	zero	STRD,LN3243
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3650	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3243,*-DPDA-ST3243-1
"
" STATE 3291
	equ	ST3291,*-DPDA
	zero	STRD,LN3291
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3654	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3291,*-DPDA-ST3291-1
"
" STATE 3339
	equ	ST3339,*-DPDA
	zero	STRD,LN3339
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3658	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3339,*-DPDA-ST3339-1
"
" STATE 3387
	equ	ST3387,*-DPDA
	zero	STRD,LN3387
	zero	T8,ST3662	")
	equ	LN3387,*-DPDA-ST3387-1
"
" STATE 3389
	equ	ST3389,*-DPDA
	zero	STRD,LN3389
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3666	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3389,*-DPDA-ST3389-1
"
" STATE 3437
	equ	ST3437,*-DPDA
	zero	STRD,LN3437
	zero	T8,ST3670	")
	equ	LN3437,*-DPDA-ST3437-1
"
" STATE 3439
	equ	ST3439,*-DPDA
	zero	STRD,LN3439
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3674	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3439,*-DPDA-ST3439-1
"
" STATE 3487
	equ	ST3487,*-DPDA
	zero	STRD,LN3487
	zero	T8,ST3678	")
	equ	LN3487,*-DPDA-ST3487-1
"
" STATE 3489
	equ	ST3489,*-DPDA
	zero	STRD,LN3489
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3682	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3489,*-DPDA-ST3489-1
"
" STATE 3537
	equ	ST3537,*-DPDA
	zero	STRD,LN3537
	zero	T8,ST3686	")
	equ	LN3537,*-DPDA-ST3537-1
"
" STATE 3539
	equ	ST3539,*-DPDA
	zero	STRD,LN3539
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST3690	",
	zero	T7,ST457	"(
	zero	T8,ST3691	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3539,*-DPDA-ST3539-1
"
" STATE 3588
	equ	ST3588,*-DPDA
	zero	STRD,LN3588
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T4,ST3695	",
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3588,*-DPDA-ST3588-1
"
" STATE 3636
	equ	ST3636,*-DPDA
	zero	APLYS,LN3636
	zero	4,4   pd ld
	zero	16,1   rule/alt
	zero	4,ST740 prod/val
	equ	LN3636,*-DPDA-ST3636-1
"
" STATE 3640
	equ	ST3640,*-DPDA
	zero	STRDS,ST278

"
" STATE 3641
	equ	ST3641,*-DPDA
	zero	APLY1,LN3641
	zero	5,5   pd ld
	zero	34,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3641,*-DPDA-ST3641-1
"
" STATE 3645
	equ	ST3645,*-DPDA
	zero	STRDS,ST278

"
" STATE 3646
	equ	ST3646,*-DPDA
	zero	APLY1,LN3646
	zero	5,5   pd ld
	zero	33,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3646,*-DPDA-ST3646-1
"
" STATE 3650
	equ	ST3650,*-DPDA
	zero	APLY1,LN3650
	zero	5,5   pd ld
	zero	86,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3650,*-DPDA-ST3650-1
"
" STATE 3654
	equ	ST3654,*-DPDA
	zero	APLY1,LN3654
	zero	5,5   pd ld
	zero	87,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3654,*-DPDA-ST3654-1
"
" STATE 3658
	equ	ST3658,*-DPDA
	zero	APLY1,LN3658
	zero	5,5   pd ld
	zero	88,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3658,*-DPDA-ST3658-1
"
" STATE 3662
	equ	ST3662,*-DPDA
	zero	APLY1,LN3662
	zero	5,5   pd ld
	zero	92,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3662,*-DPDA-ST3662-1
"
" STATE 3666
	equ	ST3666,*-DPDA
	zero	APLY1,LN3666
	zero	5,5   pd ld
	zero	89,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3666,*-DPDA-ST3666-1
"
" STATE 3670
	equ	ST3670,*-DPDA
	zero	APLY1,LN3670
	zero	5,5   pd ld
	zero	93,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3670,*-DPDA-ST3670-1
"
" STATE 3674
	equ	ST3674,*-DPDA
	zero	APLY1,LN3674
	zero	5,5   pd ld
	zero	84,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3674,*-DPDA-ST3674-1
"
" STATE 3678
	equ	ST3678,*-DPDA
	zero	APLY1,LN3678
	zero	5,5   pd ld
	zero	90,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3678,*-DPDA-ST3678-1
"
" STATE 3682
	equ	ST3682,*-DPDA
	zero	APLY1,LN3682
	zero	5,5   pd ld
	zero	85,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3682,*-DPDA-ST3682-1
"
" STATE 3686
	equ	ST3686,*-DPDA
	zero	APLY1,LN3686
	zero	5,5   pd ld
	zero	91,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3686,*-DPDA-ST3686-1
"
" STATE 3690
	equ	ST3690,*-DPDA
	zero	STRDS,ST278

"
" STATE 3691
	equ	ST3691,*-DPDA
	zero	APLY1,LN3691
	zero	5,5   pd ld
	zero	36,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3691,*-DPDA-ST3691-1
"
" STATE 3695
	equ	ST3695,*-DPDA
	zero	STRDS,ST278

"
" STATE 3696
	equ	ST3696,*-DPDA
	zero	STRD,LN3696
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3888	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3696,*-DPDA-ST3696-1
"
" STATE 3744
	equ	ST3744,*-DPDA
	zero	STRD,LN3744
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3892	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3744,*-DPDA-ST3744-1
"
" STATE 3792
	equ	ST3792,*-DPDA
	zero	STRD,LN3792
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3896	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3792,*-DPDA-ST3792-1
"
" STATE 3840
	equ	ST3840,*-DPDA
	zero	STRD,LN3840
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T8,ST3900	")
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN3840,*-DPDA-ST3840-1
"
" STATE 3888
	equ	ST3888,*-DPDA
	zero	APLY1,LN3888
	zero	7,7   pd ld
	zero	34,2   rule/alt
	zero	9,ST272 prod/val
	equ	LN3888,*-DPDA-ST3888-1
"
" STATE 3892
	equ	ST3892,*-DPDA
	zero	APLY1,LN3892
	zero	7,7   pd ld
	zero	34,3   rule/alt
	zero	9,ST272 prod/val
	equ	LN3892,*-DPDA-ST3892-1
"
" STATE 3896
	equ	ST3896,*-DPDA
	zero	APLY1,LN3896
	zero	7,7   pd ld
	zero	37,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3896,*-DPDA-ST3896-1
"
" STATE 3900
	equ	ST3900,*-DPDA
	zero	APLY1,LN3900
	zero	7,7   pd ld
	zero	35,1   rule/alt
	zero	9,ST272 prod/val
	equ	LN3900,*-DPDA-ST3900-1
"
" STATE 3904
	equ	ST3904,*-DPDA
	zero	STRD,LN3904
	zero	T12,ST735	"*
	zero	T13,ST736	"/
	zero	T14,ST737	"|
	equ	LN3904,*-DPDA-ST3904-1
"
" STATE 3908
	equ	ST3908,*-DPDA
	zero	APLY,LN3908
	zero	0,0   pd ld
	zero	-56,1   rule/alt
	zero	14,ST149 prod/val
	zero	ST859,ST1726
	zero	ST988,ST749
	zero	ST1045,ST749
	zero	ST1093,ST749
	zero	ST1141,ST749
	zero	ST1216,ST749
	zero	ST1284,ST749
	zero	ST1581,ST749
	zero	ST1629,ST749
	zero	ST1677,ST749
	zero	ST1996,ST749
	zero	ST2044,ST749
	zero	ST2092,ST749
	zero	ST2140,ST749
	zero	ST2188,ST749
	zero	ST2236,ST749
	zero	ST2284,ST749
	zero	ST2332,ST749
	zero	ST2380,ST749
	zero	ST2428,ST749
	zero	ST2484,ST749
	zero	ST2542,ST749
	zero	ST2590,ST749
	zero	ST3145,ST749
	zero	ST3195,ST749
	zero	ST3243,ST749
	zero	ST3291,ST749
	zero	ST3339,ST749
	zero	ST3389,ST749
	zero	ST3439,ST749
	zero	ST3489,ST749
	zero	ST3539,ST749
	zero	ST3588,ST749
	zero	ST3696,ST749
	zero	ST3744,ST749
	zero	ST3792,ST749
	zero	ST3840,ST749
	zero	ST4020,ST749
	zero	ST4095,ST749
	zero	ST4147,ST749
	zero	ST4152,ST749
	zero	ST4168,ST749
	zero	ST4186,ST749
	zero	ST4191,ST749
	zero	ST4196,ST749
	zero	ST4201,ST749
	zero	ST4206,ST749
	equ	LN3908,*-DPDA-ST3908-1
"
" STATE 3959
	equ	ST3959,*-DPDA
	zero	STRD,LN3959
	zero	T15,ST738	"+
	zero	T16,ST739	"-
	equ	LN3959,*-DPDA-ST3959-1
"
" STATE 3962
	equ	ST3962,*-DPDA
	zero	APLY,LN3962
	zero	0,0   pd ld
	zero	-47,1   rule/alt
	zero	10,ST215 prod/val
	zero	ST278,ST864
	zero	ST324,ST914
	zero	ST457,ST988
	zero	ST503,ST1045
	zero	ST504,ST1093
	zero	ST505,ST1141
	zero	ST604,ST1216
	zero	ST732,ST1284
	zero	ST733,ST1335
	zero	ST734,ST1335
	zero	ST811,ST1529
	zero	ST849,ST1581
	zero	ST850,ST1629
	zero	ST851,ST1677
	zero	ST1189,ST1996
	zero	ST1190,ST2044
	zero	ST1203,ST2092
	zero	ST1204,ST2140
	zero	ST1205,ST2188
	zero	ST1206,ST2236
	zero	ST1207,ST2284
	zero	ST1208,ST2332
	zero	ST1209,ST2380
	zero	ST1210,ST2428
	zero	ST1215,ST2484
	zero	ST1264,ST2542
	zero	ST1269,ST2590
	zero	ST1725,ST2675
	zero	ST2654,ST2946
	zero	ST2727,ST2995
	zero	ST2728,ST3045
	zero	ST2729,ST3095
	zero	ST2734,ST3145
	zero	ST2735,ST3195
	zero	ST2740,ST3243
	zero	ST2741,ST3291
	zero	ST2742,ST3339
	zero	ST2789,ST3389
	zero	ST2836,ST3439
	zero	ST2883,ST3489
	zero	ST2942,ST3539
	zero	ST2943,ST3588
	zero	ST3640,ST3696
	zero	ST3645,ST3744
	zero	ST3690,ST3792
	zero	ST3695,ST3840
	equ	LN3962,*-DPDA-ST3962-1
"
" STATE 4012
	equ	ST4012,*-DPDA
	zero	STRD,LN4012
	zero	T9,ST740	":
	zero	T10,ST745	".
	equ	LN4012,*-DPDA-ST4012-1
"
" STATE 4015
	equ	ST4015,*-DPDA
	zero	APLY,LN4015
	zero	0,0   pd ld
	zero	11,2   rule/alt
	zero	5,ST328 prod/val
	zero	ST334,ST972
	equ	LN4015,*-DPDA-ST4015-1
"
" STATE 4020
	equ	ST4020,*-DPDA
	zero	STRD,LN4020
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T9,ST816	":
	zero	T10,ST820	".
	zero	T17,ST824	"<
	zero	T18,ST829	">
	zero	T19,ST833	"=
	zero	T20,ST837	"<=
	zero	T21,ST841	">=
	zero	T22,ST845	"^=
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T52,ST852	"J
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN4020,*-DPDA-ST4020-1
"
" STATE 4076
	equ	ST4076,*-DPDA
	zero	APLYS,LN4076
	zero	0,0   pd ld
	zero	11,1   rule/alt
	zero	5,ST4015 prod/val
	equ	LN4076,*-DPDA-ST4076-1
"
" STATE 4080
	equ	ST4080,*-DPDA
	zero	STRD,LN4080
	zero	T10,ST964	".
	equ	LN4080,*-DPDA-ST4080-1
"
" STATE 4082
	equ	ST4082,*-DPDA
	zero	APLYS,LN4082
	zero	0,0   pd ld
	zero	-17,1   rule/alt
	zero	5,ST4015 prod/val
	equ	LN4082,*-DPDA-ST4082-1
"
" STATE 4086
	equ	ST4086,*-DPDA
	zero	STRD,LN4086
	zero	T11,ST982	":=
	equ	LN4086,*-DPDA-ST4086-1
"
" STATE 4088
	equ	ST4088,*-DPDA
	zero	STRD,LN4088
	zero	T11,ST1265	":=
	equ	LN4088,*-DPDA-ST4088-1
"
" STATE 4090
	equ	ST4090,*-DPDA
	zero	STRDS,ST3959

"
" STATE 4091
	equ	ST4091,*-DPDA
	zero	APLYS,LN4091
	zero	1,1   pd ld
	zero	49,1   rule/alt
	zero	10,ST3962 prod/val
	equ	LN4091,*-DPDA-ST4091-1
"
" STATE 4095
	equ	ST4095,*-DPDA
	zero	STRD,LN4095
	zero	T1,ST385	"<integer>
	zero	T2,ST812	"<string>
	zero	T7,ST457	"(
	zero	T23,ST849	"a[
	zero	T24,ST850	"k[
	zero	T25,ST851	"K[
	zero	T26,ST506	"Ks
	zero	T27,ST510	"be
	zero	T28,ST514	"bn
	zero	T29,ST518	"fl
	zero	T30,ST520	"fs
	zero	T31,ST522	"lb
	zero	T32,ST526	"le
	zero	T33,ST530	"sb
	zero	T34,ST534	"se
	zero	T38,ST544	"dn
	zero	T39,ST548	"en
	zero	T40,ST552	"sn
	zero	T41,ST556	"fak
	zero	T42,ST558	"fka
	zero	T43,ST560	"em
	zero	T44,ST564	"fi
	zero	T45,ST566	"fir
	zero	T46,ST568	"fv
	zero	T47,ST570	"fvr
	zero	T48,ST572	"ff
	zero	T49,ST574	"ffr
	zero	T50,ST576	"fln
	zero	T51,ST578	"sk
	zero	T53,ST582	"Kl
	zero	T54,ST586	"Kb
	zero	T55,ST590	"if
	zero	T57,ST592	"ag
	zero	T58,ST596	"cs
	zero	T60,ST600	"pn
	zero	T61,ST604	"p[
	zero	T62,ST605	"fmx
	zero	T63,ST609	"fmn
	zero	T64,ST613	"frs
	zero	T65,ST859	"||
	zero	T66,ST860	"<var>
	zero	T68,ST681	"mct
	zero	T69,ST683	"emt
	zero	T70,ST685	"emc
	zero	T71,ST687	"<u+>
	zero	T72,ST731	"<u->
	equ	LN4095,*-DPDA-ST4095-1
"
" STATE 4142
	equ	ST4142,*-DPDA
	zero	APLY,LN4142
	zero	1,1   pd ld
	zero	21,1   rule/alt
	zero	6,ST325 prod/val
	zero	ST457,ST1043
	equ	LN4142,*-DPDA-ST4142-1
"
" STATE 4147
	equ	ST4147,*-DPDA
	zero	STRDS,ST4095

"
" STATE 4148
	equ	ST4148,*-DPDA
	zero	APLYS,LN4148
	zero	1,1   pd ld
	zero	22,1   rule/alt
	zero	6,ST4142 prod/val
	equ	LN4148,*-DPDA-ST4148-1
"
" STATE 4152
	equ	ST4152,*-DPDA
	zero	STRDS,ST4095

"
" STATE 4153
	equ	ST4153,*-DPDA
	zero	APLY,LN4153
	zero	0,0   pd ld
	zero	-81,1   rule/alt
	zero	20,ST1332 prod/val
	zero	ST734,ST1384
	equ	LN4153,*-DPDA-ST4153-1
"
" STATE 4158
	equ	ST4158,*-DPDA
	zero	STRDS,ST3904

"
" STATE 4159
	equ	ST4159,*-DPDA
	zero	APLYS,LN4159
	zero	2,2   pd ld
	zero	54,1   rule/alt
	zero	14,ST3908 prod/val
	equ	LN4159,*-DPDA-ST4159-1
"
" STATE 4163
	equ	ST4163,*-DPDA
	zero	STRDS,ST3904

"
" STATE 4164
	equ	ST4164,*-DPDA
	zero	APLYS,LN4164
	zero	2,2   pd ld
	zero	55,1   rule/alt
	zero	14,ST3908 prod/val
	equ	LN4164,*-DPDA-ST4164-1
"
" STATE 4168
	equ	ST4168,*-DPDA
	zero	STRDS,ST4095

"
" STATE 4169
	equ	ST4169,*-DPDA
	zero	APLY,LN4169
	zero	2,2   pd ld
	zero	51,1   rule/alt
	zero	12,ST211 prod/val
	zero	ST457,ST986
	zero	ST1215,ST2482
	equ	LN4169,*-DPDA-ST4169-1
"
" STATE 4175
	equ	ST4175,*-DPDA
	zero	STRDS,ST3959

"
" STATE 4176
	equ	ST4176,*-DPDA
	zero	APLYS,LN4176
	zero	2,2   pd ld
	zero	48,1   rule/alt
	zero	10,ST3962 prod/val
	equ	LN4176,*-DPDA-ST4176-1
"
" STATE 4180
	equ	ST4180,*-DPDA
	zero	STRD,LN4180
	zero	T11,ST2727	":=
	equ	LN4180,*-DPDA-ST4180-1
"
" STATE 4182
	equ	ST4182,*-DPDA
	zero	STRD,LN4182
	zero	T11,ST2728	":=
	equ	LN4182,*-DPDA-ST4182-1
"
" STATE 4184
	equ	ST4184,*-DPDA
	zero	STRD,LN4184
	zero	T11,ST2729	":=
	equ	LN4184,*-DPDA-ST4184-1
"
" STATE 4186
	equ	ST4186,*-DPDA
	zero	STRDS,ST4095

"
" STATE 4187
	equ	ST4187,*-DPDA
	zero	APLYS,LN4187
	zero	3,3   pd ld
	zero	52,1   rule/alt
	zero	12,ST4169 prod/val
	equ	LN4187,*-DPDA-ST4187-1
"
" STATE 4191
	equ	ST4191,*-DPDA
	zero	STRDS,ST4095

"
" STATE 4192
	equ	ST4192,*-DPDA
	zero	APLYS,LN4192
	zero	2,2   pd ld
	zero	82,1   rule/alt
	zero	20,ST4153 prod/val
	equ	LN4192,*-DPDA-ST4192-1
"
" STATE 4196
	equ	ST4196,*-DPDA
	zero	STRDS,ST4095

"
" STATE 4197
	equ	ST4197,*-DPDA
	zero	APLYS,LN4197
	zero	4,4   pd ld
	zero	18,1   rule/alt
	zero	6,ST4142 prod/val
	equ	LN4197,*-DPDA-ST4197-1
"
" STATE 4201
	equ	ST4201,*-DPDA
	zero	STRDS,ST4095

"
" STATE 4202
	equ	ST4202,*-DPDA
	zero	APLYS,LN4202
	zero	4,4   pd ld
	zero	19,1   rule/alt
	zero	6,ST4142 prod/val
	equ	LN4202,*-DPDA-ST4202-1
"
" STATE 4206
	equ	ST4206,*-DPDA
	zero	STRDS,ST4095

"
" STATE 4207
	equ	ST4207,*-DPDA
	zero	APLYS,LN4207
	zero	4,4   pd ld
	zero	20,1   rule/alt
	zero	6,ST4142 prod/val
	equ	LN4207,*-DPDA-ST4207-1
	equ	DPDAs,*-DPDA


	zero	0,0	"SKIP/ADJ
	end
 



		    ted_gv_t_.alm                   11/23/82  1129.5rew 11/22/82  1533.5       57987


" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
	segdef	TC
	segdef	TL
	segdef	DPDA
	equ	STRD,0
	equ	LOOK,1
	equ	STRDS,2
	equ	LOOKS,3
	equ	APLY,4
	equ	APLY1,5
	equ	APLYS,6
	equ	SKIP,7
	equ	ADJUST,8
	equ	NSRD,9
	equ	NSRDS,10
	equ	T0,0
	equ	ST0,0
"
"
" TERMINALS table (TL TC)
"
	use	utc
TC:	zero	0,TCs*4
	use	utl
TL:	zero	0,TLs
"
" TERMINAL 1
	use	utc
	set	Tsl,*-TC-1
	aci	"g*  "
	use	utl
	equ	T1,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 2
	use	utc
	set	Tsl,*-TC-1
	aci	"v*  "
	use	utl
	equ	T2,*-TL
	zero	Tsl*4+1,2
"
" TERMINAL 3
	use	utc
	set	Tsl,*-TC-1
	aci	"(   "
	use	utl
	equ	T3,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 4
	use	utc
	set	Tsl,*-TC-1
	aci	"^   "
	use	utl
	equ	T4,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 5
	use	utc
	set	Tsl,*-TC-1
	aci	"|   "
	use	utl
	equ	T5,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 6
	use	utc
	set	Tsl,*-TC-1
	aci	"&   "
	use	utl
	equ	T6,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 7
	use	utc
	set	Tsl,*-TC-1
	aci	")   "
	use	utl
	equ	T7,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 8
	use	utc
	set	Tsl,*-TC-1
	aci	"    "
	use	utl
	equ	T8,*-TL
	zero	Tsl*4+1,1
"
" TERMINAL 9
	use	utc
	set	Tsl,*-TC-1
	aci	"X   "
	use	utl
	equ	T9,*-TL
	zero	Tsl*4+1,1
"
	use	utc
	equ	TCs,"-TC-1
	use	utl
	equ	TLs,*-TL-1

	use	text
"
"
" DPDA table
DPDA:	zero	0,DPDAs
"
" STATE 1
	equ	ST1,*-DPDA
	zero	STRD,LN1
	zero	T1,ST10	"g*
	zero	T2,ST15	"v*
	equ	LN1,*-DPDA-ST1-1
"
" STATE 4
	equ	ST4,*-DPDA
	zero	APLY1,LN4
	zero	0,0   pd ld
	zero	-1,1   rule/alt
	zero	1,ST8 prod/val
	equ	LN4,*-DPDA-ST4-1
"
" STATE 8
	equ	ST8,*-DPDA
	zero	STRD,LN8
	zero	T0,ST0	"EOI
	equ	LN8,*-DPDA-ST8-1
"
" STATE 10
	equ	ST10,*-DPDA
	zero	STRD,LN10
	zero	T3,ST37	"(
	zero	T4,ST38	"^
	zero	T8,ST41	"
	zero	T9,ST45	"X
	equ	LN10,*-DPDA-ST10-1
"
" STATE 15
	equ	ST15,*-DPDA
	zero	STRD,LN15
	zero	T3,ST37	"(
	zero	T4,ST38	"^
	zero	T9,ST45	"X
	equ	LN15,*-DPDA-ST15-1
"
" STATE 19
	equ	ST19,*-DPDA
	zero	APLY,LN19
	zero	0,0   pd ld
	zero	-11,1   rule/alt
	zero	6,ST24 prod/val
	zero	ST53,ST70
	equ	LN19,*-DPDA-ST19-1
"
" STATE 24
	equ	ST24,*-DPDA
	zero	APLY,LN24
	zero	0,0   pd ld
	zero	-9,1   rule/alt
	zero	5,ST29 prod/val
	zero	ST54,ST74
	equ	LN24,*-DPDA-ST24-1
"
" STATE 29
	equ	ST29,*-DPDA
	zero	NSRD,LN29
	zero	T5,-ST85	"|
	zero	T6,-ST83	"&
	zero	T7,-ST85	")
	zero	T8,-ST85	"
	equ	LN29,*-DPDA-ST29-1
"
" STATE 34
	equ	ST34,*-DPDA
	zero	STRD,LN34
	zero	T5,ST54	"|
	zero	T8,ST55	"
	equ	LN34,*-DPDA-ST34-1
"
" STATE 37
	equ	ST37,*-DPDA
	zero	STRDS,ST15

"
" STATE 38
	equ	ST38,*-DPDA
	zero	STRD,LN38
	zero	T3,ST37	"(
	zero	T9,ST45	"X
	equ	LN38,*-DPDA-ST38-1
"
" STATE 41
	equ	ST41,*-DPDA
	zero	APLY1,LN41
	zero	1,1   pd ld
	zero	4,1   rule/alt
	zero	3,ST4 prod/val
	equ	LN41,*-DPDA-ST41-1
"
" STATE 45
	equ	ST45,*-DPDA
	zero	APLY,LN45
	zero	0,0   pd ld
	zero	-12,1   rule/alt
	zero	7,ST19 prod/val
	zero	ST38,ST62
	equ	LN45,*-DPDA-ST45-1
"
" STATE 50
	equ	ST50,*-DPDA
	zero	STRD,LN50
	zero	T5,ST54	"|
	zero	T8,ST66	"
	equ	LN50,*-DPDA-ST50-1
"
" STATE 53
	equ	ST53,*-DPDA
	zero	STRDS,ST15

"
" STATE 54
	equ	ST54,*-DPDA
	zero	STRDS,ST15

"
" STATE 55
	equ	ST55,*-DPDA
	zero	APLY1,LN55
	zero	2,2   pd ld
	zero	3,1   rule/alt
	zero	3,ST4 prod/val
	equ	LN55,*-DPDA-ST55-1
"
" STATE 59
	equ	ST59,*-DPDA
	zero	STRD,LN59
	zero	T5,ST54	"|
	zero	T7,ST79	")
	equ	LN59,*-DPDA-ST59-1
"
" STATE 62
	equ	ST62,*-DPDA
	zero	APLYS,LN62
	zero	1,1   pd ld
	zero	10,1   rule/alt
	zero	6,ST19 prod/val
	equ	LN62,*-DPDA-ST62-1
"
" STATE 66
	equ	ST66,*-DPDA
	zero	APLY1,LN66
	zero	2,2   pd ld
	zero	5,1   rule/alt
	zero	3,ST4 prod/val
	equ	LN66,*-DPDA-ST66-1
"
" STATE 70
	equ	ST70,*-DPDA
	zero	APLYS,LN70
	zero	2,2   pd ld
	zero	8,1   rule/alt
	zero	5,ST24 prod/val
	equ	LN70,*-DPDA-ST70-1
"
" STATE 74
	equ	ST74,*-DPDA
	zero	NSRD,LN74
	zero	T5,-ST93	"|
	zero	T6,-ST91	"&
	zero	T7,-ST93	")
	zero	T8,-ST93	"
	equ	LN74,*-DPDA-ST74-1
"
" STATE 79
	equ	ST79,*-DPDA
	zero	APLYS,LN79
	zero	2,2   pd ld
	zero	13,1   rule/alt
	zero	7,ST45 prod/val
	equ	LN79,*-DPDA-ST79-1
"
" STATE 83
	equ	ST83,*-DPDA
	zero	STRD,LN83
	zero	T6,ST53	"&
	equ	LN83,*-DPDA-ST83-1
"
" STATE 85
	equ	ST85,*-DPDA
	zero	APLY,LN85
	zero	0,0   pd ld
	zero	-7,1   rule/alt
	zero	4,ST34 prod/val
	zero	ST15,ST50
	zero	ST37,ST59
	equ	LN85,*-DPDA-ST85-1
"
" STATE 91
	equ	ST91,*-DPDA
	zero	STRD,LN91
	zero	T6,ST53	"&
	equ	LN91,*-DPDA-ST91-1
"
" STATE 93
	equ	ST93,*-DPDA
	zero	APLYS,LN93
	zero	2,2   pd ld
	zero	6,1   rule/alt
	zero	4,ST85 prod/val
	equ	LN93,*-DPDA-ST93-1
	equ	DPDAs,*-DPDA


	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ

	zero	0,0	"SKIP/ADJ
	end
 



		    tedaddr_.pl1                    05/02/89  1148.8rew 05/02/89  1042.1      347346


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-08-03,RWaters), approve(88-08-03,MCR7950), audit(88-09-29,Huen),
     install(88-10-07,MR12.2-1146):
     Bug fixes for MR12.2.
  2) change(89-03-29,Huen), approve(89-03-29,MCR8062), audit(89-04-25,JRGray),
     install(89-05-02,MR12.3-1037):
     Fix bug 205: Modify ted not to complain that "." is undefined unless there
     is an attempt to reference it.
                                                   END HISTORY COMMENTS */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

/*							       */
/*   _|_              |             |      |			       */
/*    |      _      _ |   ___     _ |    _ |    _			       */
/*    |     / \    / \|   ___\   / \|   / \|  |/ \		       */
/*    |    (__/   (   |  /   |  (   |  (   |  |			       */
/*    \_    \_/    \_/|  \__/|   \_/|   \_/|  |			       */
/*                                                   -----		       */
/*							       */

/* tedaddr_ .......... subroutine to find address portion of ted request    */
/*  and locate addressed line in buffer				       */

/**** <<<<----- dcl_tedaddr_.incl.pl1 tedaddr_			       */
tedaddr_:				/* process request addresses	       */
   proc (adb_p, ain_p, ain_l, abp, msg, acode);
dcl (
    adb_p		ptr,		/* -> database		       */
    ain_p		ptr,		/* -> string containing address      */
    ain_l		fixed bin (21),	/*   length of it		  [IN] */
				/* If <0 then recursive call	       */
				/*   how much was used up	 [OUT] */
    abp		ptr,		/* -> buffer control block  [IN/OUT] */
    msg		char (168) var,	/* place to hold err message if any  */
    acode		fixed bin (35)	/* status code		       */
				/*   0- null address	       */
				/*   1- address found	       */
				/*   8- error, msg tells what	       */
    )		parm;		/* ----->>>>		       */

/*    req_addr			     request address format	       */
/*             ::= {@bufname,}{address}	     optional buffer spec	       */
/*							       */
/*    address			     basic address format	       */
/* 	     ::= {prefix}...addr				       */
/*							       */
/*    prefix			     conditional address process     */
/* 	     ::= ? gadr ,		       see NOTE 1		       */
/*               | ? gadr ;		       see NOTE 2		       */
/*							       */
/*    addr						       */
/* 	     ::= gadr		     single address		       */
/*               | gadr , gadr	     range, see NOTE 1	       */
/*               | gadr ; gadr	     range, see NOTE 2	       */
/*               | adr ( adr , adr )	     byte range, see NOTE 1	       */
/*               | adr ( adr ; adr )	     byte range, see NOTE 2	       */
/*               |   0 ( adr , adr )	     buffer range, see NOTE 1	       */
/*               |   0 ( adr ; adr )	     buffer range, see NOTE 2	       */
/*							       */
/*    gadr						       */
/* 	     ::= adr		     line address		       */
/*               | adr ( adr )	     line/byte address	       */
/*               |   0 ( adr )	     buffer address		       */
/*							       */
/*    adr							       */
/* 	     ::= num		     absolute line number	       */
/*               | num adrr		       with additional parts	       */
/*               |     adrr		     (just additional parts)	       */
/*							       */
/*    adrr			     additional parts	       */
/* 	     ::= rel		     relative line number	       */
/*               | num		     non-initial number is +rel      */
/*               | fwd		     forward regexp search	       */
/*               | bwd		     backward regexp search	       */
/*               | .		     curline		       */
/*               | $		     last line		       */
/*               | \l		     enter line mode	       */
/*               | \s		     enter string mode	       */
/*							       */
/*    rel							       */
/* 	     ::= + num		     forward relative	       */
/*               | . num		       (same)		       */
/*               | - num		     backward relative	       */
/*							       */
/*    fwd				     forward search		       */
/* 	     ::= / regexp /		       wrap-around, next line to     */
/*				       end of buffer, then beginning */
/* 			                 of buffer to curline	       */
/*               | [ address ] / regexp /      restricted range, beginning   */
/* 				       to end of addressed area      */
/*							       */
/*    bwd				     backward search	       */
/* 	     ::= </ regexp /	     curloc to begin buffer	       */
/*               | [ address ] </ regexp /   end to begin of addressed area  */
/*							       */
/* NOTE 1: when 2 address syllables are separated by a comma, this means     */
/*  that the second address uses the same initial location as the first one. */
/*							       */
/* NOTE 2: when 2 address syllables are separated by a semicolon, this       */
/*  means that the second address uses the result of the first as its	       */
/*  beginning location.					       */

/* UPDATE HISTORY (finally)					       */
/* EL#   date	TR	comments				       */
/* 138 84-10-08 phx16962 pass failure of tedsrch_$compile back	       */
/* 144 84-10-09 phx17335 "Addr- after buffer" in byte mode in mid-buffer     */
/* 195 88-08-07 phx19783,19787 Motion relative to '.' illegal if '.' is      */
/*	undefined                                                          */
/* 205 89-01-20 phx21225 ted should not complain that "." is undefined       */
/*        unless there is an attempt to reference it.      		       */

dcl 1 ca_		based (ca__p) like b.a_; /* current address	       */

dcl next_in	fixed bin;	/* where at in address data	       */
dcl in_p		ptr;		/* -> address data		       */
dcl in_l		fixed bin;	/*   length of it		       */
dcl in_s		char (in_l) based (in_p); /* data as a string	       */
dcl in_c		(in_l) char (1) based (in_p); /* data as an array      */

/**** data refering to the string being searched			       */
dcl file_str	char (last_file_char) based (b.cur.sp);
dcl first_file_char fixed bin (21);
dcl next_file_char	fixed bin (21);
dcl last_file_char	fixed bin (21);
dcl in_part_2	bit (1);		/* which part of file are we in      */

dcl adr_num	fixed bin;
dcl all_buffer	bit (1);
dcl bkp_sw	bit (1);
dcl ca__p		ptr;
dcl ch		char (1);
dcl code		fixed bin (35);
dcl concealsw	bit (1);
dcl delim		char (1);
dcl dot_sw	bit (1);
dcl end_sw	bit (1);
dcl expr_l	fixed bin (21);
dcl i		fixed bin (21);
dcl line_sw	bit (1);
dcl negsw		bit (1);
dcl num		fixed bin (21);
dcl possw		bit (1);
dcl q_sw		bit (1);
dcl recurring	bit (1);
dcl reg_sw	bit (1);
dcl relsw		bit (1);
dcl srb1		fixed bin (21);
dcl srb2		fixed bin (21);
dcl sre1		fixed bin (21);
dcl sre2		fixed bin (21);
dcl start_scan	fixed bin (21);
dcl string_sw	bit (1) defined (b.present (0));
dcl tbp		ptr;
dcl used		fixed bin (21);

dcl NL		char (1) int static init ("
");

dcl ioa_		entry options (variable);
dcl ioa_$ioa_switch entry () options (variable);
dcl ioa_$ioa_switch_nnl entry () options (variable);


dcl (
    addr, fixed, index, null, reverse, substr, verify
    )		builtin; %page;
      dbase_p = adb_p;
      bp = abp;			/* "current" buffer		       */
      in_part_2 = ""b;
      in_p = ain_p;
      if (ain_l < 0)
      then do;
         ain_l = -ain_l;
         recurring = "1"b;
      end;
      else recurring = ""b;
      in_l = ain_l;
      next_in = 1; %skip (2);
      if db_addr
      then call ioa_$ioa_switch (db_output,
	      "addr: in=^p,^i ""^a"" b(^a)", /* ^/^-pfnl=part|first,next,last",   */
	      ain_p, ain_l, substr (in_s, 1, in_l - 1), b.name);
      if (in_c (next_in) = "@")	/* explicit buffer specification?    */
      then do;
         next_in = next_in + 1;
         used = in_l - next_in + 1;
         call tedget_buffer_ (adb_p, addr (in_c (next_in)),
	    used, tbp, msg);
         next_in = next_in + used;
         if (tbp = null ())		/* did not find that buffer	       */
         then do;
	  acode = 8;
	  return;
         end;
         bp = tbp;			/* change reference to that buffer   */
         next_in = next_in		/* skip SPs		       */
	    + verify (substr (in_s, next_in), " ") - 1;
         if (in_c (next_in) ^= ",")	/* no address following?	       */
         then do;			/*   just point to specified buffer  */
	  q_sw = "1"b;
	  b.present (1), b.present (2) = ""b;
	  acode = 0;
	  goto finished;
         end;
         next_in = next_in + 1;	/* skip over the comma	       */
      end; %skip (3);
      adr_num = 1;			/* prepare for 1st address	       */
      b.a_.r.ln (1), b.a_.r.ln (2) = -1;
      ca__p = addr (b.a_ (1));
q_comma:				/* begin at "."		       */
      b.a_ (1) = b.a_ (0);
q_semi:
      b.present (1), b.present (2) = ""b;
      acode = 0;			/* indicate null addr	       */

line2:				/* continue on 2nd line address      */
      line_sw = "1"b;		/* in line addr		       */
      all_buffer = "0"b;		/* not addressing whole buffer       */
      reg_sw = "0"b;		/* no byte regexp just finished      */
byte2:				/* continue on 2nd byte address      */
      start_scan = 0;		/* scan is not started	       */
      end_sw = "0"b;		/* address is not finished	       */
      q_sw = "0"b;			/* prefix not in effect	       */
      relsw = "0"b;			/* absolute numerics	       */
      negsw = "0"b;			/* not "-"		       */
      possw = "0"b;			/* not "+"		       */
      dot_sw = "0"b;		/* not "."		       */
      goto scan2;			/* begin (or resume) scan of input   */

a_line:
      ca_.l.re = ca_.l.le;
      ca_.r.le = ca_.r.re;		/* set string to full line	       */
scan:				/* actually found some address       */
      acode = 1;			/* resume scan		       */
      b.present (adr_num) = "1"b;	/* current address (1|2) is present  */
      relsw = "1"b;			/* any more numbers are relative     */
scan0:				/* begin prefix or byte addr	       */
      if (start_scan = 0)		/* keep where this scan started      */
      then start_scan = next_in;
scan1:
      next_in = next_in + 1;		/* bump source char index	       */
scan2:
      if db_addr
      then call ioa_$ioa_switch_nnl (db_output,
	      """^1a""(^i)", in_c (next_in), next_in);

      if (next_in > in_l)		/* check for end of line	       */
      then do;			/* OPPS, went too far	       */
         next_in = in_l;		/* bring it back in line	       */
err_Amn:
         msg = "Amn) No NL.";
add_err_8:
         acode = 8;			/* error found		       */
add_err_text:
         if recurring
         then goto fail;
         if (start_scan = 0)		/* didnt capture start point,        */
         then start_scan = next_in;	/* so force it in		       */
         msg = msg || " """;
         msg = msg || substr (in_s, start_scan, next_in - start_scan + 1);
         msg = msg || """";
         goto fail;
      end;
      ch = in_c (next_in);		/* pick up next char from input line */
      if db_addr
      then call ioa_$ioa_switch (db_output,
	      "^-a^d:^[,rel^]^[,pos^]^[,neg^]", adr_num, relsw, possw, negsw);

      if (ch = " ") then goto scan1;	/* ignore blanks at this level       */
      if ^end_sw
      then do;
         if (ch = "/") then goto reg;	/* start of regular expression       */
/**** A special case exists so that (/abc/////) will find the 3rd occrrance  */
/****  but will also be able to find the abc beginning in col 1.	       */
/**** A TR complained about (/,/;//) giving a single character result,       */
/****  so we make this special case carry over the ";".		       */
         if (ch ^= ";")
         then reg_sw = "0"b;		/*   not regexp		       */
         if (ch = "$") then goto last;	/* "$" goto end of input file	       */
         if (ch = "-") then goto neg;	/* "-" note minus sign seen	       */
         if (ch = "+") then goto pos;	/* "+" note plus sign seen	       */
         if (ch >= "0") & (ch <= "9") then goto get_num;
         if (ch = "[") then goto limit; /* search limiting		       */
         if (ch = "?")		/* prefix			       */
         then do;
	  if b.present (1)		/* already been an address	       */
	  then goto err_Ad1;	/*   so this is an error	       */
	  q_sw = "1"b;
	  goto scan0;		/* go get the prefix	       */
         end;
         if ^line_sw		/* in byte addr		       */
         then do;
	  if (ch = ".")
	  then do;
	     if relsw
	     then do;
err_Ad1:
	        msg = "Ad1) . $ ? Can only appear first.";
	        goto add_err_8;
	     end;
	     dot_sw = "1"b;
	     goto scan;
	  end;
	  if (ch = ")")		/* end byte address		       */
	  then do;
	     if negsw | possw	/* ### number missing	       */
	     then goto err_Anm;
	     line_sw = "1"b;	/* back in line address	       */
	     end_sw = "1"b;		/* however, this one finished	       */
	     goto scan1;
	  end;
	  if (ch = ",") | (ch = ";")	/* byte address separator	       */
	  then do;
	     if q_sw		/* cant use this form in byte addr   */
	     then goto err_Aqe;
	     if negsw | possw	/* ### number missing	       */
	     then goto err_Anm;
	     if (adr_num = 2)	/* ### already done 2nd?	       */
	     then goto only_2;
	     if ^b.present (1)	/* ### left out 1st one?	       */
	     then goto err_Aa1;
	     next_in = next_in + 1;	/* skip the separator	       */
	     adr_num = 2;		/* start 2nd address	       */
	     ca__p = addr (b.a_.l (2)); /* begin 2nd where 1st left off */
	     b.a_ (2) = b.a_ (1);
	     if (ch = ",")		/* except if comma then go back to   */
	     then do;		/*   beginning of line	       */
	        b.a_.l.re (2) = b.a_.l.le (2);
	        b.a_.r.le (2) = b.a_.r.re (2);
	     end;
	     b.present (2) = "0"b;	/* no address found		       */
	     goto byte2;
	  end;
	  msg = "Abc) Bad char in byte addr.";
	  goto add_err_8;
         end;
         else do;			/* in line address		       */
	  if negsw | possw		/* ### number missing	       */
	  then goto err_Anm;
	  if (ch = ".")		/* current line ref		       */
	  then do;
	     if q_sw & (ca_.r.le = 0) /* prefix and undefined "."	       */
	     then goto q_fail;	/* then let him know by failing      */
	     if relsw
	     then goto err_Ad1;	/* dot only allowed first	       */
	     dot_sw = "1"b;
	     goto a_line;
	  end;
	  if (ch = "(")		/* begin byte | buffer addr?	       */
	  then do;
	     relsw, dot_sw, line_sw = "0"b;
	     goto scan0;
	  end;
	  if (ch = "<")		/* backup search		       */
	  then goto backup;
         end;
      end;
      if negsw | possw		/* ### number missing	       */
      then goto err_Anm;
      if (ch = ",") | (ch = ";")	/* line address separator	       */
      then do;
         if (adr_num = 2)		/* already done 2 of em?	       */
         then do;
only_2:
	  msg = "Ao2) Only 2 addr allowed.";
	  goto add_err_8;
         end;
         if ^b.present (1)		/* any 1st one there?	       */
         then goto err_Aa1;
         next_in = next_in + 1;	/* skip over separator	       */
         if (ca_.l.re < b.b_.l.le)	/* before beginning?	       */
	    | (ca_.r.le > b.b_.r.re)	/* ...after end		       */
         then goto q_fail;		/* too bad!		       */
         if q_sw			/* just finish up a prefix?	       */
         then do;
	  q_sw = "0"b;		/* turn off prefix flag	       */
	  if (ch = ",")
	  then goto q_comma;
	  goto q_semi;
         end;
         ca__p = addr (b.a_ (2));	/* point to 2nd result	       */
         if (ch = ",")		/* comma means		       */
         then adr_num = 0;		/* use same starting location	       */
         else adr_num = 1;		/* use updated location	       */
         ca_ = b.a_ (adr_num);	/* set "." value for next address    */
         b.present (2) = "0"b;	/* havent found 2nd one yet	       */
         adr_num = 2;		/* begining 2nd address	       */
         goto line2;
      end;

      if (ch = "\")
      then do;
         ch = in_c (next_in + 1);
         if (ch = "s")
         then do;
	  string_sw = "1"b;
	  next_in = next_in + 1;
	  goto scan1;
         end;
         if (ch = "l")
         then do;
	  string_sw = "0"b;
	  next_in = next_in + 1;
	  goto scan1;
         end;
      end;

finished:
      ain_l = next_in - 1;
      if q_sw			/* end in prefix?		       */
      then b.present (1) = "0"b;	/* then no effective address	       */
      if db_addr
      then do;
         call ioa_$ioa_switch (db_output,
	    """^1a""(^i) b(^a)", in_c (ain_l), ain_l, b.name);
         call tedshow_ (bp, ". adr a0 a1 a2");
      end;
      abp = bp;			/* tell him buffer we worked on      */
      return;			/* normal return to caller	       */
				/* (acode = 0, 1 or 2)	       */

q_fail:				/* "non-failing" failure	       */
      b.present (1), b.present (2) = "0"b;
      next_in = ain_l + 1;		/* throw away rest of line	       */
fail:				/* here on any other failure	       */
      ain_l = next_in - 1;
      return;
%page;
limit:				/* limit range of a search expr      */
      if negsw | possw		/* ### number missing	       */
      then goto err_Anm;
      if (start_scan = 0)
      then start_scan = next_in;
      next_in = next_in + 1;		/* skip over the [		       */
      if (in_c (next_in) = "@")	/* TRYING TO REF OTHER BUFFER HERE?  */
      then do;
         msg = "Misplaced @.";	/* no you dont!		       */
         goto add_err_8;
      end;
      b.rel_temp = b.a_;		/* keep the current address data     */
      if b.present (1)		/* WHAT TO DO?		       */
      then do;
         b.a_ (0) = ca_;
      end;
      apr (1) = b.present (1);
      apr (2) = b.present (2);
dcl apr		(2) bit (1);
      used = -(in_l - next_in + 1);	/* <0 flags recursive entry	       */
      call tedaddr_ (adb_p, addr (in_c (next_in)), used, bp, msg, acode);
      next_in = next_in + used;
      if (acode = 8)
      then do;
         if q_sw
         then goto q_fail;
         goto add_err_text;
      end;
      if (in_c (next_in) ^= "]")	/* next thing up must be the closer  */
      then do;
         msg = "Anb) Missing ].";
         goto add_err_8;
      end;
      next_in = next_in + 1;		/* skip over "]", then SPs	       */
      next_in = next_in + verify (substr (in_s, next_in), " ") - 1;
      if b.present (1)
      then do;
         b.a_ (0) = b.a_ (1);
         if b.present (2)
         then b.a_.r (0) = b.a_.r (2);
      end;
      b.present (1) = apr (1);
      b.present (2) = apr (2);
      ch = in_c (next_in);
      if (ch = "<")
      then do;
         srb1 = 0;			/* must look at last line	       */
         srb2 = b.a_.l.le (0);
         sre2 = b.a_.r.re (0);
         b.a_ = b.rel_temp;		/* restore old address data	       */
         ca_.l.le = sre2;
         goto backup_limit;
      end;
      if (ch = "/")
      then do;
         srb1 = b.a_.l.re (0);
         sre1 = b.a_.r.le (0);
         srb2, sre2 = 0;
         b.a_ = b.rel_temp;		/* restore old address data	       */
         goto reg_limit;
      end;

      msg = "Invalid char follows [...].";
      goto add_err_8; %page;
backup:
      if negsw | possw
      then goto err_Anm;
      srb1 = -1;			/* do not look at cur line	       */
      srb2 = b.b_.l.le;
      sre2 = ca_.l.le;
backup_limit:
      next_in = next_in + 1;
      delim = in_c (next_in);
      bkp_sw = "1"b;
      goto scan_reg; %skip (2);
reg:
      if negsw | possw		/* ### number missing	       */
      then goto err_Anm;
      srb1 = ca_.r.le + 1;		/* from here to buffer end	       */
      sre1 = b.b_.r.re;
      srb2 = b.b_.l.le;		/* then from buffer begin to here    */
      sre2 = ca_.r.le;
reg_limit:
      delim = "/";
      bkp_sw = "0"b; %skip (2);
scan_reg:
      b.rel_temp = tedcommon_$no_data;
      if (b.cur.sn = 0)
      then goto buffer_empty;
      if (start_scan = 0)
      then start_scan = next_in;
      i = next_in + 1;		/* here after "/" found, look for    */
				/*  regular expression	       */
      concealsw = "0"b;
      do next_in = i to in_l;
         if concealsw
         then concealsw = "0"b;
         else do;
	  ch = in_c (next_in);
	  if (ch = delim)
	  then goto reg1;
	  if (ch = "")		/* is this \031 ?		       */
	  then concealsw = "1"b;
	  if (ch = "\")
	  then do;
	     if (in_c (next_in + 1) = "c")
		| (in_c (next_in + 1) = "C")
	     then do;
	        next_in = next_in + 1;
	        concealsw = "1"b;
	     end;

	  end;
         end;
      end;
      msg = "Ad2) No 2nd delimiter.";
      acode = 8;
      goto fail;

reg1:
      expr_l = next_in - i;		/*  length of regular expression     */

      if (expr_l > 0)
      then do;
         call tedsrch_$compile (addr (in_c (i)), expr_l, addr (dbase.regexp),
	    (string_sw), (dbase.lit_sw), msg, code);
         if (code ^= 0)
         then do;			/* #138*/
	  acode = code;		/* #138*/
	  goto fail;		/* #138*/
         end;			/* #138*/
      end;
				/** b.newa = b.b_; */
      if bkp_sw
      then goto bkp1;
      if ^line_sw
      then goto creg;
      if (srb1 < 1)			/* undefined ".", search whole thing */
      then do;
         srb1 = b.b_.l.le;
         sre1 = b.b_.r.re;
         sre2 = 0;
      end;
      call tedsrch_$search (addr (dbase.regexp), bp,
	 srb1, sre1, ca_.l.re, ca_.r.le, 0,
	 msg, code);
				/* try to match expression, pass 1   */
      if (code = 1) & (sre2 > 0)
      then call tedsrch_$search (addr (dbase.regexp), bp,
	      srb2, sre2, ca_.l.re, ca_.r.le, 0,
	      msg, code);
				/* try to match expression, pass 2   */
      if (code ^= 0)
      then do;			/* error if match failed on 2nd pass */
         if (code = 2)
         then do;
	  acode = 8;
	  goto fail;
         end;
         if q_sw
         then goto q_fail;
         msg = "Als) Line search failed.";
         acode = 2;
         goto add_err_text;
      end;

      call find_line (0);		/* isolate /.../ line	       */
      if line_sw
      then goto a_line;
      goto scan;

bkp1:				/* what if "." undefined?	       */
      ca_.l.re, ca_.r.le = ca_.l.le;
      do while (ca_.l.le > srb2);
         call find_line (srb1);	/* may go 0 or -1 the first time     */
         srb1 = -1;			/*  make sure any more go -1	       */
         call tedsrch_$search (addr (dbase.regexp), abp,
	    ca_.l.le, ca_.r.re, ca_.l.re, ca_.r.le, 0, msg, code);
         if (code = 0)
         then do;
	  if line_sw
	  then goto a_line;
	  goto scan;
         end;
         if (code ^= 1)
         then do;
	  acode = 8;
	  goto fail;
         end;
         expr_l = 0;
         ca_.l.re, ca_.r.le = ca_.l.le;
      end;
      if q_sw
      then goto q_fail;
      msg = "Abs) Backup search failed.";
      acode = 2;
      goto add_err_text;

last:				/* $ found		       */
      if negsw | possw
      then goto err_Anm;
      if relsw
      then goto err_Ad1;
      if ^line_sw
      then do;			/* CHAR - last, i.e. the NL	       */
         if all_buffer		/* if referencing all of buffer      */
         then ca_.r.re = b.b_.r.re;	/*  then give him last char thereof  */
         if (ca_.r.re = -1)
         then do;
err_Adn:
	  msg = "A.n) ""."" undefined.";
	  goto add_err_8;
         end;
         if (b_c (ca_.r.re) = NL)	/* is there a NL on EOL?	       */
         then ca_.l.re, ca_.r.le = ca_.r.re; /*  point to it	       */
         else ca_.l.re, ca_.r.le = ca_.r.re + 1; /*  point where it should be*/
         goto scan;			/* continue scan		       */
      end;
      if (b.cur.sn = 0)
      then goto scan;		/* "$" found, find last line	       */
      if (b.b_.r.re + 1 = b.b_.r.le)	/* upper part empty		       */
      then ca_.r.le = b.b_.l.re;
      else ca_.r.le = b.b_.r.re;
      ca_.l.re = ca_.r.le;
      ca_.l.ln, ca_.r.ln = b.b_.r.ln;
      call find_line (0);		/* isolate $ line		       */
      goto a_line;			/* resume line addr		       */

neg:
      if possw | negsw
      then do;
err_Anm:
         msg = "Amn) Missing number value.";
         goto add_err_8;
      end;
      dot_sw = "0"b;
      negsw = "1"b;			/* "-" found, note minus sign seen   */

/* RW 88: bug 195 */
/* If we are attempting to reference a relative address, '.' MUST be defined
 * command sequences such as  "$d; -1" have 1 address, but a_(0) is undefined
   SH 89: bug 205
   Complain '.' is undefined only when there is an attempt to reference it
 */
      if (b.a_.r.re (0) = -1) & (ca_.r.re = -1) /*# 205 */
      then do;			/*# 205 */
         msg = "A.u) ""."" undefined."; /*# 205 */
         goto add_err_8;		/*# 205 */
      end;			/*# 205 */

      goto scan;			/*  continue addr scan	       */


pos:
      if possw | negsw
      then goto err_Anm;
      dot_sw = "0"b;
      possw = "1"b;			/* "+" found, note plus sign seen    */

/* RW 88: bug 195 */
/* If we are attempting to reference a relative address, '.' MUST be defined
 * command sequences such as  "$d; -1" have 1 address, but a_(0) is undefined
   SH 89: bug 205
   Complain '.' is undefined only when there is an attempt to reference it
 */
      if (b.a_.r.re (0) = -1) & (ca_.r.re = -1) /*# 205 */
      then do;			/*# 205 */
         msg = "A.u) ""."" undefined."; /*# 205 */
         goto add_err_8;		/*# 205 */
      end;			/*# 205 */

      goto scan;			/*  continue addr scan	       */ %page;
get_num:
      if (start_scan = 0)
      then start_scan = next_in;
      i = verify (substr (in_s, next_in), "0123456789") - 1;
      num = fixed (substr (in_s, next_in, i));
      next_in = next_in + i - 1;
				/* allow zero even if buffer empty   */
      if (b.cur.sn = 0) & ((num ^= 0) | relsw | ^line_sw)
      then goto buffer_empty;
      if dot_sw			/* back by popular demand:	       */
      then do;			/* i.e.  .35 -> +35		       */
         dot_sw = "0"b;
         possw = "1"b;
      end;
      if line_sw
      then do;
         if ^relsw
         then do;
         /*** see if we know any locations near here		       */
	  do i = 1 to 2;
	  end;
         end;
         if ^relsw			/* absolute line number	       */
         then do;			/* begin at left end	       */
	  if (b.b_.l.le - 1 = b.b_.l.re) /* is lower part empty?	       */
	  then ca_.l.le = b.b_.r.le;	/* YES, use upper		       */
	  else ca_.l.le = b.b_.l.le;	/*  NO, use lower		       */
	  if (num = 0)		/* line "0" is a special case	       */
	  then do;
	     all_buffer = "1"b;
	     ca_.r.re = ca_.l.le - 1; /* undefined location	       */
	  end;
	  else do;
	     ca_.l.re, ca_.r.le = ca_.l.le;
	     ca_.r.ln = 1;		/* -> beginning of buffer	       */
	     call find_line (num - 1);/* move ahead necessary amount      */
	  end;
         end;
         else do;			/* relative line number	       */
	  if (ca_.r.re = -1)	/* undefined?		       */
	  then ca_.r.le, ca_.r.re = ca_.l.le;
	  else ca_.r.le = ca_.r.re;
	  ca_.l.re = ca_.l.le;
	  if negsw
	  then num = -num;
	  else if ^possw
	  then do;
err_Axn:
	     msg = "Axn) Extra number present.";
	     goto add_err_8;
	  end;
	  call find_line (num);	/* isolate +- Nth line	       */
	  negsw, possw = "0"b;
         end;
         goto a_line;		/* continue addr a_line	       */
      end; %skip (2);
cnum:				/* CHAR - numeric addr	       */
      if (ca_.r.re = -1)		/* no good if "." undefined	       */
      then goto err_Adn;
      ca_.l.ln, ca_.r.ln = -1;	/* #144*/
      if ^relsw
      then do;			/* #144*/
/****    calc the absolute location, then if that is above		   #144*/
/****      the lower part, adjust it into the upper part.		   #144*/
         i = ca_.l.le - 1 + num;
         if db_addr then call ioa_ ("(abs) ^i = ^i -1 + ^i", i, ca_.l.le, num);

         if (ca_.l.le <= b.b_.l.re) & (i > b.b_.l.re)
         then
	  do;
	  if db_addr then call ioa_ ("^i<=^i & ^i>^i", ca_.l.le, b.b_.l.re, i, b.b_.l.re);
	  i = b.b_.r.le - b.b_.l.re + i - 1; /* #144*/
	  if db_addr then call ioa_ ("^i = ^i - ^i +i-1", i, b.b_.r.le, b.b_.l.re);
         end;
      end;			/* #144*/
      else if negsw
      then do;			/* #144*/
/****    apply the negative offset, then if that pushed it out	   #144*/
/****    of the upper part, adjust it into the lower part.		   #144*/
         i = ca_.l.re - num;
         if (ca_.l.re >= b.b_.r.le) & (i < b.b_.r.le)
         then i = i - b.b_.r.le + b.b_.l.re + 1; /* #144*/
      end;			/* #144*/
      else if possw
      then do;			/* #144*/
/****    apply the positive offset, then if that pushed it out	   #144*/
/****    of the lower part, adjust it into the upper.		   #144*/
         i = ca_.l.re + num;
         if (ca_.l.re <= b.b_.l.re) & (i > b.b_.l.re)
         then i = b.b_.r.le - b.b_.l.re + i - 1; /* #144*/
      end;			/* #144*/
      else goto err_Axn;
      negsw, possw = "0"b;
      if (i < ca_.l.le)		/* is it before line begin?	       */
      then do;
         if ^string_sw		/* not OK in line mode	       */
         then goto addr_before_line;
         if (i < 1)			/* can't fall out of	       */
         then goto addr_before_buffer;	/*  the buffer		       */
         ca_.l.re, ca_.r.le = i;
         call find_line (0);		/* isolate (N) char		       */
         goto scan;
      end;
      if (i ^< ca_.r.re)		/* is it after line end?	       */
      then do;
         if string_sw | all_buffer	/* if in string mode	       */
         then do;
				/* code deleted		   #144*/
	  if (i > b.b_.r.re)	/* can't fall out of	       */
	  then call addr_after_buffer;/*  the buffer		       */
	  ca_.l.re, ca_.r.le = i;
	  call find_line (0);
	  goto scan;
         end;
         if (b_c (ca_.r.re) = NL)	/* find the NL		       */
         then ca_.r.le = ca_.r.re - 1;
         else ca_.r.le = ca_.r.re;	/*  or where it should be	       */
         if (i ^= ca_.r.le)		/* that is all that is	       */
         then goto addr_after_line;	/*  for "after" the line	       */
      end;
      ca_.l.re, ca_.r.le = i;		/* set str to this char	       */
      goto scan;			/* continue scan		       */ %skip (2);
creg:				/* CHAR - contextual addr	       */
      if string_sw
      then sre1 = b.b_.r.re;
      else sre1 = ca_.r.re;
      srb1 = ca_.l.re;
/**** When a "first" expression search is specified, allow it to match at    */
/****  the current location. Then any immediately following searches will    */
/****  start at current+1. This is so (/abc/////) doesn't match the same     */
/****  thing 3 times.					       */
      if reg_sw
      then srb1 = srb1 + 1;
      reg_sw = "1"b;
      call tedsrch_$search (addr (dbase.regexp), bp, srb1, sre1,
	 ca_.l.re, ca_.r.le, 0, msg, code);
      if (code ^= 0)
      then do;
         if (code = 2)
         then do;
	  acode = 8;
	  goto fail;
         end;
         if q_sw
         then goto q_fail;
         msg = "Acs) Char search failed.";
         acode = 2;
         goto add_err_text;
      end;
      if string_sw
      then call find_line (0);
      goto scan; %page;
/****  NOTE! --------------------------------------------------------------- */
/****	    find_line assumes that a line will never be split.	       */
/**** ---------------------------------------------------------------------- */
find_line: proc (num);

dcl num		fixed bin (21);	/* how many lines to move + or -     */

dcl NLct		fixed bin (21);
dcl i		fixed bin (21);
dcl (lb, le, se)	fixed bin (21);

      lb = ca_.l.re;
      le = ca_.r.le;
      if db_addr
      then call ioa_$ioa_switch_nnl (db_output, "^i:^i", lb, le);
      if (lb = le + 2) | (lb = le + 1)
      then le = lb;
      if (le = -1)
      then goto err_Adn;
      if (le < 1)			/* & (le+1 ^= lb) */
      then call addr_after_buffer;
      NLct = 0; %skip (3);
      if (NLct < num)
      then do;			/* go forward num lines	       */
         call set_file (le);
         do while ((NLct < num)
	    & ((next_file_char < last_file_char) | ^in_part_2));
	  i = index (substr (file_str, next_file_char), NL);
	  if (i = 0)
	  then next_file_char = last_file_char + 1;
	  else next_file_char = next_file_char + i;
	  if (next_file_char > last_file_char)
	  then if ^in_part_2
	       then call set_file (b.b_.r.le);
	  NLct = NLct + 1;
         end;
/**** coming out of this loop, next_file_char points just past a NL	       */
/****  (unless none there )					       */
         lb, le = next_file_char;
         if (ca_.r.ln ^= -1)
         then ca_.r.ln = ca_.r.ln + NLct;
      end; %skip (3);
      if (NLct > num)
      then do;			/* go backward num lines	       */
         call set_file (lb);
         do while ((NLct > num) & (first_file_char <= next_file_char));
	  i = index (reverse (substr (file_str, first_file_char,
	       next_file_char - first_file_char)), NL);
	  if (i = 0)
	  then do;
	     if in_part_2
	     then call set_file (b.b_.l.re);
	     else do;
	        if (NLct ^= num + 1)
	        then goto addr_before_buffer;
	        next_file_char = 0;	/* allow decr to line 0 (undefined)  */
	        NLct = -1;
	        goto set;
	     end;
	  end;
	  next_file_char = next_file_char - i;
	  NLct = NLct - 1;
         end;
/**** coming out of this loop, next_file_char points just ahead of a	       */
/****  NL unless there is none there.				       */
         lb, le = next_file_char;
         if (le = 0)
         then le = -1;
         if (ca_.r.ln ^= -1)
         then ca_.r.ln = ca_.r.ln + NLct;
      end;
      ca_.l.ln = ca_.r.ln;
      if (NLct = num)
	 & (b.b_.l.le <= lb)	/* 82-3-4 don't remember why this
         & (le <= b.b_.r.re)		/* 82-3-4 don't remember why this    */
      then do;			/* find both ends of current line    */
         call set_file (le);
         i = index (substr (file_str, le), NL);
         if (i = 0)
         then le = last_file_char + 1;
         else le = le + i - 1;

         call set_file (lb);
         i = index (reverse (substr (file_str, first_file_char,
	    lb - first_file_char)), NL);
         if (i = 0)
         then lb = first_file_char;
         else lb = lb - i + 1;
      end;

      if (NLct < num)
      then call addr_after_buffer;
      if (NLct > num)
      then goto addr_before_buffer;
      if (b_c (b.b_.r.re) = NL)
      then se = b.b_.r.re;
      else se = b.b_.r.re + 1;
      if (le > se)
      then call addr_after_buffer;
      if (le = b.b_.r.re + 1)		/* if just barely fell out of part2  */
      then le = b.b_.r.re;		/* ..then reference end	       */
      else if (le = b.b_.l.re + 1)	/* if just barely fell out of part1  */
	 & (b.b_.r.le > b.b_.r.re)	/* ..and part 2 is empty	       */
      then le = b.b_.l.re;		/* ..then reference end of part1     */
set:
      ca_.l.le = lb;
      ca_.r.re = le;
      if (num ^= 0)
      then do;
         ca_.l.re = lb;
         ca_.r.le = le;
      end;
      if db_addr
      then do;
         call ioa_$ioa_switch (db_output,
	    "^xfind[^d]a^d  l=^4d,^d(^d)^30.1tr=^4d,^d(^d) ^[str^;lin^]",
	    num, adr_num,
	    ca_.l.le, ca_.l.re, ca_.l.ln, ca_.r.le, ca_.r.re, ca_.r.ln,
	    string_sw);
      end;
   end find_line; %skip (3);
set_file: proc (at);

dcl at		fixed bin (21);	/* location which must be available  */

      next_file_char = at;
      if (next_file_char <= b.b_.l.re)
      then do;
         in_part_2 = ""b;
         first_file_char = b.b_.l.le;
         last_file_char = b.b_.l.re;
      end;
      else if (b.b_.r.le <= next_file_char)
      then do;
         in_part_2 = "1"b;
         first_file_char = b.b_.r.le;
         last_file_char = b.b_.r.re;
      end;
      else do;
         msg = "next in gap";
range_err:
         call ioa_ (" addr: ^a", msg);
         signal condition (addr_error); dcl addr_error condition;
         goto fail;
      end;
      if (next_file_char < first_file_char)
      then goto addr_before_buffer;
      if (last_file_char < next_file_char)
      then call addr_after_buffer;

      if db_addr
      then call ioa_$ioa_switch (db_output, "^-^[>>^;<<^] ^i)^i(^i",
	      in_part_2, first_file_char, next_file_char, last_file_char);

   end set_file; %page;
/*		      : : : ERROR messages : : :		       */
err_Aqe:
      msg = "Aqe) Bad ? form.";
      goto add_err_8;

err_Aa1:
      msg = "Aa1) No 1st addr.";
      goto add_err_8;

addr_before_buffer:
      msg = "Abb) Addr- before buffer";
      goto addr_outside;

addr_before_line:
      msg = "Abl) Addr- before line";
      goto addr_outside;

addr_after_buffer: proc;
      msg = "Aab) Addr- after  buffer";
      goto addr_outside;
   end;

addr_after_line:
      msg = "Aal) Addr- after  line";
      goto addr_outside;

buffer_empty:
      msg = "Abe) Buffer empty.";
      goto addr_outside;

addr_outside:
      if ^q_sw
      then do;
         acode = 8;
         goto fail;
      end;
      goto q_fail; %page;
%include tedbase;
%include tedcommon_;
%include tedbcb;
dcl tedaddr_	entry (		/* process request addresses	       */
		ptr,		/* -> database		       */
		ptr,		/* -> string containing address      */
		fixed bin (21),	/*   length of it		  [IN] */
				/* If <0 then recursive call	       */
				/*   how much was used up	 [OUT] */
		ptr,		/* -> buffer control block  [IN/OUT] */
		char (168) var,	/* place to hold err message if any  */
		fixed bin (35),	/* status code		       */
				/*   0- null address	       */
				/*   1- address found	       */
				/*   8- error, msg tells what        */
		);


dcl tedshow_	entry () options (variable);
%include tedsrch_;
/*dcl tedget_existing_buffer_ entry (	/* find a named buffer	       */
/*		ptr,		/* -> database		       */
/*		ptr,		/* -> string containing buffer name  */
/*		fixed bin (21),	/*   length of string	  [IN] */
/*				/*   how much was used	 [OUT] */
/*		ptr,		/* buffer control block (OUT)        */
/*		char (168)var	/* error message text	       */
/*		);					       */

dcl tedget_buffer_	entry (		/* find (or create) a buffer	       */
		ptr,		/* -> database		       */
		ptr,		/* -> string containing buffer name  */
		fixed bin (21),	/*   length of string	  [IN] */
				/*   how much was used	 [OUT] */
		ptr,		/* buffer control block (OUT)        */
		char (168) var	/* error message text	       */
		);


   end tedaddr_;
  



		    tedcheck_entryname_.pl1         08/04/87  1710.6r   08/04/87  1542.5       22041


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

/* CHECK_ENTRYNAME_ - See if the entryname x is "troublesome."    - THVV     */

/* added ! to VALID	 - jaf */


/****^  HISTORY COMMENTS:
  1) change(86-08-18,JSLove), approve(86-08-18,MCR7518),
     audit(86-08-19,Parisek), install(86-10-02,MR12.0-1175):
     Changed to call check_star_name_, which returns more meaningful error
     codes.  Changed to return error_table_$bad_file_name rather than
     error_table_$badstar if an invalid character is found.
                                                   END HISTORY COMMENTS */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

tedcheck_entryname_: check_entryname_: proc (x, ec);

dcl x		char (*), ec fixed bin (35); /* Arguments */

dcl j		fixed bin;	/* Indices */

dcl LEGAL		char (76) int static init /* Valid characters. */
		("'_`~^+-.{}:0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
		|| "abcdefghijklmnopqrstuvwxyz!/");
dcl BS		char (1) int static init ("");

dcl check_star_name_ entry (char (*), bit (36) aligned, fixed bin (2), fixed bin (35));

dcl error_table_$bad_file_name fixed bin (35) external;

dcl (index, length, rtrim, substr, verify) builtin;
%page;
%include check_star_name;
%page;
      call check_star_name_ (x, CHECK_STAR_ENTRY_DEFAULT | CHECK_STAR_REJECT_WILD, (0), ec);
      if ec ^= 0 then return;

      j = length (rtrim (x));		/* find real length of name	       */
      if verify (substr (x, 1, j), LEGAL) = 0 then return;

      if index (substr (LEGAL, 1, 12), substr (x, 1, 1)) ^= 0
      then if substr (x, 2, 1) = BS then return; /* accept overstrikes */

      ec = error_table_$bad_file_name;

      return;

   end tedcheck_entryname_;
   



		    tederror_table_.alm             11/05/86  1619.8r w 11/04/86  1038.6        4968


	include	et_macros

	et	tederror_table_

ec           ted_com_abort,(tedabort),(Error in ted_com with -abort specified.)
ec                Copy_Set,(copy_set),(Copy_Set)
ec                NoChange,(nochange),(NoChange)
ec                     Set,(set     ),(Set)
ec               Error_Msg,(err_msg ),(Error_Msg)
ec               No_Delim1,(no1delim),(No 1st delimiter.)
ec               No_Delim2,(no2delim),(No 2nd delimiter.)
ec               No_Delim3,(no3delim),(No 3rd delimiter.)
ec      zero_length_buffer,(zerobufl),(Zero length buffer.)
	end



		    tedeval_.pl1                    12/18/84  0939.0rew 12/18/84  0907.8      194877


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */

/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

/*                                              _			       */
/*    _|_              |                         |		       */
/*     |      _      _ |    _            ___     |		       */
/*     |     / \    / \|   / \   \   /   ___\    |		       */
/*     |    (__/   (   |  (__/    \ /   /   |    |		       */
/*     \_    \_/    \_/|   \_/     V    \__/|   _|_		       */
/*                                                    -----		       */
/*							       */

/**** <<<<----- dcl_tedeval_.incl.pl1 tedeval_			       */
tedeval_:				/* process evaluations	       */
      proc (adb_p, ain_p, ain_l, buf_ptr, ams_p, ams_l, result, msg, code);
dcl (
    adb_p		ptr,		/* -> database		       */
    ain_p		ptr,		/* -> evaluation string	       */
    ain_l		fixed bin (21),	/*   length thereof		  [IN] */
				/*   amount used up		 [OUT] */
    buf_ptr	ptr,		/* -> buffer control block	       */
    ams_p		ptr,		/* -> matched string in \g{...}      */
				/*    null otherwise	       */
    ams_l		fixed bin (21),	/*  length of string in \g{...}      */
				/* <0 in \{...}, 0 otherwise	       */
    result	char (500) var,	/* output string, if any	       */
    msg		char (168) var,	/* error message, if any	       */
    code		fixed bin (35)	/* return code		       */
    )		parm;		/* ----->>>>		       */

/* stk(top) corresponds to the rightmost symbol in the production	       */
/*  (rule,alternative) being "applied".				       */

dcl 1 s1		like ls based (s1_ptr);
dcl 1 s2		like ls based (s2_ptr);
dcl 1 sr		like ls based (sr_ptr);
dcl (s1_ptr, s2_ptr, sr_ptr) ptr;

dcl ex_sw		bit (1);
dcl ch2		char (1);

dcl ind		fixed bin (21);
dcl cat_p		ptr;
dcl cat_l		fixed bin (21);
dcl 1 catv	based (cat_p),
      2 link	ptr,		/* pointer to next temporary	       */
      2 len	fixed bin (21),
      2 text	char (cat_l refer (catv.len));
dcl ii		fixed bin (21);
dcl lval_ptr	ptr;
dcl 1 val		based (lval_ptr),
      2 temp	ptr,		/* pointer to temp variable list     */
      2 version	fixed bin,
      2 avar	bit (18) aligned,
      2 spare	(123) bit (36) aligned,
      2 av	(-200:200) fixed bin (24),
      2 k		(-200:200) char (32) var,
      2 K		(-10:30) char (500) var,
      2 cata	area;
dcl nextab	bit (18);
dcl avar_len	fixed bin (21);
dcl avar_ptr	ptr;
dcl unary		bit (1);
dcl char16	char (16) var;
dcl 1 avar	based (avar_ptr),
      2 next	bit (18) aligned,
      2 name	char (16),
      2 type	fixed bin,
      2 num	fixed bin (35),
      2 txt_r	bit (18);		/* offset of catv if any	       */

dcl alb		fixed bin static internal init (-200),
    aub		fixed bin static internal init (200),
    klb		fixed bin static internal init (-200),
    kub		fixed bin static internal init (200),
    Klb		fixed bin static internal init (-10),
    Kub		fixed bin static internal init (30),
    ns_string	char (256) var,
    ns_num	fixed bin;
dcl define_area_	entry (ptr, fixed bin(35));
dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl tedwhere_	entry (ptr);
dcl conc_sw	bit (1);

      code = 1;			/* FAILURE.		       */
      dbase_p = adb_p;
      bp = dbase.eval_p;
      lval_ptr = b.cur.sp;
      if (lval_ptr = null())
      then do;
         call tedget_segment_ (dbase_p, b.cur.sp, b.cur.sn);
         lval_ptr = b.cur.sp;
         val.version = 1;
         val.temp = null ();
         val.avar = "0"b;
         ai.version = area_info_version_1;
         ai.extend = "0"b;
         ai.zero_on_alloc = "1"b;
         ai.zero_on_free = "0"b;
         ai.dont_free = "0"b;
         ai.no_freeing = "0"b;
         ai.owner = dbase.tedname;
         ai.size = sys_info$max_seg_size - 8901;
         ai.areap = addr (cata);
         call define_area_ (addr (ai), code);
         if (code ^= 0)
         then do;
	  msg = "Error defining eval area.";
	  return;
         end;
dcl 1 ai		like area_info;
%include area_info;
dcl sys_info$max_seg_size fixed bin ext static;
      end;


      bp = buf_ptr;
      conc_sw = "1"b;
/****      IP = ain_p;		/* Point at the input.	       */
/****      ti = 1;						       */
/****      te = ain_l;					       */
				/* Initialize variables.	       */
      do l = lbound (ls, 1) to hbound (ls, 1);
         ls.pt (l) = null ();
      end;
      ex_sw = "0"b;
      level = -1;
      lnl = 0;			/* where is last NL char	       */
      call ns_alt (ain_p, 1, ain_l);	/* setup level 0 execute string      */
      ind = 0;
      result = "";
      code = 0;
      unary = "0"b;
      if (substr (is, 1, 3) = "{?}")
      then do;
         ain_l = 3;
         call ioa_ ("Type ""help <eval>"" for more help");
         return;
      end;

%include ted_eval_p_;
%page;
scanner: proc returns (fixed bin (21));

dcl ret_val	fixed bin;	/* hold ret val during unary check   */

/*   Return one of the following encodings:
   0	EOI	End Of Input.
   1	<integer>	0->9...
   2	<string>	pl1 string.
   3	]	Array right bracket.
   4	,
   5	{
   6	}
   7	(
   8	)
   9	:
   10	;
   11	:=	Assignment.
   12	*	Multiply.
   13	/
   14	|	Mod.
   15	+
   16	-
   17	<
   18	>
   19	=
   20	<=
   21	>=
   22	^=
   23	a[	Array of numbers.
   24	k[	Array of short strings.
   25	K[	Array of long strings.
   26	Ks Kt	addressed string
   27	be	buffer end, last byte in buffer
   28	bn	buffer name
   29	fl	function, length
   30	fs	function, substr
   31	lb	line begin, first line addressed
   32	le	linne end, last line addressed
   33	sb	string begin, first byte addressed
   34	se	string end, last byte addressed
   35	da	dump a-var
   36	dk	dump k-var
   37	dK	dump K-var
   38	dn	directory name
   39	en	entry name
   40	sn	subfile name
   41	fak	function, a to k
   42	fka	function, k to a
   43	em	error message
   44	fi	function, index
   45	fir	function, index-reverse
   46	fv	function, verify
   47	fvr	function, verify-reverse
   48	ff	function, find
   49	ffr	function, find-reverse
   50	fln	function, linenumber
   51	sk	component kind
   52	J	special compare indicator
   53	Kl	line reference
   54	Kb	buffer reference
   55	if	if command
   56	ex	execute MACRO
   57	ag	number of arguments to ted
   58	cs	collate9() value
   59	<set>	set description
   60	pn	parameter number (% call)
   61	p[	parameter reference (% call)
   62	fmx	function, max
   63	fmn	function, min
   64	frs	function, rearrange string
   65	||	concatenate
   66	<var>	variable
   67     d (   	dump function
   68	mct (	match count (substitute)
   69	emt (	error message text
   70	emc ( 	error message code
   71	<u+>	unary plus
   72	<u->	unary minus
*/


MORE:
      ls.symptr (-la_put) = addr (ib (nc));
      ls.symlen (-la_put) = 0;
      ls.symbol (-la_put) = 0;
      ls.type (-la_put) = 0;
      ls.num (-la_put) = 0;
      ls.loc (-la_put) = 0;
      if (nc > te)			/* last char may not be a NL	       */
      then do;
         if (level = 0)
         then do;			/* no more input		       */
	  test_symbol = 0;
	  goto error;
         end;
         level = level - 1;
         IP = input.pt (level);
         lgnc = input.loc0 (level);
         nc = input.loc1 (level);
         te = input.loc2 (level);
         goto MORE;
      end;
      fc = nc;
      ret_val = val_mad (fixed (ib (nc), 9));
      nc = nc + 1;
      if (nc <= te)
      then ch2 = ic (nc);
      else ch2 = " ";
      i = verify (substr (is, nc - 1), azAZ09);
      char16 = substr (is, nc - 1, i - 1);
(subscriptrange): goto LS (ret_val);

LS (0):				/* Characters that are skipped. */
      if ic (fc) > " " then goto error;
      goto MORE;
LS (1):				/* <digit>. */
      k = nc - 1;
      ns_num = index ("0123456789", ic (nc - 1)) - 1;
      do nc = nc to te while (val_mad (fixed (ib (nc), 9)) = 1);
         ns_num = (10 * ns_num) + index ("0123456789", ic (nc)) - 1;
      end;
      ls.num (-la_put) = ns_num;
      ls.symlen (-la_put) = nc - k;
      return (1);

LS (2):				/* <string>. */
      j = te - nc + 1;
      ns_string = "";
      do while (j > 0);
         k = index (substr (is, nc, j), """");
         if k < 1 then j = 0;
         else do;
	  if k > 1 then ns_string = ns_string || substr (is, nc, (k - 1));
	  ls.symlen (-la_put) = k;
	  nc = nc + k;		/* The location of the char after ". */
	  if nc > te then return ((STRING_TYPE ()));
	  if ic (nc) = """"		/* "Internal" quote.	       */
	  then do;
	     ns_string = ns_string || """"; /* Catenate in one quote.      */
	     nc = nc + 1;
	     j = te - nc + 1;
	  end;
	  else return ((STRING_TYPE ()));
         end;
      end;
      msg = "Vmq) Missing "".";
      goto err_ret;

LS (3): return (3);			/* ] */

LS (4):				/* , */
LS (5):				/* { */
LS (7):				/* ( */
LS (10):				/* ; */
LS (19):				/* = */
unary_check:
      do nc = nc to te while (ic (nc) < "!");
      end;
      if (ic (nc) = "+") | (ic (nc) = "-")
      then unary = "1"b;
      return (ret_val);

LS (6): return (6);			/* } */
LS (8): return (8);			/* ) */

LS (9):				/* :. */
      if (ch2 = "=") then do; nc = nc + 1; ret_val = 11; end;
      goto unary_check;

LS (11):				/* p */
      if (char16 = "pn") then do; nc = nc + 1; return (60); end;
      ret_val = 61;			/* might be p[ */
      goto LS (24);


LS (12): return (12);		/* * */
LS (13): return (13);		/* / */

LS (14):				/* | */
      if ch2 = "|" then do; nc = nc + 1; return (65); end;
      return (14);

LS (15):				/* + */
LS (16):				/* - */
      if unary
      then do;
         unary = "0"b;
         ret_val = ret_val + 56;
      end;
      return (ret_val);

LS (17):				/* <. */
      if ch2 = "=" then do; nc = nc + 1; ret_val = 20; end;
      goto unary_check;

LS (18):				/* >. */
      if ch2 = "=" then do; nc = nc + 1; ret_val = 21; end;
      goto unary_check;

LS (21):				/* azAZ */
alpha:
      nc = nc + length (char16) - 1;
      ls.symlen (-la_put) = length (char16);
      nextab = val.avar;
      do avar_ptr = pointer (lval_ptr, nextab)
         repeat (pointer (lval_ptr, nextab))
         while (nextab ^= "0"b);
         if (avar.txt_r = "0"b)
         then cat_p = null ();
         else cat_p = pointer (lval_ptr, avar.txt_r);
         if (char16 = "abbreviations") & (avar.type = ABREV)
         then call ioa_ ("^8a  ^a", avar.name, catv.text);
         else if (char16 = avar.name)
         then do;
	  if (avar.type = ABREV)
	  then do;
	     call ns_alt (addr (catv.text), 1, catv.len);
	     goto MORE;
	  end;
	  ls.pt (-la_put) = avar_ptr;
	  return (66);		/* defined variable		       */
         end;
         nextab = avar.next;
      end;
      if (char16 = "abbreviations")
      then goto MORE;
      ls.pt (-la_put) = null ();
      return (66);			/* undefined var		       */

LS (22):				/* ^ */
      if ch2 = "=" then do; nc = nc + 1; goto unary_check; end;
      goto error;

LS (25):				/* K[ or Kt. */
      if (char16 = "Kt") then do; nc = nc + 1; return (26); end;
      if (char16 = "Ks") then do; nc = nc + 1; return (26); end;
      if (char16 = "Kl") then do; nc = nc + 1; return (53); end;
      if (char16 = "Kb") then do; nc = nc + 1; return (54); end;
      if ("0"b) then do;
LS (23):				/* a. */
         if (char16 = "ag") then do; nc = nc + 1; return (57); end;
      end;
LS (24):				/* k */
      do nc = nc to te while (ic (nc) < "!");
      end;
      if nc <= te then if ic (nc) = "["
	 then do;
	    nc = nc + 1;
	    goto unary_check;
	 end;
      goto alpha;

LS (27):				/* "b". */
      if (char16 = "be") then do; nc = nc + 1; return (27); end;
      if (char16 = "bn") then do; nc = nc + 1; return (28); end;
      goto alpha;

LS (28):				/* c */
      if (char16 = "cs") then do; nc = nc + 1; return (58); end;
      goto alpha;

dcl fxx		(14) char (03) int static init (
		"fl ", "fs ", "fak", "fka", "fi ", "fir", "fv ", "fvr",
		"ff ", "ffr", "fln", "fmx", "fmn", "frs");
dcl fvv		(14) fixed bin int static init (
		00029, 00030, 00041, 00042, 00044, 00045, 00046, 00047,
		00048, 00049, 00050, 00062, 00063, 00064);
LS (29):				/* "f". */
      do i = 1 to 14;
         if (char16 = fxx (i))
         then do;
	  k = fvv (i);
test_for_paren:
	  ii = nc + length (char16) - 1;
	  if (ic (ii) ^= "(")
	  then goto alpha;
	  nc = ii;
	  return (k);
         end;
      end;
      goto alpha;

LS (31):				/* "l". */
      if (char16 = "lb") then do; nc = nc + 1; return (31); end;
      if (char16 = "le") then do; nc = nc + 1; return (32); end;
      goto alpha;

LS (33):				/* "s". */
      if (char16 = "sb") then do; nc = nc + 1; return (33); end;
      if (char16 = "se") then do; nc = nc + 1; return (34); end;
      if (char16 = "sn") then do; nc = nc + 1; return (40); end;
      if (char16 = "sk") then do; nc = nc + 1; return (51); end;
      goto alpha;

LS (35):				/* "d". */
      if (char16 = "da") then do; nc = nc + 1; return (35); end;
      if (char16 = "dk") then do; nc = nc + 1; return (36); end;
      if (char16 = "dK") then do; nc = nc + 1; return (37); end;
      if (char16 = "dn") then do; nc = nc + 1; return (38); end;
      k = 67;
      goto test_for_paren;

LS (36):				/* "e". */
      if (char16 = "en") then do; nc = nc + 1; return (39); end;
      if (char16 = "em") then do; nc = nc + 1; return (43); end;
/**** if (char16 = "ex") then do; nc = nc + 1; return (56); end;	       */
      if (char16 = "emt") then do; k = 69; goto test_for_paren; end;
      if (char16 = "emc") then do; k = 70; goto test_for_paren; end;
      goto alpha;

LS (37):				/* J */
      if (char16 = "J") then return (52);
      goto alpha;

LS (38):				/* i */
      if (char16 = "if") then do; nc = nc + 1; return (55); end;
      goto alpha;

LS (39):				/* S */
      if (ch2 ^= "(") then goto alpha;
      ls.mask (-la_put) = "0"b;
      ls.symlen (-la_put) = index (substr (is, nc - 1, te - nc), ")");
      nc = nc + 1;
      do while ("1"b);

/*	A alphabetic	a->z_A->Z
   N numeric		0->9
   U upper case	A->Z
   L lower case	a->z
   M carriage motion	BSP HT NL VT FF SP
   O octal		0->7
   X hex		0->9a->fA->F
   g graphic		!->~
*/
         k = index ("ANULMOXGA)anulmoxga)", ic (nc)); /* the last A is for future expansion */
         if (k = 0)
         then goto error;
         if (k > 10)
         then k = k - 10;
         nc = nc + 1;
         if (k = 10)
         then return (59);
         substr (ls.mask (-la_put), k, 1) = "1"b;
      end;

/* NEVER gets here */

LS (40):				/* m */
      if (char16 = "mct") then do; k = 68; goto test_for_paren; end;
      goto alpha;


dcl azAZ09	char (63) int static init (
		"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz");
dcl (k, j)	fixed bin (21);
dcl val_mad	(0:511) fixed bin (8) unaligned static internal init (

/* "mad" array initialized to:
   '000'777	0
   09	1
   "	2
   ]	3
   ,	4
   {	5
   }	6
   (	7
   )	8
   :	9
   ;	10
   *	12
   /	13
   |	14
   +	15
   -	16
   <	17
   >	18
   =	19
   az	21
   AZ	21
   ^	22
   a	23
   k	24
   K	25
   b	27
   c	28
   f	29
   l	31
   p	11
   s	33
   d	35
   e	36
   J	37
   i	38
   S	39
   m	40

*/
		(34) 0, 2, (5) 0, 7, 8, 12, 15, 4, 16, 0, 13, (10) 1, 9,
		10, 17, 19, 18, (2) 0, (9) 21, 37, 25, (7) 21, 39, (7) 21,
		(2) 0, 3, 22, (2) 0, 23, 27, 28, 35, 36, 29, (2) 21, 38,
		21, 24, 31, 40, (2) 21, 11, 21, 21, 33, (7) 21, 5, 14, 6,
		(386) 0);
ns_alt: entry (ipt, ilc, iln);

dcl ipt		ptr,		/* pointer to command string */
    ilc		fixed bin (21),	/* beginning location */
    iln		fixed bin (21);	/* length */

      if (level = 5)
      then do;
         ain_l = input.loc1 (1);
         msg = "Vlv) Evaluation depth > 5.";
         goto err_ret;
      end;
      if (level >= 0)
      then do;
         input.pt (level) = IP;
         input.loc0 (level) = lgnc;
         input.loc1 (level) = nc;
         input.loc2 (level) = te;
      end;
      level = level + 1;
      input.pt (level), IP = ipt;
      input.loc0 (level), lgnc,
         input.loc1 (level), nc = ilc;
      input.loc2 (level), te = ilc + iln - 1;
      return;
   end scanner;
dcl level		fixed bin (21);
dcl 1 input	(0:5),
    2 pt ptr,
    2 loc0 fixed bin (21),
    2 loc1 fixed bin (21),
    2 loc2 fixed bin (21);


%include ted_eval_;
%include ted_eval_t_;
%page;
/* . . . cka . . . */
cka: proc (i) returns (fixed bin (21));
				/* Check "i" as a valid index for    */
				/*  the "a" array.		       */
      if (i < alb) | (i > aub)
      then do;
         msg = "Vsa) Subscript not in a[-200:200].";
         goto err_ret;
      end;
      return (i);
dcl i		fixed bin (21) parm;
   end cka;


/* . . . ckk . . . */
ckk: proc (i) returns (fixed bin (21));
				/* Check "i" as a valid index for    */
				/*  the "k" array.		       */
      if (i < klb) | (i > kub)
      then do;
         msg = "VSk) Subscript not in k[-200:200].";
         goto err_ret;
      end;
      return (i);
dcl i		fixed bin (21) parm;
   end ckk;


/* . . . ckK . . . */
ckK: proc (i) returns (fixed bin (21));
				/* Check "i" as a valid index for    */
				/*  the "K" array.		       */
      if (i < Klb) | (i > Kub)
      then do;
         msg = "VsK) Subscript not in K[-10:10].";
         goto err_ret;
      end;
      return (i);
dcl i		fixed bin (21) parm;
   end ckK;
%page;
/* . . . STRING_TYPE . . . */
STRING_TYPE: proc returns (fixed bin);

dcl hold_string	char (20);

      hold_string = ns_string;
				/* Evaluate the string. */
      if nc > te then return (2);	/* <string>. */
      goto typ (index ("xXoO", substr (is, nc, 1)));
typ (0): return (2);		/* <string>. */
typ (1):
typ (2):				/* <hexvalue>. */
      nc = nc + 1;			/* Skip the "x". */
      rn = 9;			/* location of the right hex field.  */
      ns_num = 0;
				/* Proliferate first bit left. */
      if length (ns_string) > 0
      then if substr (hold_string, 1, 1) > "7"
	 then unspec (ns_num) = (36)"1"b;
      do i = length (ns_string) to 1 by -1; /* Assign right to left. */
         j = index ("0123456789ABCDEFabcdef", substr (hold_string, i, 1));
         if j < 1
         then do;
	  msg = "Vbx) Bad hex digit, """;
	  msg = msg || ns_string;
	  msg = msg || """";
	  goto err_ret;
         end;
         if j > 16
         then j = j - 6;		/* Adjust for lower case letters. */
         addr (ns_num) -> hex (rn) = hexv (j);
         rn = rn - 1;
      end;
      ls.num (-la_put) = ns_num;
      return (1);			/* <integer> */
typ (3):
typ (4):				/* <octvalue>. */
      nc = nc + 1;			/* Skip the "o". */
      rn = 12;			/* location of the right oct field.  */
      ns_num = 0;
				/* Proliferate first bit left. */
      if length (ns_string) > 0
      then if substr (hold_string, 1, 1) > "3"
	 then unspec (ns_num) = (36)"1"b;
      do i = length (ns_string) to 1 by -1; /* Assign right to left. */
         j = index ("01234567", substr (hold_string, i, 1));
         if j < 1
         then do;
	  msg = "Vbo) Bad octal digit. """;
	  msg = msg || ns_string;
	  msg = msg || """";
	  goto err_ret;
         end;
         addr (ns_num) -> oct (rn) = octv (j);
         rn = rn - 1;
      end;
      ls.num (-la_put) = ns_num;
      return (1);			/* <integer> */

dcl (i, j,
    rn)		fixed bin (21),
    hex		(9) bit (4) based,
    hexv		(16) bit (4) static internal init (
		"0000"b, "0001"b, "0010"b, "0011"b,
		"0100"b, "0101"b, "0110"b, "0111"b,
		"1000"b, "1001"b, "1010"b, "1011"b,
		"1100"b, "1101"b, "1110"b, "1111"b),
    oct		(12) bit (3) based,
    octv		(8) bit (3) static internal init (
		"000"b, "001"b, "010"b, "011"b,
		"100"b, "101"b, "110"b, "111"b);
   end STRING_TYPE;
%page;
/* . . . Global declarations . . . */
dcl
    (ioa_$ioa_switch,
     ioa_$nnl)	entry options (variable),

/* Input files. */
    IP		ptr,
    te		fixed bin (24),
    is		char (te) aligned based (IP),
    1 CHAR_ARRAY	aligned based (IP),
      2 ic	(te) char (1) unaligned,
    1 BIT_ARRAY	aligned based (IP),
      2 ib	(te) bit (9) unaligned;

dcl (abs, addrel, char, collate9, divide, hbound, index, lbound, length, 
    ltrim, max, min, null, pointer, rel, reverse, search, string, substr,
    unspec, verify
    )		builtin;

/* Declaration of Automatic data. */
dcl fc		fixed bin (21);
dcl l		fixed bin (21);
dcl lgnc		fixed bin (21);
dcl lnl		fixed bin (21);
dcl nc		fixed bin (21);

%include tedcommon_;
%include tedbase;
%include tedbcb;
%include tedstk;
dcl tedget_segment_ entry (		/* get a segment to work in	       */
		ptr,		/* -> database		       */
		ptr,		/* -> gotten segment	 [OUT] */
		fixed bin,	/* sequence # of it         [IN/OUT] */
				/* if >0 upon entry, it will then    */
				/*  fill that entry in seg_p array   */
				/* otherwise it will take any one    */
		);


dcl tedcount_lines_ entry (		/* return # lines in string	       */
		ptr,		/* -> buffer in which to count       */
		fixed bin (21),	/* where string begins in segment    */
		fixed bin (21),	/* where string ends in segment      */
		fixed bin (21)	/* # lines		 [OUT] */
		);


dcl db_sw bit (1) int static init ("0"b);
dbn: entry; db_sw = "1"b; return;
dbf: entry; db_sw = "0"b; return;
   end tedeval_;
   



		    tedglobal_.pl1                  11/23/82  1129.5rew 11/22/82  1525.4       44055


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */

/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

proc_expr:			/* process the expression for global execution */
   proc (ted_support_p, msg, code);	/* of an external function	       */

dcl msg		char (168) var,
    code		fixed bin (35);

      code = 0;
      if db_glob
      then call ioa_ (">proc rchr(^i)=`^1a' de=^i", req.cc, rchr (req.cc),
	    req.de);
loop1:
      delim = rchr (req.cc);		/* pick up str delimiter	       */
      if (delim = " ")
      then do;
         req.cc = req.cc + 1;
         goto loop1;
      end;
      if (delim = NL)
      then do;
         code = tederror_table_$No_Delim1;
         return;
      end;

      expr_b = req.cc + 1;
      concealsw = "0"b;
      do req.cc = req.cc + 1 to req.de; /* try to find end of str1      */
         if ^concealsw
         then do;
	  ch = rchr (req.cc);
	  if (ch = delim)
	  then goto sub1;
	  if (ch = "\")
	  then do;
	     if (rchr (req.cc + 1) = "c")
	        | (rchr (req.cc + 1) = "C")
	     then do;
	        req.cc = req.cc + 1;
	        concealsw = "1"b;
	     end;
	  end;
         end;
         else concealsw = "0"b;
      end;

      code = tederror_table_$No_Delim2; /*  no end of string	       */
      return;

sub1:
      expr_l = req.cc - expr_b;
      if (expr_l > 0)
      then call tedsrch_$compile (addr (rchr (expr_b)), expr_l,
	    ted_support.reg_exp_p, (ted_support.string_mode), ""b, msg, code);

/* req.nc now points to 2nd delim    */

      if db_glob
      then call ioa_ ("<proc rchr(^i)=`^1a' de=^i", req.cc, rchr (req.cc),
	    req.de);
      return; %page;
do_global:			/* globally execute some function    */
   entry (worker, mode, ted_support_p, msg, code);

dcl worker	entry (),		/* routine to do all the work	       */
    mode		char (1);		/* "g" or "v"		       */

      code = 0;
      xsw = (mode = "v");
      gb_sb = inp.sb;
      gb_se = inp.se;
      if db_glob
      then call ioa_ (">do sb=^i se=^i ln=^i", inp.sb, inp.se, inp.lno);
gb_loop:
      inp.sb = gb_sb;
      i = index (			/* then find end of it	       */
         substr (istr, gb_sb, gb_se - gb_sb + 1), NL);
      if (i = 0)			/* worry about no NL at EOB	       */
      then inp.se = gb_se;
      else inp.se = gb_sb + i - 1;
      if db_glob
      then call ioa_ ("-do sb=^i se=^i ln=^i", inp.sb, inp.se, inp.lno);
      gb_sb = inp.se + 1;		/* keep beginning of next line..     */
				/* search line for REGEXP	       */
      call tedsrch_$search (ted_support.reg_exp_p, ted_support.bcb_p,
         inp.sb, inp.se, 0, 0, 0,	/* don't care what match was	       */
         msg, code);
      if (code = 2)
      then do;
         code = tederror_table_$Error_Msg;
         return;
      end;
      if xsw = (code ^= 0)		/* ^match w/ exclude request	       */
      then do;			/*  OR match w/ global request       */
				/* this line is to be processed      */
         code = 0;
         call worker;
         if (code ^= 0)
         then return;
      end;
      else do;
         i = inp.se - inp.sb + 1;
         substr (ostr, out.de + 1, i) = substr (istr, inp.sb, i);
         out.de = out.de + i;
      end;
      ted_support.inp.lno = ted_support.inp.lno + 1;
      if (gb_sb <= gb_se)
      then goto gb_loop;
      code = 0;
      if db_glob
      then call ioa_ ("<do sb=^i se=^i ln=^i", inp.sb, inp.se, inp.lno);
      return;

dcl concealsw	bit (1);
dcl ch		char (1);
dcl delim		char (1);
dcl expr_b	fixed bin (21);
dcl expr_l	fixed bin (21);
dcl gb_sb		fixed bin (21);
dcl gb_se		fixed bin (21);
dcl i		fixed bin (21);
dcl xsw		bit (1);
dcl NL		char (1) int static options (constant) init ("
");
dcl ioa_		entry () options (variable);

%include ted_support;

dcl 1 tedcommon_$etc ext static,
      2 unused	fixed bin (24),
      2 com_blank	bit (1) aligned,
      2 com1_blank	bit (1) aligned,
      2 caps	bit (1) aligned,
      2 sws,
        3 db_ted	bit (1) aligned,
        3 db_addr	bit (1) aligned,
        3 db_eval	bit (1) aligned,
        3 db_sort	bit (1) aligned,
        3 db_zproc	bit (1) aligned,
        3 db_gv	bit (1) aligned,
        3 db_util	bit (1) aligned,
        3 db_srch	bit (1) aligned,
        3 db_glob	bit (1) aligned,
        3 db_sp1	bit (1) aligned,
      2 not_used	fixed bin,
      2 not_used2	bit (1) aligned,
      2 reset_read	bit (1) aligned;

   end proc_expr;
 



		    tedhelp_.pl1                    10/07/88  1311.2rew 10/07/88  1306.3      110304


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-01-21,LJAdams), approve(86-01-21,MCR7327),
     audit(86-04-17,Lippard), install(86-04-24,MR12.0-1048):
     Added ssu_ references so subsytem call to help_ work properly.  Added
     include file "help_args" which contains the new version number for help.
  2) change(88-08-03,RWaters), approve(88-08-03,MCR7950),
     audit(88-09-29,Huen), install(88-10-07,MR12.2-1146):
     Bug fixes for MR12.2.
                                                   END HISTORY COMMENTS */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

tedhelp_: proc (rstr);

dcl rstr		char (*);

/* UPDATE HISTORY						       */
/* EL#   date	TR	comments				       */
/* 143 84-10-10 phx17314 "help <info> -about <topic>" == "help <info>"       */
/* modified April, 1985 by L. Adams - use new help_args_ incl file           */
/* 202 88-07-08 phx20819 sci_ptr must be set to null()                       */

%include help_args_;
%include tedcommon_;
dcl 1 buf_des, 2 des;		/* These 2 lines are to fulfill      */
dcl 1 seg_des, 2 des;		/* ..refs in tedcommon.	       */
%page;
dcl about_sw	bit (1);
dcl err_ct	fixed bin;
dcl error_table_$badopt fixed bin (35) ext static;
dcl error_table_$nomatch fixed bin (35) ext static;
dcl first_rule_p	ptr;
dcl i		fixed bin;
dcl me		char (8) int static init ("ted_help");
dcl msg		char (168) var;
dcl code		fixed bin (35);
dcl msg_sw	bit (1);
dcl bar_info	bit (1);
dcl progress	fixed bin;
				/* =1: bad help_args version	       */
				/* =2: no pathnames given.	       */
				/* =3: evaluating pathnames.	       */
				/* =4: finding help segs.	       */
				/* =5: -section/-search	       */
				/*     & printing help segs.	       */
dcl rstr_b	fixed bin;
dcl sci_ptr         ptr;
dcl sec_sw	bit (1);
dcl state		fixed bin;
dcl tp		ptr;
dcl dname		char (168);
dcl command_error	condition;

dcl com_err_	entry options (variable);
dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*),
		fixed bin (35));
dcl hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2),
		fixed bin(24), fixed bin(35));
dcl ioa_		entry options (variable);

dcl ssu_$destroy_invocation    	entry (ptr),
    ssu_$standalone_invocation	entry (ptr, char(*), char(*), ptr, entry, fixed bin(35));


dcl (addr, codeptr, index, length, null, rtrim, string, substr, verify
    ) builtin;

dcl cleanup                              condition;


      call help_$init (me, "info", "", Vhelp_args_3, Phelp_args, code);
      if (code ^= 0)
      then call com_err_ (code, me, "init");

      help_args.Sctl.title = "1"b;
      help_args.Lspace_between_infos = 1;
      bar_info = "0"b;
      help_args.min_Lpgh = 2;
      help_args.Npaths = 1;
      help_args.path (1).value = "ted";
      string (help_args.path (1).S) = "0"b;
      help_args.dir (1, 1) = "";
      help_args.ent (1) = "";
      help_args.S (1).info_name_not_starname = "1"b;
/* RW 88 */
      help_args.sci_ptr = null;                                       /*#202*/

xxxxx: first_rule_p = codeptr (xxxxx);	/* get pointer to me	       */
      rstr_b = verify (rstr, " ");	/* skip any leading SP	       */
      msg_sw, about_sw, sec_sw = "0"b;
      state = 1;

/* .   1 	     2       3       4       5       6       7 <-- STATE	       */
/* .   |func   info    section -about  topic   -from X		       */
/* . Expected combinations:					       */
/* .           info						       */
/* .           info    section				       */
/* .           **      section				       */
/* .                           -about  topic			       */
/* .				       -from X		       */
/* .           **      section                 -from X		       */
/* .   |func						       */
/* .   |func   info						       */
/* .   |info                   -about  topic			       */
/* .   -msg    xxx)etc					       */

      do while (rstr_b < length (rstr));
         i = index (substr (rstr, rstr_b), " ");
         if (i = 0)
         then i = length (rstr) - rstr_b;
         else i = i - 1;
         if (i > 1)
         then do;
	  if (substr (rstr, rstr_b, 1) = "|")
	  then do;
	     if (state ^= 1)
	     then do;
	        msg = "External function name must be first.";
	        goto err_ret;
	     end;
	     call find_external_info;
	     bar_info = "1"b;
	     state = 2;
	     goto update;
	  end;
	  if (substr (rstr, rstr_b, i) = "-msg")
	  then do;
	     if (state = 1)
	     then do;
	        help_args.title = "0"b;
	        msg_sw = "1"b;
	        help_args.path (1).value = "ted_msgs";
	        state = 2;
	        goto update;
	     end;
	  end;
	  if (substr (rstr, rstr_b, i) = "-about")
	  then do;
	     help_args.title = "0"b;				/* #143*/
	     if (state < 3)
	     then do;
	        help_args.info_name (1) = "**";
	        help_args.S (1).info_name_not_starname = "0"b;
	        about_sw = "1"b;
	        state = 5;
	        goto update;
	     end;
	     if (state < 5)
	     then do;
	        state = 5;
	        goto update;
	     end;
	     msg = "Misplaced -about.";
	     goto err_ret;
	  end;
	  if (substr (rstr, rstr_b, i) = "-from")
	  then do;
	     if (state = 5)
	     then do;
	        msg = "-from cannot follow -about.";
	        goto err_ret;
	     end;
	     if (state = 1)
	     then do;
	        help_args.Sctl.he_only = "1"b;
	        help_args.Sctl.he_info_name = "1"b;
	        help_args.Sctl.he_counts = "1"b;
	        help_args.info_name (1) = "**";
	        help_args.S (1).info_name_not_starname = "0"b;
	     end;
	     rstr_b = rstr_b + i;
	     i = length (rstr) - rstr_b;
	     msg = substr (rstr, rstr_b, i);
	     call convert_date_to_binary_ ((msg),
	        help_args.min_date_time, code);
	     if (code ^= 0)
	     then goto err_ret;
	     goto update;
	  end;
	  if (substr (rstr, rstr_b, 1) = "-")
	  then do;
	     msg = substr (rstr, rstr_b, i);
	     code = error_table_$badopt;
	     goto err_ret;
	  end;
         end;
         if (state < 3)
         then do;
	  help_args.info_name (1) = substr (rstr, rstr_b, i);
	  if (help_args.info_name (1) = "**")
	  then help_args.info_name_not_starname (1) = "0"b;
	  state = 3;
	  if msg_sw
	  then if (i > 5)
	       then if (substr (help_args.info_name (1), 5, 1) = "|")
		  then do;	/* external function error	       */
		     rstr_b = rstr_b + 4;
		     i = i - 4;
		     call find_external_info;

/* The form here is						       */
/*      -msg xxx)|yyyy					       */
/* The action to be done is to search for ted_yyyy_ and then use the	       */
/*  directory containing it as the search directory. The segment looked for  */
/*  is ted_yyyy_.info.  The info looked for is "xxx)|yyyy". If that is not   */
/*  found, then "xxx)" is looked for.				       */

		  end;
	  goto update;
         end;
         if (state = 3)
         then do;
	  help_args.title = "0"b;
	  help_args.Sctl.scn, sec_sw = "1"b;
	  help_args.Nscns = 1;
	  help_args.scn (1) = substr (rstr, rstr_b, i);
	  state = 4;
	  goto update;
         end;
         if (state = 5)
         then do;
	  help_args.Nsrhs = 1;
	  help_args.Sctl.srh = "1"b;
	  i = length (rstr) - rstr_b;
	  help_args.srh = substr (rstr, rstr_b, i);
	  goto update;
         end;
         msg = "Improper arguments.";
err_ret:
         call com_err_ (code, me, "^a", msg);
         goto return_;
update:
         rstr_b = rstr_b + i;
         rstr_b = rstr_b - 1 + verify (substr (rstr, rstr_b), " ");
				/* skip any leading SP	       */
      end;


      on condition (command_error) begin;
dcl 1 command_error_info aligned based (cond_info.infoptr),
      2 length	fixed bin,
      2 version	fixed bin init (2),
      2 action_flags,
        3 cant_restart bit (1) unal,
        3 default_restart bit (1) unal,
        3 reserved	bit (34) unal,
      2 info_string char (256) var,
      2 status_code fixed bin (35),
      2 name_p	ptr,
      2 name_l	fixed bin,
      2 msg_p	ptr,
      2 msg_l	fixed bin,
      2 msg_maxl	fixed bin,
      2 print_sw	bit (1);
dcl 1 cond_info	aligned,
%include cond_info;
dcl find_condition_info_ entry (ptr, ptr, fixed bin (35));

	  call find_condition_info_ (null (), addr (cond_info), code);
	  if (code = 0)
	  then do;
	     command_error_info.print_sw = "0"b;
	     err_ct = err_ct + 1;
	  end;

         end;
dcl l fixed bin;
      call hcs_$fs_get_path_name (first_rule_p, dname, l, "", code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "Getting pathname from ^p", first_rule_p);
         goto return_;
      end;
      call hcs_$status_minf (dname, help_args.path (1).value || ".info",
         0, 0, 0, code);
      if (code = 0)			/* if name was found, use that'un    */
      then help_args.path (1).value
         = rtrim (dname) || ">" || help_args.path (1).value;

re_help:
      err_ct = 0;
      sci_ptr = null;

      on cleanup
         begin;
         if Phelp_args ^= null then
	  call ssu_$destroy_invocation (help_args.sci_ptr);
         else if sci_ptr ^= null then
	  call ssu_$destroy_invocation (sci_ptr);
         end;
      
      call ssu_$standalone_invocation (sci_ptr, me, (ted_vers), null, abort_help_command, code);
      if code ^= 0 then
         call com_err_ (code, me, "Unable to invoke ssu.");

      help_args.sci_ptr = sci_ptr;

      call help_ (me, Phelp_args, "info", progress, code);
      if (err_ct > 0) & msg_sw
      then do;
         if (substr (help_args.info_name (1), 4, 1) = ")")
         then do;
	  substr (help_args.info_name (1), 4) = "";
	  goto re_help;
         end;
         call ioa_ ("No additional help available.^/");
         code = 0;
      end;
      if (code ^= 0)
      then do;
         if (progress = 3)
         then code = help_args.path (1).code;
         if (progress = 5) & (sec_sw | about_sw) & (err_ct = 0)
         then call ioa_ (
	       "^[^; Info ""^a"" does not contain section ""^a"""
	       || "^[ (in ^a)^]^/^]", about_sw, help_args.info_name (1),
	       help_args.scn (1), bar_info, help_args.search_dirs (1));
         else if (progress = 4)
         then call ioa_ ("Info segment not found. ^a.info",
	       help_args.value (1));
         else do;
	  if (code = error_table_$nomatch)
	  then call ioa_ ("No info found. ^a^[ (in ^a)^]",
		help_args.info_name (1), bar_info, help_args.search_dirs (1));
	  else call com_err_ (code, me);
         end;
      end;

return_:
      if Phelp_args ^= null then
         call ssu_$destroy_invocation (help_args.sci_ptr);
      else if sci_ptr ^= null then
         call ssu_$destroy_invocation (sci_ptr);
      call help_$term (me, Phelp_args, 0);
      return;


abort_help_command:
      proc;
      
      return;
end abort_help_command;


find_external_info: proc;
      help_args.value (1) = "ted_";
      help_args.info_name (1) = "";
      help_args.value (1)
         = help_args.value (1) || substr (rstr, rstr_b + 1, i - 1);
      help_args.value (1) = help_args.value (1) || "_";

      call hcs_$make_ptr (first_rule_p, (help_args.value (1)),
         (help_args.value (1)), tp, code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "Searching for ^a",
	  help_args.value (1));
         goto return_;
      end;
      first_rule_p = tp;
   end;

   end tedhelp_;



		    tedmgr_.pl1                     10/07/88  1311.2rew 10/07/88  1308.4      453159


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-08-03,RWaters), approve(88-08-03,MCR7950), audit(88-09-29,Huen),
     install(88-10-07,MR12.2-1146):
     Bug fixes for MR12.2.
                                                   END HISTORY COMMENTS */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

/*							       */
/*   _|_              |					       */
/*    |      _      _ |           _      _			       */
/*    |     / \    / \|  |/|/|   / \|  |/ \			       */
/*    |    (__/   (   |  | | |  (   |  |			       */
/*    \_    \_/    \_/|  | | |   \_/|  |			       */
/*                                  |         -----		       */
/*                              \__/				       */

/* UPDATE HISTORY (finally)					       */
/* EL#   date	TR	comments				       */
/* 139 84-10-09 phx17096 "q" complains about buffer even though its deleted  */
/* 140 84-10-09 phx17209 "x" on windowed buffer not show windowed size       */
/* 158 84-10-10 phx17290 "ted -restart" with 1 active environment will get   */
/*		the user into a confusing dialogue.		       */
/* 152 84-10-11 phx17594  OOB fault on empty buffer (after [buffer X])       */
/* 163 88-07-08 changed pic6 to be picture 7 to avoid size condition in      */
/*                       buffers that exceed 99999 lines.                    */
/* 201 88-07-08 phx20688 fix message about archive component.                */
/* NNN 88-19-07 flag the buffer as modified when ted_buffer get called as    */
/*                       an active function                                  */

tedmgr_:				/* dump current database	       */
   proc;

      dbase_p = envir.bwd;		/* pick up latest environment	       */
      call ioa_$ioa_switch (db_output,
         "ptr(^d)=^p  ""^a""", env_ct, dbase_p,
         dbase.dir_db);
      if (dbase_p = null ())
      then return;
      call tedshow_ (dbase_p, "base");
      return;

list:				/* list all active pointers	       */
   entry;
dcl ptr_2		(2) ptr based;
      tp = envir.bwd;
      do while (tp ^= null ());
         call ioa_$ioa_switch (db_output,
	  "  @^p^-`^a'^( ^p^)", tp, tp -> dbase.recurs,
	  tp -> dbase.bwd, addr (tp -> dbase.reset) -> ptr_2);
         tp = tp -> dbase.bwd;
      end;
      call ioa_$ioa_switch (db_output, "    EOL");
      return;%skip(5);
dcl 1 DATABASE	based (dbase_p),
      2 zzzzzz	like dbase,
      2 cb	(0:DATABASE.bufnum) like b;

dcl 1 entries	(e_c) aligned based (e_p),
      2 type	bit (2) unal,
      2 nnames	fixed bin (15) unal,
      2 nindex	fixed bin (17) unal;
dcl names		(3) char (32) based (n_p);

dcl NL		char (1) int static options (constant) init ("
");
dcl area_p	ptr;
dcl arg		char (arg_l) based (arg_p);
dcl arg_bufs	fixed bin;
dcl arg_l		fixed bin (21);
dcl arg_p		ptr;
dcl cleanup	condition;
dcl code		fixed bin (35);
dcl db_dir	char (168) var;
dcl DD		pic "99";
dcl (
    error_table_$action_not_performed,
    error_table_$dirseg,
    error_table_$invalid_lock_reset,
    error_table_$locked_by_this_process,
    error_table_$namedup,
    error_table_$noentry,
    error_table_$no_component,
    error_table_$unimplemented_version,
    error_table_$zero_length_seg
   )		fixed bin (35) ext static;
dcl e_c		fixed bin;
dcl e_ca		fixed bin;
dcl e_p		ptr;
dcl func		fixed bin;
dcl i		fixed bin (21);
dcl ii		fixed bin (21);
dcl j		fixed bin (21);
dcl lockid	bit (36) int static init ("0"b);
dcl n_p		ptr;
dcl pdir		char (32)int static init ("");
dcl pic3		pic "999";
dcl reply		char (32);
dcl rqid		char (19);
dcl startup	fixed bin (71);
dcl status_only	bit (1);
dcl the_name	char (32);
dcl tp		ptr;
dcl used		fixed bin (21);

/* ------------------------- EXTERNAL PROCEDURES --------------------------- */

dcl com_err_	entry options (variable);
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl cv_dec_check_	entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl delete_$ptr	entry (ptr, bit (6), char (*), fixed bin (35));
dcl delete_$path	entry (char (*), char (*), bit (6), char (*),
		fixed bin (35));
dcl get_default_wdir_ entry returns (char (168));
dcl get_lock_id_	entry returns (bit (36));
dcl get_system_free_area_ entry returns (ptr);
dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl hcs_$append_link entry (char (*), char (*), char (*), fixed bin (35));
dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin (21), char (*),
		fixed bin (35));
dcl hcs_$initiate	entry (char (*), char (*), char (*), fixed bin (1),
		fixed bin (2), ptr, fixed bin (35));
dcl hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr,
		fixed bin (35));
dcl hcs_$set_bc_seg entry (ptr, fixed bin (21), fixed bin (35));
dcl hcs_$star_	entry (char (*), char (*), fixed bin (2), ptr, fixed bin,
		ptr, ptr, fixed bin (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));
dcl get_pdir_	entry () returns (char (168));
dcl ioa_		entry options (variable);
dcl ioa_$nnl	entry () options (variable);
dcl ioa_$ioa_switch entry () options (variable);
dcl iox_$error_output ptr ext static;
dcl iox_$get_line	entry (ptr, ptr, fixed bin (21), fixed bin (21),
		fixed bin (35));
dcl iox_$user_input ptr ext static;
dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl set_lock_$lock	entry (bit (36), fixed bin, fixed bin (35));
dcl request_id_	entry (fixed bin (71)) returns (char (19));
dcl user_info_	entry options (variable);

dcl env_ct	fixed bin int static init (0);
dcl 1 envir	int static,
      2 (fwd, bwd)	ptr init (null ());

dcl (
    clock, convert, ltrim, low, max, ptr, rel,
    rtrim, string, unspec
    )		builtin;

/**** <<<<----- dcl_tedinit_.incl.pl1 tedinit_			       */
tedinit_:				/* create a ted environment	       */
   entry (ted_data_p, adb_p, acode);
dcl (
    ted_data_p	ptr,		/* -> ted_ input structure	       */
    adb_p		ptr,		/* -> dbase		 (OUT) */
    acode		fixed bin (35)	/* status code		       */
    )		parm;		/* ----->>>>		       */

      if (pdir = "")
      then pdir = get_pdir_();
      if ted_data.version = 1000	/* handle old version	       */
      then do;
         if (ted_data.ted_mode = RESTART) | (ted_data.ted_mode = SAFE)
         then db_dir = rtrim (get_default_wdir_ ());
         else db_dir = "";
      end;
      else db_dir = rtrim (ted_data.temp_dir);
      status_only = "0"b;
      the_name = ted_data.tedname;
      goto somehow;

/**** <<<<----- dcl_tedstatus_.incl.pl1 tedstatus_		       */
tedstatus_:			/* display saved environments	       */
   entry (tempdir, acode);
dcl (
    tempdir	char (*)		/* name of temp dir		       */
/****acode	fixed bin (35)	/* status code		       */
    )		parm;		/* ----->>>>		       */

dcl i21		fixed bin (21);

      db_dir = tempdir;
      status_only = "1"b;
      the_name = "ted";
      goto status_1;

nil_action:
      acode = error_table_$action_not_performed;
abort_print:
      call com_err_ (acode, the_name, "^a^/^-abort[^a]", msg,
         convert (DD, env_ct));
abort_no_print:
      goto get_out;
somehow:
      acode = 1;

      if (env_ct >= 14) then do;
         msg = "Recursion exceeds depth of 14";
         goto nil_action;
      end;

      startup = clock ();
      if (lockid = "0"b)
      then lockid = get_lock_id_ ();
      e_p, n_p, dbase_p = null;
      e_c = 0;
      on condition (cleanup) begin;
	  if (dbase_p ^= null ())
	  then call tedcleanup_ (dbase_p);
         end;
      if (ted_data.ted_mode = RESTART)
      then do;
status_1:
         area_p = get_system_free_area_ ();
         call hcs_$star_ ((db_dir), db_select, 3, area_p, e_c, e_p, n_p,
	  acode);
         if (e_c = 0)
         then do;
no_envir:
	  msg = "No environment exists";
	  if status_only
	  then do;
	     call ioa_ (msg);
	     return;
	  end;
	  goto nil_action;
         end;
         begin;
dcl ps		(e_c) ptr;
	  e_ca = e_c;
	  do i = 1 to e_c;
	     call hcs_$initiate ((db_dir), names (entries (i).nindex),
	        "", 0, 1, ps (i), acode);
	     if (ps (i) = null ())
	     then do;
	        e_ca = e_ca - 1;
	        if (acode = error_table_$dirseg)
	        then do;
	        end;
	        else if (acode = error_table_$noentry)
	        then do;
/**** The only way I know that this can happen is when a -temp_dir was       */
/****  specified (thus a link was created) and now the destination of that   */
/****  link does not exist.					       */
		 call delete_$path ((db_dir), names (entries (i).nindex),
		    "100010"b, the_name, (code));
				/* try to unlink		       */
		 
	        end;
	        else call com_err_ (acode, the_name, "^a>^a", db_dir,
		 names (entries (i).nindex));
	     end;
	     else do;
	        if (ps (i) -> dbase.version ^= dbase_vers_3)
	        then do;
		 call com_err_ (error_table_$unimplemented_version,
		    the_name, "^a>^a", db_dir,
		    names (entries (i).nindex));
		 call term;
	        end;
	        else if (e_c > 1) | status_only
	        then do;
	        end;
	     end;
	  end;
	  if (e_ca < 1)
	  then goto no_envir;
	  if (e_ca > 1) & ^status_only
	  then call ioa_ ("More than 1 environment exists.");
	  force = ""b;					/* #158*/
displ_1:
	  if (e_ca > 1) | status_only
	  | force						/* #158*/
	  then call ioa_ (" #     Started, by whom, as what");
dcl (shown, activ)	fixed bin;
dcl mylock	fixed bin;				/* #158*/
dcl force		bit (1);					/* #158*/
dcl b1		bit (1);

	  shown = 0;
displ:
	  activ = 0;
	  mylock = 0;
	  do i = 1 to e_c while ((e_ca > 1) | status_only | force);	/* #158*/
	     if ps (i) ^= null ()
	     then do;
	        dbase_p = ps (i);
	        if db_util
	        then call ioa_$ioa_switch (db_output,
		 "B ^p -> ^w [^i]", ps (i),
		      dbase.lock, dbase.recurs);
	        if (dbase.recurs = 0)
	        then dbase.lock = "0"b;
	        else if (dbase.lock = "0"b)
	        then dbase.recurs = 0;
	        else do;
		 call set_lock_$lock (dbase.lock,
		    0, acode);
		 if db_util
	        then call ioa_$ioa_switch (db_output,
		    "A ^p -> ^w [^i]", ps (i),
		      dbase.lock, dbase.recurs);
		 if (acode = error_table_$invalid_lock_reset)
		 then do;
		    dbase.lock = "0"b;
		    dbase.recurs = 0;
		 end;
		 if (acode = error_table_$locked_by_this_process)
		 then mylock = mylock + 1;			/* #158*/
	        end;
	        b1 = (dbase.recurs ^= 0);
	        if b1
	        then activ = activ + 1;
	        shown = shown + 1;
	        call ioa_ (
		 "^2i^[*^; ^] ^a   ^a.^a (^a[^i])",
		 i, b1, date_time_$format ("date_time", dbase.time,"",""),
		 dbase.person, dbase.project,
		 dbase.tedname, dbase.recurs);
	        if dbase.remote_sw
	        then call ioa_ ("     @ ^a", dbase.dir_db);
	        if (length (dbase.comment) > 0)
	        then call ioa_ ("^-comment=^a",
		      dbase.comment);
	     end;
	  end;
	  if (activ > 0)
	  then call ioa_ ("(*=now active)");
	  if status_only
	  then goto freum2;
	  if (shown = 0) & ^force			/* BEGIN     #158*/
	  then do;
	     force = "1"b;
	     shown = 0;
	     goto displ_1;
	  end;
	  if (activ = shown)
	  then do;
	     if (shown > 1)
	     then do;
	        call ioa_ ("
All saved ted environments found are active.");
	        if (mylock > 0)
	        then call ioa_ (
"  Use ""pi"" or ""ted -reset"" to return to the latest one you have active.");
	        if (mylock > 1)
	        then call ioa_ (
"  Use ""ted -reset 1"" to return to the first one you have active,
  discarding environment^[ 2^;s 2 thru ^i.^]",
	        (mylock=2), mylock);
	     end;
	     else call ioa_ ("
The only saved ted environment found is active.^[
  Use ""pi"" or ""ted -reset"" to return to it.^]",
	        (mylock>0));			/* END       #158*/
	     goto freum;
	  end;
	  if (e_ca = 1) & (activ <= shown)
	  then i = 1;
	  else do;
	     i = 0;
	     call ioa_ ("Type the number of the one you want or ""?"".");
	  end;
	  do while (i = 0);
getline:
	     call iox_$get_line (iox_$user_input, addr (reply),
	        length (reply), i21, acode);
	     if (substr (reply, 1, 1) = "q")
	     then goto freum;
	     if (substr (reply, 1, 1) = "l")
	     then goto displ;
	     if (substr (reply, 1, 2) = "??")
	     then call ioa_ ("  sN^-dump of environment N");
	     if (substr (reply, 1, 1) = "?")
	     then do;
	        call ioa_ ("  dN^-delete environment N");
	        call ioa_ ("  xN^-list buffers in environment N");
	        call ioa_ ("  l^-list available environments");
	        call ioa_ ("  q^-quit");
	        goto getline;
	     end;
	     if (substr (reply, 1, 1) = "x")
	     then do;
	        ii = 2;
	        func = 1;
	     end;
	     else if (substr (reply, 1, 1) = "d")
	     then do;
	        ii = 2;
	        func = 2;
	     end;
	     else if (substr (reply, 1, 1) = "s")
	     then do;
	        ii = 2;
	        func = 3;
	     end;
	     else do;
	        ii = 1;
	        func = 4;
	     end;
	     i = cv_dec_check_ (substr (reply, ii, i21 - ii), acode);
	     if (acode ^= 0)
	        | (i < 1)
	        | (i > e_c)
	     then do;
	        call ioa_ ("Please give a number in range 1-^i.",
		 e_c);
	        i = 0;
	        goto getline;
	     end;
	     if (ps (i) = null ())
	     then do;
	        call ioa_ ("Environment ^i is not available.", i);
	        i = 0;
	        goto getline;
	     end;
	     goto rsfunc (func);
rsfunc (1):			/* function "x"		       */
	     call tedlist_buffers_ (ps (i), "", "0"b, "0"b);
	     goto getline;
rsfunc (2):			/* function "d"		       */
	     if (ps (i) -> dbase.lock ^= "0"b)
	     then do;
	        call ioa_ ("
Environment ^i is currently active, delete not done.", i);
	        goto getline;
	     end;
				/*-*/
	     call tedcleanup_ (ps (i));
	     ps (i) = null ();
	     e_ca = e_ca - 1;
	     if (e_ca < 1)
	     then goto no_envir;
	     goto getline;
rsfunc (3):			/* function "s"		       */
	     dbase_p = ps (i);
	     call tedshow_ (dbase_p, "base");
	     goto getline; %skip (4);
term: proc;
      call hcs_$terminate_noname (ps (i), 0);
      ps (i) = null ();
      e_ca = e_ca - 1;
   end;
rsfunc (4):			/* try starting up again	       */
	     if (ps (i) -> dbase.lock ^= "0"b)
	     then do;
	        call ioa_ (
"Environment ^i is currently active, restart not done.", i);
	        goto getline;
	     end;
	  end;
	  dbase_p = ps (i);
	  call set_lock_$lock (dbase.lock, 0, acode);
	  if (acode = error_table_$invalid_lock_reset)
	  then acode = 0;
	  if (acode ^= 0)
	  then do;
	     call ioa_ ("The selected ted environment is already active.");
	     goto getline;
	  end;
	  ps (i) = null ();
	  if ""b
	  then do;
freum:
	     acode = error_table_$action_not_performed;
	     status_only = "1"b;
	  end;
freum2:
	  free entries;
	  free names;
	  do i = 1 to e_c;
	     if (ps (i) ^= null ())
	     then call term;
	  end;
         end;

         if status_only
         then return;
         call ioa_ ("Restarting session of ^a.",
	  date_time_$format ("date_time", dbase.time,"",""));
         call restart;
      end;
      else do;			/* starting from scratch	       */
         if (db_dir ^= "")
         then do;
	  call hcs_$star_ ((db_dir), db_select, 3, null (), e_c, e_p,
	     n_p, code);
	  if (e_c > 0)
	  then call ioa_ ("^a: ^i environment^[s^] already saved.",
		the_name, e_c, (e_c > 1));
         end;
         rqid = request_id_ (startup);
         dbase_p = null ();
         call get_base (adb_p, 0, "base    ", acode);
         dbase_p = adb_p;
         call start;
      end;
      env_ct = env_ct + 1;
      dbase.recurs = env_ct;
      dbase.lock = lockid;		/* show user is active	       */
      dbase.bwd = envir.bwd;		/* link new one in to list	       */
      envir.bwd = dbase_p;
      acode = 0;			/* successful initialization	       */
      adb_p = dbase_p;
get_out:
      if db_util then call ioa_$ioa_switch (db_output,
         "dbase_p=^p[^i]", envir.bwd, env_ct);
      return;
dcl db_select	char (26) int static options (constant) init (
		"ted_.????????????.??????.X");
/****		"ted_.820827000117.6795936.X"			       */
%page;
tedhold_:				/* exit ted, keeping environment     */
   entry (adb_p);
      dbase_p = adb_p;
      cleaning = "0"b;
      goto hold_clean;

dcl cleaning	bit (1);
tedcleanup_:			/* exit ted, destroying environment  */
   entry (adb_p);
      dbase_p = adb_p;
      if db_util then do;
         call ioa_$ioa_switch (db_output, "CLEANUP ^p", dbase_p);
         call tedshow_ (dbase_p, "base");
      end;
      cleaning = "1"b;
hold_clean:
      if (dbase.recurs ^= 0)
      then do;
         if dbase_p ^= envir.bwd
         then signal condition (base_ne_envir); dcl base_ne_envir condition;
         envir.bwd = dbase.bwd;
         dbase.bwd = null;
         env_ct = env_ct - 1;
      end;
      the_name = dbase.tedname;
      dbase_lock = dbase.lock;
      dbase.lock = "0"b;		/* show not in service	       */
dcl dbase_lock	bit (36);
dcl segid		char (32);

      if ^cleaning
      then do;
         do bp = addr (cb (0)), addr (cb (1));
	  b.b_.l.re = b.b_.l.le - 1;	/* empty out b((request line))       */
	  b.b_.r.le = b.b_.r.re + 1;	/* and b((ted))		       */
	  b_s = low (b.maxl);
         end;
         if (dbase.seg_p (3) ^= null()) /* empty out call stack if there     */
         then call hcs_$truncate_seg (dbase.seg_p (3), 0, 0);

         do i = 0 to dbase.bufnum;
	  bp = addr (cb (i));
	  if (b.cur.sn > 0)		/* is there buffer space?	       */
	     & (i ^= 2)		/* and it's not the eval segment     */
	     & ^b.pseudo		/* and its for real		       */
	  then do;		/* zero out the empty part	       */
	     substr (b_s, b.b_.l.re + 1,b.b_.r.le - b.b_.l.re - 1)
	        = low (b.b_.r.le - b.b_.l.re - 1);
	  end;
         end;
      end;
      call delete_$path (pdir, "ted_." || dbase.rq_id, "100100"b,
         the_name, 0);		/* cleanup possible fileout segment  */
      segid = "ted_.yymmddHHMMSS.UUUUUU.000";
      substr (segid, 6, 19) = dbase.rq_id;
      do i = dbase.seg_ct to 1 by -1;
         if (dbase.seg_p (i) ^= null ())
         then do;
	  call wipeout (i);
         end;
      end;
      call wipeout (0);
      if db_util
      then call ioa_$ioa_switch (db_output,
         "^2d ^p", env_ct, envir.bwd);
      return; %skip (5);
wipeout: proc (ndx);

dcl ndx		fixed bin (21);

dcl tp		ptr;

      tp = dbase.seg_p (i);
      if db_util
      then call ioa_$ioa_switch (db_output,
         "wipe: ^p^[ cleaning^]^[ active^]^[ base^]",
         tp, cleaning, (dbase_lock^="0"b), (ndx=0));

/**** This statement is OK because the only way you will be cleaning up an   */
/****  environment of temp segs is when the environment is active.	       */
      if (dbase.dir_db = "")
      then call release_temp_segment_ (the_name, tp, code);
      else do;
/**** If we're not cleaning out, then just tuck 'em in bed.		       */
         if ^cleaning
         then call hcs_$terminate_noname (tp, code);
         else do;
/**** OK! We're throwing the stuff away.			       */
	  if (ndx = 0)
	  then substr (segid, 26) = "X  ";
	  else substr (segid, 26) = convert (pic3, i);
/**** If the environment is active, get rid of them by pointer, otherwise we */
/****  must do it by pathname.				       */
	  if (dbase_lock ^= "0"b)
	  then call delete_$ptr (tp, "100100"b, the_name, code);
	  else call delete_$path (dbase.dir_db, segid,
	     "100100"b, the_name, code);
/**** If -temp_dir was specified, a link was placed in the home dir so we    */
/****  can find the database. When we clean up everything, this link is a    */
/****  part of everything. We don't know or care if it is there...	       */
	  if (ndx = 0)
	  then call delete_$path (get_default_wdir_ (), segid, "100010"b,
		the_name, (code));	/* ...just get rid of it!	       */
         end;
         if (code ^= 0)
         then call com_err_ (code, the_name);
      end;
   end wipeout; %page;
dcl date_time_$format entry (char(*), fixed bin(71), char(*), char(*))
		returns(char(250) var);
buffer:			/* return name of buffer segment     */
   entry;
buf_comm:
      if (env_ct = 0)
      then do;
         call ioa_ ("Not in ted");
         return;
      end;
      call cu_$arg_ptr (1, arg_p, arg_l, code);
      if (code ^= 0) | (arg_l = 0)
      then do;
         call com_err_ (code, "ted_buffer", "Buffer name");
         return;
      end;

      dbase_p = envir.bwd;
      do j = 3 to dbase.bufnum;
         bp = addr (cb (j));
         if (b.name = arg)
         then do;
	  if db_util
	  then call tedshow_(bp,"bcb");
	  if (b.cur.sn = -1)	/* is this a ^read file	       */
	  then do;
	     if b.ck_ptr_sw
	     then do;
	        if db_util then call ioa_$ioa_switch (db_output,
		 "ck_ptr");
	        call tedck_ptr_ (bp);
	     end;
	     dbase.not_read_ct = max (0, dbase.not_read_ct - 1);
	  end;
	  call tedcloseup_ (bp);	/* put into own segment	       */
	  if db_util
	  then call tedshow_ (bp, "bcb");
	  call hcs_$set_bc_seg (b.cur.sp, b.b_.l.re * 9, code);
	  call hcs_$truncate_seg (b.cur.sp,
	     divide (b.b_.l.re + 3, 4, 21, 0), code);
	  if (dbase.dir_db = "")
	  then do;
	     call hcs_$fs_get_path_name (b.cur.sp, d_name, dl, e_name, 0);
	     msg = substr (d_name, 1, dl);
	     msg = msg || ">";
	     msg = msg || rtrim (e_name);
	  end;
	  else do;
	     msg = rtrim (dbase.dir_db);
	     msg = msg || ">ted_.";
	     msg = msg || dbase.rq_id;
	     msg = msg || ".";
	     msg = msg || convert (pic3, b.cur.sn);
	  end;
	  if db_util
	  then call ioa_$ioa_switch (db_output,
	     "val=`^va'", length (msg), msg);
	  call cu_$af_arg_count (j, code);
	  if (code ^= 0)
	  then call ioa_ ("^a", msg);
	  else do;
	     b.get_bit_count = "1"b;
/* RW 88 */
/* e emacs [ted_buffer 0] should set the buffer as modified
 * possibly, it should also decriment the sequence number??
 * b.cur.sn--;
 */
	     b.mod_sw = "1"b;                                       /* #NNN*/
	     call cu_$af_return_arg (j + 1, af_ptr, af_len, code);
	     af_val = msg;
	  end;
	  return;
         end;
      end;
      call com_err_ (0, "ted_buffer", "b(^a) not found.", arg);
      return;
dcl d_name	char (168);
dcl e_name	char (32);
dcl dl		fixed bin (21);
dcl cu_$af_arg_count entry (fixed bin (21), fixed bin (35));
dcl cu_$af_return_arg entry (fixed bin (21), ptr, fixed bin (21),
		fixed bin (35));
dcl af_val	char (af_len) var based (af_ptr);
dcl af_ptr	ptr;
dcl af_len	fixed bin (21); %page;
tedreset_:			/* re-enter ted, simulating an error */
   entry;

      if (env_ct = 0)
      then do;
         call ioa_ ("Not in ted");
         return;
      end;
      call cu_$arg_ptr (1, arg_p, arg_l, code);
      if (code = 0)
      then do;
         if (verify (arg, "0123456789") = 0)
         then do;
	  i = fixed (arg);
	  if (i > env_ct)
	  then do;
	     call ioa_ ("ted[^a] not active", arg);
	     return;
	  end;
         end;
         else do;
	  call ioa_ ("ted -reset: invalid argument");
	  return;
         end;
      end;
      else i = env_ct;
      dbase_p = envir.bwd;
      j = env_ct;
      if db_util
      then call tedmgr_$list;
      do while (j > i);
         if db_util
         then call ioa_$nnl (" [^i] ^p ->", j, dbase_p);
         dbase_p = dbase.bwd;
         j = j - 1;
      end;
      if db_util
      then call ioa_$ioa_switch (db_output,
         " [^i] ^p", j, dbase_p);
      call ioa_$ioa_switch (iox_$error_output, "^a: reset[^i]",
         dbase.tedname, dbase.recurs);
      goto dbase.reset; %page;
tedbreak_:			/* set break mode and continue       */
   entry;
      if (env_ct = 0)
      then do;
         call ioa_ ("Not in ted");
         return;
      end;
      envir.bwd -> dbase.at_break = 1;
      call start$start;
dcl start$start	entry;
      return; %page;
/**** <<<<----- dcl_tedget_buffer_.incl.pl1 tedget_existing_buffer_	       */
tedget_existing_buffer_:		/* find a named buffer	       */
   entry (adb_p, ain_p, ain_l, abp, a_msg);
/****dcl (
/****adb_p	ptr,		/* -> database		       */
/****ain_p	ptr,		/* -> string containing buffer name  */
/****ain_l	fixed bin (21),	/*   length of string	  [IN] */
				/*   how much was used	 [OUT] */
/****abp		ptr		/* buffer control block (OUT)	       */
/****a_msg	char (168)var	/* error message text	       */
/****)		parm;		/* ----->>>>		       */

      create = "0"b;
      goto common_get;

/**** <<<<----- dcl_tedget_buffer_.incl.pl1 tedget_buffer_		       */
tedget_buffer_:			/* find (or create) a buffer	       */
   entry (adb_p, ain_p, ain_l, abp, a_msg);
dcl (
/****adb_p	ptr,		/* -> database		       */
    ain_p		ptr,		/* -> string containing buffer name  */
    ain_l		fixed bin (21),	/*   length of string	  [IN] */
				/*   how much was used	 [OUT] */
    abp		ptr		/* buffer control block (OUT)	       */
/****a_msg	char (168)var	/* error message text	       */
    )		parm;		/* ----->>>>		       */

dcl create	bit (1);

      create = "1"b;
common_get:
      dbase_p = adb_p;
      if (dbase_p = null ())
      then dbase_p = envir.bwd;
      if (dbase_p = null ())
      then do;
         abp = null ();
				/* @@ */
         return;
      end;

dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (21),
		fixed bin (35));
find_buffer: begin;
				/* extract buffer name and find      */
				/*  (or create) buffer	       */

dcl next_in	fixed bin;	/* where at in address data	       */
dcl in_p		ptr;		/* -> address data		       */
dcl in_l		fixed bin (21);	/*   length of it		       */
dcl in_s		char (in_l) based (in_p); /* data as a string	       */
dcl in_c		(in_l) char (1) based (in_p); /* data as an array      */

dcl i		fixed bin (21);
dcl j		fixed bin (21);
dcl l		fixed bin (21);
dcl tch		char (1);
dcl tnl		fixed bin (21);
dcl tname		char (32);
dcl MTi		fixed bin (21);
dcl inext_in	fixed bin (21);
/*			dcl acode		fixed bin (35);	       */

make_buf: proc;

      if (MTi ^= 0)
      then do;
         bp = addr (cb (MTi));
         call re_alloc (bp, tname);
      end;
      else do;
         call allocate_cb (bp, tname);
      end;
   end make_buf;

         bp = null;			/* null ptr => error occurred	       */
         in_p = ain_p;
         in_l = ain_l;
         next_in = verify (in_s, " ");
         inext_in = next_in;
         tch = in_c (next_in);
         if tch ^= "("		/* one char buffer name given	       */
         then do;
	  tname = tch;		/* pick up single character name     */
	  if (index ("(),;", tch) ^= 0)
	  then do;
	     msg = "Bbc) Invalid buffer name.";
	     goto add_str;
	  end;
	  tnl = 1;
	  if (tch = NL)
	  then goto Bnn;
	  next_in = next_in + 1;	/* skip index over buffer name       */
	  tch = ")";
         end;
         else do;			/* if multiple characters in name    */
	  if (substr (in_s, next_in + 1, 1) = "@")
	  then do;		/* this is a "current buffer" ref    */
	     next_in = next_in + 3;
	     tch = in_c (next_in - 1);
	     bp = ptr (dbase_p, dbase.cb_c_r);
	     tname = b.name;
	     goto addr_check;
	  end;
	  if (substr (in_s, next_in, 6) = "((g*))")
	  then do;
	     tnl = 4;
	     tname = "(g*)";
	     next_in = next_in + 6;
	  end;
	  else do;
	     l = in_l - next_in;	/* find end of buffer name	       */
	     if l < 2
	     then goto Bmd;
	     i = next_in + 1;	/* skip over the "("	       */
	     j = search (substr (in_s, i, l), "),");
	     if (j < 2)
	     then do;
	        if (j = 0)
	        then goto Bmd;
Bnn:
	        msg = "Bnn) Null buffer name.";
	        goto add_str;
	     end;
	     tnl = j - 1;
	     if (tnl > length (b.name))
	     then do;
	        msg = "Bln) Name > ";
	        msg = msg || ltrim (char (length (b.name)));
	        msg = msg || " char.";
	        goto add_str;
	     end;
	     next_in = i + j;	/* set line index after char found   */
	     tname = substr (in_s, i, tnl); /* pick up buffer name	       */
	  end;
	  tch = in_c (next_in - 1);	/* pick up stopper character	       */
         end;
         ain_l = next_in - 1;		/* tell how much string used up      */
         MTi = 0;
         do i = 3 to dbase.bufnum;
	  if (cb (i).name = "")
	  then MTi = i;
	  else do;
	     if (cb (i).name = tname)
	     then do;
	        bp = addr (cb (i));
	        b.noref = "0"b;
	        call check_bc;				/* #152*/
	        goto addr_check;
	     end;
	  end;
         end;
         if create
         then do;
	  call make_buf;
addr_check:
	  if (tch = ",")
	  then do;
	     if (in_c (next_in) = "@")
	     then do;
	        msg = "@ not allowed in this context";
	        goto add_str;
	     end;
/****	     b.temp = b.a_;					       */
/****	     b.newb = b.b_;					       */
/****	     if (rel (bp) ^= dbase.cb_c_r)  /* not current buffer?	       */
/****	     then do;					       */
/****	        b.newb.l.le = 1;	/* 4/12/82 cant remember why this    */
/****	        b.newb.r.re = b.maxl;				       */
/****	     end;						       */
	     used = in_l - next_in + 1;
	     call tedaddr_ (dbase_p, addr (in_c (next_in)), used, bp,
	        msg, code);
	     next_in = next_in + used + 1;
	     ain_l = next_in - 1;	/* tell how much string used up      */
	     if (code > 1)
	     then do;
add_str:
	        msg = msg || " """;
	        msg = msg || substr (in_s, inext_in, next_in - inext_in + 1);
	        msg = msg || """.";
	        goto err_out;
	     end;
	     tch = in_c (next_in - 1);
	     if ^b.present (1)
	     then b.a_ (1), b.a_ (2) = b.a_ (0);
	     else do;
	        if ^b.present (2)
	        then b.a_ (2) = b.a_ (1);
				/* b.newb.l.ln, b.newb.r.ln = -1;    */
	     end;
	  end;
	  else do;
	     b.a_.l.ln (1) = 1;
	     b.a_.r.ln (2) = b.b_.r.ln;
	     b.a_.l (1) = b.b_.l;
	     b.a_.l.re (1) = b.a_.l.le (1);
	     b.a_.r (2) = b.b_.r;
	     b.a_.r.le (2) = b.a_.r.re (2);
	     b.present (1), b.present (2) = "0"b;
	  end;
	  if (tch ^= ")")
	  then do;
Bmd:
	     msg = "Bmd) Missing ).";
	     goto add_str;
	  end;
         end;
         else do;			/* not found, take error return      */
	  msg = "Bnf) b(";		/* ***) not found. */ /* ERROR       */
	  msg = msg || substr (tname, 1, tnl);
	  msg = msg || ") not found.";
err_out:
	  bp = null ();
	  a_msg = msg;
         end;
      end find_buffer;					/* #152*/
out:
      abp = bp;			/* give him what we got	       */
out_only:
      return; %page;
check_bc: proc;						/* #152*/
	
      if b.ck_ptr_sw & b.terminate
      then call tedck_ptr_ (bp);
      if b.get_bit_count
      then do;
         b.get_bit_count = "0"b;
         call hcs_$status_mins (b.cur.sp, 0, arg_l, code);
         if (code ^= 0)
         then do;
	  msg = b.name;
	  call tederror_rc_ (dbase_p, msg, code);
	  goto out_only;
         end;
         arg_l = divide (arg_l, 9, 24, 0);
         if (arg_l ^= b.b_.l.re)
         then do;
	  b.b_.l.re = arg_l;	/* set changed buffer length	       */
	  b.a_.l.le (0), b.a_.r.le (0) = 1; /* "." undefined	       */
	  b.a_.l.re (0), b.a_.r.re (0) = -1;
	  b.maxln,		/* line counts unknown	       */
	     b.a_.r.ln (0), b.a_.l.ln (0) = -1;
         end;
      end;						/* #152*/
   end check_bc;						/* #152*/

tedcheck_buffer_state_: entry (adb_p, abp, a_msg);		/* #152*/

      dbase_p = adb_p;					/* #152*/
      bp = abp;						/* #152*/
      call check_bc;					/* #152*/
      return;						/* #152*/
%page;
/**** <<<<----- dcl_tedget_segment_.incl.pl1 tedget_segment_	       */
tedget_segment_:			/* get a segment to work in	       */
   entry (adb_p, asp, asn);
dcl (
/****adb_p	ptr,		/* -> database		       */
    asp		ptr,		/* -> gotten segment	 [OUT] */
    asn		fixed bin		/* sequence # of it	        [IN/OUT] */
				/* if >0 upon entry, it will then    */
				/*  fill that entry in seg_p array   */
				/* otherwise it will take any one    */
    )		parm;		/* ----->>>>		       */

      dbase_p = adb_p;
      if (asn = 0)
      then call get_seg (asp, asn, "getseg  ", code);
      else if (asn = 2)
      then call get_seg_n (asp, asn, "16Kpool ", code);
      else if (asn = 3)
      then call get_seg_n (asp, asn, "stk ", code);
      else call get_seg_n (asp, asn, "getsegn ", code);

      return; %skip (5);
/**** <<<<----- dcl_tedfree_segment_.incl.pl1 tedfree_segment_	       */
tedfree_segment_:			/* give back a work segment	       */
   entry (adb_p, asn);
/****dcl (
/****adb_p	ptr,		/* -> database		       */
/****asn		fixed bin		/* sequence # of segment to free     */
/****)		parm;		/* ----->>>>		       */

      dbase_p = adb_p;
      call hcs_$truncate_seg (dbase.seg_p (asn), 0, 0);
      substr (dbase.inuse_seg, asn, 1) = "0"b;
      return; %page;
tederror_rc_:			/* add return code data to message   */
   entry (adb_p, a_msg, rc);
dcl (
/****adb_p	ptr,		/* -> dabatase		       */
    a_msg 	char (168) var,	/* error message		       */
    rc		fixed bin (35)	/* code to include with message      */
    )		parm;

dcl shortinfo	char (8);
dcl longinfo	char (100);
dcl convert_status_code_ entry (fixed bin (35), char (8), char (100));

      call convert_status_code_ (rc, shortinfo, longinfo);
/* RW 88 */
      if (rc = error_table_$noentry)
      then msg = "Cnf) ";
      else if (rc = error_table_$no_component)                        /*#201*/
      then msg = "Cnf) ";
      else if (rc = error_table_$zero_length_seg)
      then msg = "Czl) ";
      else msg = "Cxx) ";
      msg = msg || rtrim (longinfo);
      msg = msg || " ";
      msg = msg || a_msg;
      call tederror_ (adb_p, msg);
      return; %page;
/**** <<<<----- dcl_tedlist_buffers_.incl.pl1 tedlist_buffers_	       */
tedlist_buffers_:			/* show the status of buffers	       */
   entry (adb_p, select, atest, ln_sw);
dcl (
/****adb_p	ptr,		/* -> database		       */
    select	char (16),	/* name of buffer to show	       */
    atest		bit (1),		/* 0- listing inactive environment   */
				/* 1- listing active one	       */
    ln_sw		bit (1)		/* 1- validate b.maxln	       */
    )		parm;		/* ----->>>>		       */

dcl buf_ct	fixed bin (21);
dcl line_counts	char (24)var;
dcl Window	char (24)var;				/* #140*/

      dbase_p = adb_p;
      buf_ct = 0;
      arg_bufs = dbase.argct;
      if (arg_bufs > 0)
      then arg_bufs = arg_bufs + 1;
      do ii =
         3 + arg_bufs to dbase.bufnum,
         3 to 2 + arg_bufs;
         bp = addr (cb (ii));
         if (b.name ^= "") & ^b.noref
         then do;
	  if atest
	  then call check_bc;				/* #152*/
	  if (select = " ") | (select = b.name)
	  then do;
	     buf_ct = buf_ct + 1;
	     call fix_buffer_data (atest, ln_sw);
	     call ioa_ (
	        "^a ^[->^;  ^] ^[mod^;   ^] (^a)^a^[ [^^trust]^]"
	        || "^[ [^^pasted]^] ^a^[>^a^[:^]^a^a^[   *^]^]",
	        line_counts, (rel (bp) = dbase.cb_c_r),
	        b.mod_sw, b.name, Window,  ^b.trust_sw, b.not_pasted,
	        b.dname, b.file_sw, b.ename, (b.kind = ":"),
	        b.kind, b.cname, (b.cur.sn = -1));		/* #140*/
				/* print buffer status line	       */
	  end;
         end;
      end;
      if (buf_ct = 0)
      then do;
         msg = "X: b(";
         msg = msg || select;
         msg = msg || ") not found";
         call tederror_ (adb_p, msg);
      end;
      return; %page;
dcl in_window	bit (1);
fix_buffer_data: proc (flag, ln_sw);

dcl flag		bit (1),
   ln_sw		bit (1);

/* RW 88 */
dcl pic7		pic "------9";                                    /*#163*/
dcl hold_maxln	fixed bin (21);

      if (b.cur.sn = 0)		/* buffer empty?		       */
      | (b.b_.l.le > b.b_.l.re) & (b.b_.r.le > b.b_.r.re)		/* #152*/
      then do;
         b.mod_sw, b.not_pasted = "0"b;
         b.maxln = 0;
      end;
      else if ^(b.file_sw | (b.name = "0"))
      then b.mod_sw = "0"b;
      if ^b.file_sw
      then b.trust_sw = "1"b;
      else b.not_pasted = "0"b;
      hold_maxln = b.maxln;
      if ln_sw & atest
      then b.maxln = -1;
      if (b.b_.l.le = 1) & (b.b_.r.re = b.maxl)
      then do;						/* #140*/
         in_window = ""b;					/* #140*/
         Window = "";					/* #140*/
      end;						/* #140*/
      else do;						/* #140*/
         in_window = "1"b;					/* #140*/
         Window = " windowed(";				/* #140*/
         b.maxln = -1;		/* force linecounting	   #140*/
      end;						/* #140*/
/* RW 88 */
      if (b.maxln < 0)
      then string (pic7) = "     ??";				/* #140,163*/
      else pic7 = b.maxln;					/* #140*/
      if flag & (b.maxln < 0)
      then do;
         call tedcount_lines_ (bp, b.b_.l.le, b.b_.r.re, b.maxln);	/* #140*/
         if ^in_window					/* #140*/
         then b.b_.r.ln = b.maxln;
         pic7 = b.maxln;					/* #140*/
      end;
      if in_window
      then do;						/* #140*/
         line_counts = "     ??";				/* #140,163*/
         Window = Window || pic7;				/* #140*/
         Window = Window || ")";				/* #140*/
         b.maxln = -1;					/* #140*/
      end;						/* #140*/
      else line_counts = pic7;				/* #140*/
      if ln_sw & atest
      then do;
         pic7 = hold_maxln;
         line_counts = line_counts || " <<";
         line_counts = line_counts || pic7;
      end;

   end fix_buffer_data; %page;
/**** <<<<----- dcl_tedcheck_buffers_.incl.pl1 tedcheck_buffers_	       */
tedcheck_buffers_:			/* check for modified buffers	       */
   entry (adb_p, check_code);
dcl (
/****adb_p	ptr,		/* -> database		       */
    check_code	fixed bin		/* number of modified buffers found  */
    )		parm;		/* ----->>>>		       */

      dbase_p = adb_p;
      check_code = 0;
      do i = 3 to dbase.bufnum;
         bp = addr (cb (i));
         if b.ck_ptr_sw & b.terminate
         then call tedck_ptr_ (bp);
         call fix_buffer_data (""b, ""b);
         if (b.name ^= "") then				/* #139*/
         if b.mod_sw | b.not_pasted
         then do;
	  if (check_code = 0)
	  then call ioa_ ("Modified buffers exist:");
	  check_code = 1;
	  call ioa_ ("^[->^;  ^](^a)	^a^[>^a^[:^]^a^a^]",
	     (rel (bp) = dbase.cb_c_r),
	     b.name, b.dname, b.file_sw, b.ename,
	     (b.kind = ":"), b.kind, b.cname);
         end;
      end;
      return; %page;
tedset_ck_ptr_:			/* set "check" flag on ^read buffers */
   entry (adb_p);

      dbase_p = adb_p;
      do ii = 3 to dbase.bufnum;
         bp = addr (cb (ii));
         if (b.cur.sn = -1) & b.terminate
         then b.ck_ptr_sw = "1"b;
      end;
      return; %skip (3);
/* ------------------------- INTERNAL PROCEDURES --------------------------- */
allocate_cb: proc (cb_ptr, cb_name);

dcl cb_ptr	ptr,		/* points to new control block [OUT] */
    cb_name	char (32);	/* name of new block	       */


dcl ii		fixed bin;
dcl new		bit (1);

      dbase.bufnum = dbase.bufnum + 1;
      cb_ptr = addr (cb (dbase.bufnum));
      new = "1"b;
      if ""b
      then do;

re_alloc: entry (cb_ptr, cb_name);
         new = ""b;
      end;
      unspec (cb_ptr -> b) = "0"b;	/* clean everything out	       */
      do ii = 1 to all_des;
         cb_ptr -> buf_des (ii) = tedcommon_$no_data;
      end;
      cb_ptr -> b.cur = tedcommon_$no_seg;
      cb_ptr -> b.ex = tedcommon_$no_data;
      cb_ptr -> b.ex.l.le = cb_ptr -> b.ex.l.re + 1;
      cb_ptr -> b.name = cb_name;
      cb_ptr -> b.dname = "";
      cb_ptr -> b.ename = "";
      cb_ptr -> b.cname = "";
      cb_ptr -> b.kind = "";
      cb_ptr -> b.trust_sw = "1"b;
      if db_util
      then call ioa_$ioa_switch (db_output,
         "^[new^;old^]-cb ^d.^d b(^a)", new, env_ct,
	    dbase.bufnum, cb_name);
      if db_util
      then call tedshow_ (cb_ptr, ".", ltrim(char(dbase.bufnum)), "bcb");

   end allocate_cb; %skip (4);
get_seg: proc (seg_dp, seg_id_no, seg_use, a_code);

      seg_id_no = 0;		/* set seq # unspecified	       */

get_seg_n: entry (seg_dp, seg_id_no, seg_use, a_code);

dcl (
    seg_dp	ptr,		/* ptr to gotten segment	 [OUT] */
    seg_id_no	fixed bin,	/* sequence # of segment    [IN/OUT] */
    seg_use	char (8),		/* use of the segment (db info)      */
    a_code	fixed bin (35)
    )		parm;

      if (seg_id_no = 0)		/* if no slot specified, look..      */
      then			/*   ..for an unused one	       */
	 seg_id_no = index (substr (dbase.inuse_seg, 4), "0"b) + 3;
      if (seg_id_no > dbase.seg_ct)	/* there wasn't one so we're using.. */
      then dbase.seg_ct = seg_id_no;	/* ..a new one		       */
				/* (Really should check for 72 seg   */
				/* ..limit being exceeded.)	       */
      seg_dp = dbase.seg_p (seg_id_no);	/* get contents of this slot	       */
      if (seg_dp ^= null ())		/* is there something there?	       */
      then do;			/*   YES			       */
         substr (dbase.inuse_seg, seg_id_no, 1) = "1"b;
         goto exit;
      end;

dcl dirname	char (168);
dcl myname	char (32) var;
dcl ename		char (32);
dcl i		fixed bin;

get_base: entry (seg_dp, seg_id_no, seg_use, a_code);

      a_code = 0;
      ename = "ted_.yymmddHHMMSS.UUUUUU.000";
      if (dbase_p = null ())		/* getting the database segment      */
      then do;
         substr (ename, 6, 19) = rqid;
         substr (ename, 26) = "X";
         dirname = db_dir;
         if db_util
         then call ioa_$ioa_switch (db_output,
	  " ^[[pd]^s^;^a^] > ^a", (dirname = ""), dirname, ename);
         myname = ted_data.tedname;
      end;
      else do;			/* getting an auxiliary segment      */
/**** This routine enters new entries into dbase.seg_p. demote handles the   */
/****  freeing of them during execution. (cleanup, of course, cleans them    */
/****  all out at termination time.)				       */
         substr (dbase.inuse_seg, seg_id_no, 1) = "1"b;
         substr (ename, 6, 19) = dbase.rq_id;
         substr (ename, 26) = convert (pic3, seg_id_no);
         dirname = dbase.dir_db;
         myname = dbase.tedname;
      end;
      seg_dp = null ();
      if (dirname ^= "")		/* -safe/-temp_dir environment       */
      then do;
         call hcs_$make_seg (dirname, ename, "", 01011b, seg_dp, a_code);
         if (seg_dp = null ())
         then do;
	  call com_err_ (a_code, myname, "get_seg(^a>^a)",
	     dirname, ename);
	  goto abort_no_print;
         end;
         a_code = 0;
      end;
      else do;			/* environment is in [pd]	       */
         call get_temp_segment_ ((myname), seg_dp, a_code);
         if (a_code ^= 0)
         then do;
	  msg = "Getting temp segment";
	  goto abort_print;
         end;
      end;
      if (dbase_p ^= null ())
      then dbase.seg_p (seg_id_no) = seg_dp;
      else do;
         do i = -1 to 72;		/* initialize the ptr array	       */
	  seg_dp -> dbase.seg_p (i) = null ();
         end;
         seg_dp -> dbase.seg_p (0) = seg_dp; /* just for  completeness      */
         seg_dp -> dbase.seg_ct = 2;	/* reserve 1 and 2		       */
         string (seg_dp -> dbase.sws) = "0"b;
         if (db_dir ^= "")		/* The temp_dir given may not be the */
         then do;			/*  home_dir. Try to link to the     */
				/*  segment we just created	       */
	  call hcs_$append_link (get_default_wdir_ (), ename,
	     rtrim (dirname) || ">" || ename, a_code);
				/* If a name duplication then	       */
				/*  temp_dir IS home_dir, no sweat   */
	  if (a_code ^= 0)
	  then do;
	     if (a_code ^= error_table_$namedup)
	     then call com_err_ (a_code, ted_data.tedname,
		   "Trying to link to remote dbase ^a>^a.",
		   rtrim (dirname), ename);
	  end;
	  else seg_dp -> dbase.remote_sw = "1"b;

         end;
      end;
exit:
      if db_util
      then call ioa_$ioa_switch (db_output,
         "get_seg ^3d ^p ^a", seg_id_no, seg_dp, seg_use);

   end get_seg;
%page;
start: proc;

/**** This is a clean segment, so all fields which need to be initialized to */
/**** zero are left alone.					       */

      if db_util then call ioa_$ioa_switch (db_output,
         "begin start");
      dbase.tedname = ted_data.tedname; /* these 3 values		       */
      dbase.dir_db = db_dir;		/* ..must be set		       */
      dbase.rq_id = rqid;		/* ..before calling get_seg	       */
      dbase.cba_p = addr (cb (1));
      dbase.eval_p = null ();
      dbase.version = dbase_vers_3;
   /*** dbase.seg_p(*) is initialized by get_base		       */

      dbase.time = startup;
      dbase.argct = ted_data.arg_list_n - max (1, ted_data.arg_list_1) + 1;
      call user_info_ (dbase.person, dbase.project);
      dbase.nulreq = "p";
      dbase.err_go = "";
      dbase.recurs = env_ct + 1;

/****		        init call stack data			       */
      dbase.stk_info.top = null ();
      dbase.stk_info.curp = addr (cb (1));
      dbase.stk_info.level = 0;
      dbase.stk_info.next = 1;

/****		         request buffer space			       */
      bp = addr (cb (0));
      call re_alloc (bp, "(request line)");
      call tedpromote_ (bp, 4096);	/* get some buffer space	       */
      dbase.rl.part1 = b.cur;
      dbase.rl.part2 = b.b_;

/****		       allocate the console cb		       */
      call allocate_cb (bp, "(ted)");	/* ted_ will allocate the space      */
      call tedpromote_ (bp, 4096);	/* get some buffer space	       */
      b.tw_sw = "1"b;		/* ..where data will be read	       */
      b.terminate = "0"b;

/****			 allocate val cb			       */

      call allocate_cb (bp, "(val)");
      dbase.eval_p = bp;		/* a "buffer" segment will be gotten */
				/*  if evaluation is ever used.      */

/****		         process arg buffers			       */

      if (dbase.argct > 0)
      then do;
         call allocate_cb (bp, "args");
         b.noref = "1"b;
dcl arg_no	fixed bin;
dcl tbp		ptr;
         i = 0;			/* first find out how many chars     */
         do arg_no = ted_data.arg_list_1 to ted_data.arg_list_n;
	  call cu_$arg_ptr_rel (arg_no, arg_p, arg_l, code,
	     ted_data.arg_list_p);
	  i = i + arg_l + 1;
         end;
         call tedpromote_ (bp, i);	/* get enough room for args	       */
         b.a_.r.le (0), b.a_.r.re (0) = -1;
         b.maxln = dbase.argct;
         b.pseudo = "1"b;
         b.cur.ast = 0;		/* (make promotion work)	       */
         i = 1;
         do arg_no = ted_data.arg_list_1 to ted_data.arg_list_n;
	  call cu_$arg_ptr_rel (arg_no, arg_p, arg_l, code,
	     ted_data.arg_list_p);
	  substr (b_s, b.b_.l.re + 1, arg_l) = arg;
	  call allocate_cb (tbp, "arg" || ltrim (char (i)));
	  i = i + 1;
/****       Leave buffer empty if no data to put there.		       */
	  if (arg_l > 0)
	  then call tedpseudo_ (tbp, b.cur.sn, addr (b_c (b.b_.l.re + 1)), arg_l);
	  tbp -> b.a_.r.le (0), tbp -> b.a_.r.re (0) = -1;
	  tbp -> b.maxln = fixed (arg_l > 0);
	  tbp -> b.noref = "1"b;
	  b.b_.l.re = b.b_.l.re + arg_l + 1;
	  b_c (b.b_.l.re) = NL;
         end;
      end;

/*	allocate b(0) cb	*/

      call allocate_cb (bp, "0");
      dbase.cb_c_r = rel (bp);

      if db_util then call ioa_$ioa_switch (db_output,
         "end start");

   end; %page;
restart: proc;


      if (dbase.version ^= dbase_vers_3)
      then do;
         call com_err_ (0, dbase.tedname,
	  "Old version of ted dbase, cannot restart.");
         goto abort_no_print;
      end;
      if db_util then call tedshow_ (dbase_p, "> restart base");

      dbase.seg_p (0) = dbase_p;
      do i = 1 to dbase.seg_ct;
         if (dbase.seg_p (i) ^= null ())
         then do;
	  dbase.seg_p (i) = null ();
	  call get_seg_n (dbase.seg_p (i), (i), "reget_n ", code);
	  if (code ^= 0)
	  then goto abort_print;
         end;
      end;
      dbase.eval_p = addr (cb (2));
      dbase.cba_p = addr (cb (1));
      do i = 0 to dbase.bufnum;
         bp = addr (cb (i));
         if (b.cur.sn = -1)
         then do;
	  if cb (i).terminate | cb (i).initiate
	  then do;
	     addr (cb (i).cur.sp) -> its.segno = "77777"b3;
	     call tedck_ptr_ (addr (cb (i)));
	  end;
         end;
         if (b.cur.sn > 0)		/* was this an active pointer?       */
         then addr (b.cur.sp) -> its.segno
	       = addr (dbase.seg_p (b.cur.sn)) -> its.segno;
         if (b.pend.sn > 0)		/* was this an active pointer?       */
         then addr (b.pend.sp) -> its.segno
	       = addr (dbase.seg_p (b.pend.sn)) -> its.segno;
      end;
      dbase.rl.part1 = cb (0).cur;
      dbase.recurs = env_ct + 1;
      dbase.stk_info.top = null ();
      dbase.stk_info.curp = addr (cb (1));
      dbase.stk_info.level = 0;

      if db_util then call tedshow_ (dbase_p, "< restart base");
      return;


   end restart; %page;
dcl (addr, char, divide, fixed, index, length, null, search, substr,
    verify)	builtin;

%include ted_;
%include tedbase;
%include tedbcb;
%include tedstk;
%include tederror_;
%include tedcommon_;
dcl tedmgr_$list	entry;
dcl tedaddr_	entry (		/* process request addresses	       */
		ptr,		/* -> database		       */
		ptr,		/* -> string containing address      */
		fixed bin (21),	/*   length of it		  [IN] */
				/* If <0 then recursive call	       */
				/*   how much was used up	 [OUT] */
		ptr,		/* -> buffer control block  [IN/OUT] */
		char (168) var,	/* place to hold err message if any  */
		fixed bin (35),	/* status code		       */
				/*   0- null address	       */
				/*   1- address found	       */
				/*   8- error, msg tells what        */
		);


dcl tedck_ptr_	entry (ptr);
dcl tedcount_lines_ entry (		/* return # lines in string	       */
		ptr,		/* -> buffer in which to count       */
		fixed bin (21),	/* where string begins in segment    */
		fixed bin (21),	/* where string ends in segment      */
		fixed bin (21)	/* # lines		 [OUT] */
		);


dcl tedcloseup_	entry (		/* move all buffer data to lower     */
		ptr		/* -> to buffer to convert	       */
		);


dcl tedpromote_	entry (		/* get a larger data buffer	       */
		ptr,		/* -> buffer to promote	       */
		fixed bin (21)	/* amount not fitting	       */
		);


dcl tedpseudo_	entry (		/* make a pseudo (read-only) buffer  */
		ptr,		/* -> to buffer to convert	       */
		fixed bin,	/* segno of data (-1 if ^read)       */
		ptr,		/* -> the data		       */
		fixed bin (21)	/* the length of it 	       */
		);


dcl tedshow_	entry options (variable);
%include its;
   end tedmgr_;
 



		    tedshow_.pl1                    12/18/84  0939.0r w 12/18/84  0907.8      220734


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

ts_: tedshow_:			/* show parts of bcb or dbase	       */
   proc options (variable);
     goto start;

init:      entry;
     stk_init = "1"b;
     return;

dcl stk		(0:20) char (8) var int static;
dcl stkl		fixed bin int static init (0);
dcl stk_init	bit (1) int static init ("1"b);
dcl prefix	char (1) int static init (" ");

dcl concat	char (1024)var;
dcl work		char (256) var;
dcl token		char (8) var;
dcl name		char (8) var;
dcl abp		ptr based (arg_p);
dcl active	bit (1);
dcl argct		fixed bin;
dcl argno	fixed bin;
dcl arg_l		fixed bin (21);
dcl arg_p		ptr;
dcl arg		char (arg_l) based (arg_p);
dcl code		fixed bin (35);
dcl CR		bit (1);
dcl cu_$arg_count	entry (fixed bin, fixed bin(35));
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl td		fixed bin;
dcl tedshow_	entry() options (variable);
dcl new_name	bit (1);
dcl gvx_mark	char (1);
dcl NLct		fixed bin;
dcl i		fixed bin;
dcl ioa_$ioa_switch entry() options(variable);
dcl ioa_$ioa_switch_nnl
		entry() options(variable);
dcl printing	char (96) int static options (constant) init (
		" !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLM" ||
		"NOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");

start:
      CR = ""b;
      concat = "";
      if stk_init
      then do;
         stk_init = "0"b;
         stk(*)="???";
         stkl = 0;
         prefix = "@";
      end;
/****      call ioa_$ioa_switch (db_output, "stk(^i)=""^a""", stkl, stk(stkl));		       */
      call cu_$arg_count (argct, code);
      if (code ^= 0)
      then do;
         call com_err_ (code, "tedshow_");
         return;
      end;
      call cu_$arg_ptr (1, arg_p, arg_l, code);
      if (code ^= 0)
      then do;
         call com_err_ (code, "tedshow_");
         return;
      end;
      bp = abp;			/* for bcb, a1, a2, etc	       */
      dbase_p = ptr (bp, 0);
      if (dbase.version ^= dbase_vers_3)
         | (verify (dbase.rq_id, "0123456789.") ^= 0)
         | (verify (dbase.dir_db, printing) ^= 0)
         | (verify (dbase.person, printing) ^= 0)
         | (verify (dbase.project, printing) ^= 0)
      then dbase_p = null();
      else do;
dcl set_lock_$lock	entry (bit(36) aligned, fixed bin, fixed bin(35));
dcl error_table_$locked_by_this_process fixed bin(35) ext static;
         if (dbase.recurs = 0)
         | (dbase.lock = ""b)
         then active = ""b;
         else do;
				/* do NOT want to alter the value of */
				/*  dbase.lock, but want to test to  */
				/*  see if this process "owns" it.   */
	  call set_lock_$lock ((dbase.lock), -1, code);
				/* MUST pass dbase.lock by value!    */
	  if (code = error_table_$locked_by_this_process)
	  then active = "1"b;
	  else active = ""b;
         end;
      end;
      name = stk(stkl);
      prefix = " ";
      new_name = ""b;
      do argno = 2 to argct;
         call cu_$arg_ptr (argno, arg_p, arg_l, code);
         concat = concat || " ";
         concat = concat || arg;
         work = ltrim (arg);
         do while (work ^= "");
	  token = before (work, " ");
	  if new_name
	  then do;
	     new_name = ""b;
	     name = token;
	     if (prefix = "..")
	     then call ioa_$ioa_switch (db_output, "^a", name);
	     else do;
	        do td = 1 to stkl while (stkl > 0);
		 call ioa_$ioa_switch_nnl (db_output, 
"^[>^;:^]^a", (td = 1), stk (td));
	        end;
	        call ioa_$ioa_switch (db_output, "^[>^;:^]^a", (stkl < 1), name);
	        if (prefix = ">")
	        then do;
		 stkl = min (hbound (stk, 1), stkl + 1);
		 stk (stkl) = name;
	        end;
	     end;
	  end;
	  else do;
	     if (substr (token, length (token), 1) = ",")
	     then do;
	        NLct = 0;
	        token = substr (token, 1, length (token) - 1);
	     end;
	     else NLct = 1;
	     if (token = "*")	/* show "  * :"		       */
	     | (token = "<")	/* pop name from stack	       */
	     then do;
	        prefix = token;
	     end;
	     else if (token = ">")	/* push name on stack	       */
	     | (token = ".")	/* use temporary name	       */
	     | (token = "..")
	     then do;
	        prefix = token;
	        new_name = "1"b;
	     end;
	     else if (substr (token, 1, 1) = "[") /* literal string	       */
	     then do;
	        token = "";
	        call heading;
	        i = index (work, "]");
	        if (i = 0)
	        then i = length (work) - 1;
	        else i = i - 2;
	        call ioa_$ioa_switch_nnl (db_output, 
"^a", substr (work, 2, i));
	        CR = "1"b;
	        work = substr (work, i+1);
	     end;
	     else if (token = "max")
	     then do;
	        token = ":";
	        call heading;
	        call ioa_$ioa_switch (db_output, "b(^a) max=  1:^i(^i^[ PSEUDO^]",
		 b.name, b.maxl, b.maxln, b.pseudo);
	        last_bname = b.name;
	     end;
	     else if (token = "re")
	     then do;
	        if (dbase_p = null())
	        then goto not_avail;
	        call tedsrch_$dis_exp (addr (dbase.regexp));
	     end;
	     else if (token = "cf")
	     then do;
	        comptr = bp;
	        gvx_mark = "";
	        call cf_dumper;
	     end;
	     else if (token = "gvx")
	     then do;
	        comptr = bp;
	        call gvx_dumper;
	     end;
	     else if (token = "b_")
	     then call des (addr (b.b_));
	     else if (token = "b_*")
	     then do;
	        if (dbase_p = null())
	        then goto not_avail;
	        do i = 0 to dbase.bufnum;
		 bp = addr (DATABASE.cb(i));
		 call ioa_$ioa_switch_nnl (db_output, 
"b(^a)^21t^15p spa=^2i,^2i,^2i ",
		    b.name, b.cur.sp, b.cur.sn, b.cur.pn, b.cur.ast);
		 call des$no_last (addr (b.b_));
	        end;
	     end;
	     else if (substr (token, 1, 2) = "b(")
	        & (substr (token, length (token), 1) = ")")
	     then do;
	        if (dbase_p = null())
	        then goto not_avail;
	        token = substr (token, 3, length (token) - 3);
	        bp = null();
	        do i = 0 to dbase.bufnum;
		 bp = addr (DATABASE.cb(i));
		 if (b.name = token)
		 then goto found;
	        end;
	        call ioa_$ioa_switch (db_output, "*** b(^a) not found", token);
	        return;
found:
	        call ioa_$ioa_switch (db_output, "--> b(^a)", token);
	     end;
	     else if (token = "nb")
	     then call des (addr (b.newb));
	     else if (token = "ex")
	     then call des (addr (b.ex));
	     else if (token = "bx")
	     then do;
	        token = "b_";
	        call des (addr (b.b_));
	        token = "ex";
	        call des (addr (b.ex));
	     end;
	     else if (token = "so.ex")
	     then do;
	        if (dbase_p = null())
	        then goto not_avail;
	        sv_p = ptr (dbase.seg_p (3), b.stack_o);
	        token = "sex";
	        call des (addr (sv.ex));
	     end;
	     else if (token = "so.a0")
	     then do;
	        if (dbase_p = null())
	        then goto not_avail;
	        sv_p = ptr (dbase.seg_p (3), b.stack_o);
	        token = "sa0";
	        call des (addr (sv.a0));
	     end;
	     else if (token = "a0")
	     then do;
	        ad_b, ad_e = 0;
	        goto do_adr;
	     end;
	     else if (token = "a1")
	     then do;
	        ad_b, ad_e = 1;
	        goto do_adr;
	     end;
	     else if (token = "a2")
	     then do;
	        ad_b, ad_e = 2;
	        goto do_adr;
	     end;
	     else if (token = "adr")
	     then do;
	        ad_b = 0;
	        ad_e = 2;
	        hold_prefix = prefix;
	        prefix = " ";
dcl hold_prefix	char (1);
dcl (ad_b, ad_e)	fixed bin;
do_adr:
	        if (ad_b ^= ad_e)
	        then do;
		 prefix = hold_prefix;
		 token = "b_";
		 call des (addr (b.b_));
	        end;
	        do i = ad_b to ad_e;
		 token = "a";
		 token = token || ltrim (char (i));
		 if b.present (i)
		 then token = token || "p";
		 call des (addr (b.a_ (i)));
	        end;
	     end;
	     else if (token = "cd")
	     then call des (addr (b.cd));
	     else if (token = "gb")
	     then call des (addr (b.gb));
	     else if (token = "na")
	     then call des (addr (b.newa));
	     else if (token = "rt")
	     then call des (addr (b.rel_temp));
	     else if (token = "t0")
	     then call des (addr (b.temp (0)));
	     else if (token = "t1")
	     then call des (addr (b.temp (1)));
	     else if (token = "t2")
	     then call des (addr (b.temp (2)));
	     else if (token = "rl")
	     then do;
	        if (dbase_p = null())
	        then goto not_avail;
	        call pspa (addr (dbase.rl.part1));
	        token = "";
	        call des$no_last (addr (dbase.rl.part2));
	     end;
	     else if (token = "cur")
	     then call pspa (addr (b.cur));
	     else if (token = "pend")
	     then do;
	        if (unspec (b.pend) ^= unspec (b.cur))
	        then call pspa (addr (b.pend));
	     end;
	     else if (token = "base")
	     then do;
	        if (dbase_p = null())
	        then goto not_avail;
	        call dump_stk (1);
	        call dump_base;
	     end;
	     else if (token = "segs")
	     then do;
	        if (dbase_p = null())
	        then goto not_avail;
	        call segs;
	     end;
	     else if (token = "bcb")
	     then call bcb;
	     else if (token = "stkall")
	     then do;
	        if (dbase_p = null())
	        then goto not_avail;
	        call dump_stk (1);
	     end;
	     else if (token = "stktop")
	     then do;
	        if (dbase_p = null())
	        then goto not_avail;
	        call dump_stk (dbase.stk_info.level);
	     end;
	     else if (substr (token, 1, 1) = "?")
	     then do;
	        if (token = "?")
	        then do;
		 do qm = 1 to hbound (item, 1);
		    call ioa_$nnl (" ""^a""", substr (item(qm), 1, 6));
		 end;
		 call ioa_$nnl ("^2/");
	        end;
	        else do;
		 token = substr (token, 2);
		 done = ""b;
		 do qm = 1 to hbound (item, 1) while (^done);
		    if (substr (item(qm), 1, 6) = token)
		    then do;
		       call ioa_$nnl ("^7a ^a^/", token, substr (item(qm), 7));
		       done = "1"b;
		    end;
		 end;
		 if ^done
		 then call ioa_$nnl ("""^a"" is not defined^/", token);
	        end;
	        
		 
dcl qm		fixed bin;
dcl done		bit (1);
dcl ioa_$nnl	entry() options(variable);
dcl item		(39) char (18) int static options (constant) init (
		"?     ------------",
		"?X    ------------",
		"*     ------------",
		".     ------------",
		"..    ------------",
		"<     ------------",
		"> X   ------------",
		"[X    ------------",
		"[X]   ------------",
		"a0    ------------",
		"a1    ------------",
		"a2    ------------",
		"adr   ------------",
		"b_    ------------",
		"b_*   ------------",
		"base  ------------",
		"bcb   ------------",
		"bx    ------------",
		"cd    ------------",
		"cf    ------------",
		"cur   ------------",
		"ex    ------------",
		"gb    ------------",
		"gvx   ------------",
		"max   ------------",
		"na    ------------",
		"nb    ------------",
		"pend  ------------",
		"re    ------------",
		"rl    ------------",
		"rt    ------------",
		"segs  ------------",
		"so.a0 ------------",
		"so.ex ------------",
		"stkall------------",
		"stktop------------",
		"t0    ------------",
		"t1    ------------",
		"t2    ------------");
	     end;
	     else do;
	        call ioa_$ioa_switch (db_output, "??? ^a", token);
	     end;
	     if (prefix = "<") & (token ^= "<")
	     then do;
	        do td = 1 to stkl while (stkl > 0);
		 call ioa_$ioa_switch_nnl (db_output, 
"^[^/^]^1a^a", CR, prefix, stk (td));
		 CR = ""b;
		 prefix = ":";
	        end;
	        call ioa_$ioa_switch (db_output, "");
	        stkl = max (0, stkl - 1);
	        name = stk (stkl);
	        prefix = " ";
	     end;
	  end;
	  work = ltrim (after (work, " "));
         end;
      end;
      if CR then call ioa_$ioa_switch (db_output, "");
      return;

not_avail:
      call ioa_$ioa_switch (db_output, "tedshow_: dbase_p not available to do ^a.", token);
      return;

heading: proc;

	  if move_right
	  then call ioa_$ioa_switch_nnl (db_output, 
"^2-");
	  call ioa_$ioa_switch_nnl (db_output, 
" :^4a", token);

      end heading;

des: proc (bd_p);
dcl bd_p		ptr;

dcl 1 bd		like buf_des based (bd_p);

      if (last_bname ^= b.name)
      then do;
         call ioa_$ioa_switch (db_output, "^2-    :---b(^a)", b.name);
         last_bname = b.name;
      end;
      if (unspec (bd) = unspec (tedcommon_$no_data))
      then do;
         return;
      end;

des$no_last: entry (bd_p);

      call heading;
      call ioa_$ioa_switch (db_output, 
         "l=^4i:^i(^i^v.1tr=^4i:^i(^i^[ lv=^i
^6xex_next:ex_EOD^v.1tex_lre:ex_last^]",
         bd.l.le, bd.l.re, bd.l.ln, indent,
         bd.r.le, bd.r.re, bd.r.ln, (token="ex"), dbase.stk_info.level, indent);
   end des; %skip (2);
pspa: proc (sd_p);
dcl (
    sd_p		ptr		/* segment descr to display	       */
    )		parm;
dcl 1 sd		like seg_des based (sd_p);

/*      if (prefix ^= " ")					       */
/*      then call heading;					       */
      if (unspec (sd) = unspec (tedcommon_$no_seg))
      then do;
         return;
      end;
      call heading;
      call ioa_$ioa_switch (db_output,
         "^p sn=^i pn=^i ast=^i^[(255K)^;(64K)^;(16K)^;(4K)^;(1K)^]",
         sd.sp, sd.sn, sd.pn, sd.ast, sd.ast);

   end pspa; %skip (3);
segs: proc;
  
      call ioa_$ioa_switch (db_output, "    .. ................ r/u c/l");
      do i = -1 to dbase.seg_ct;
         if (dbase.seg_p (i) ^= null ())
         then do;
	  if active
	  then do;
	     call hcs_$fs_get_path_name (dbase.seg_p (i),
	        dname, 0, ename, code);
	     if (code ^= 0) then call com_err_ (code, "get_pn", "^p",
	        dbase.seg_p (i));
	     call hcs_$status_long (dname, ename, 1, addr (sb),
	        null(), code);
	     if (code ^= 0) then call com_err_ (code, "stat_lg", "^a > ^a",
	        dname, ename);
	     call ioa_$ioa_switch_nnl (db_output, 
"    ^2i ^16p ^3i ^3i", i, dbase.seg_p (i),
	        sb.records_used, sb.current_length);
	  end;
	  else call ioa_$ioa_switch_nnl (db_output, 
"    ^2i ^16p ??? ???", i,   dbase.seg_p (i));

	  if (i = 0)
	  then call ioa_$ioa_switch (db_output, " segs=^b",
	     substr (dbase.inuse_seg,1,dbase.seg_ct));
	  else if (i = 1)
	  then call ioa_$ioa_switch (db_output, " 1K=^b 4K=^b", dbase.inuse_1K,dbase.inuse_4K);
	  else if (i = 2)
	  then call ioa_$ioa_switch (db_output, " 16K=^b", dbase.inuse_16K);
	  else call ioa_$ioa_switch (db_output, "");
         end;
      end;

dcl hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr,
		fixed bin(35));
dcl hcs_$fs_get_path_name entry (ptr, char(*), fixed bin, char(*),
		fixed bin(35));
dcl dname		char (168);
dcl ename		char (32);
dcl code		fixed bin (35);
%include status_structures;
dcl 1 sb like status_branch;

		
   end segs;
dump_base: proc;


      call ioa_$ioa_switch (db_output, "  version=^i recurs=^i bwd=^p cba_p=^p eval_p=^p",
         dbase.version, dbase.recurs, dbase.bwd, dbase.cba_p, dbase.eval_p);
      call segs;

      call ioa_$ioa_switch (db_output, "  inuse:16K=^.b  4K=^.b  1K=^.b  seg=^.b",
         dbase.inuse_16K, dbase.inuse_4K, dbase.inuse_1K,
         substr (dbase.inuse_seg, 1, dbase.seg_ct + 1));
dcl date_time_	entry options (variable) returns (char (21));
      call ioa_$ioa_switch (db_output, "  time=^a ^a seg_ct=^i argct=^i S_count=^i",
         date_time_ (dbase.time), dbase.rq_id, dbase.seg_ct, dbase.argct,
         dbase.S_count);
      call ioa_$ioa_switch (db_output, "  not_read_ct=^i at_break=^i bufnum=^i lock=^.3b",
         dbase.not_read_ct, dbase.at_break, dbase.bufnum, dbase.lock);
      call ioa_$ioa_switch (db_output, "  cb_c_r=^6.3b cb_w_r=^6.3b", dbase.cb_c_r, dbase.cb_w_r);
      call ioa_$ioa_switch (db_output, " ^[ flow^]^[ break^]^[ edit^]^[ input^]^[ old^]"
         || "^[ read^]^[ lit^]",
         dbase.flow_sw, dbase.break_sw, dbase.edit_sw, dbase.input_sw,
         dbase.old_style, dbase.read_sw, dbase.lit_sw);
      call ioa_$ioa_switch (db_output, " name=^a  ^a.^a comment=^a", dbase.tedname,
         dbase.person, dbase.project, dbase.comment);
      call ioa_$ioa_switch (db_output, " dir_db=^a^[ REMOTE^]", dbase.dir_db, dbase.remote_sw);
      call ioa_$ioa_switch (db_output, " error=""^a""  err_go=""^a""", dbase.err_msg, dbase.err_go);
      call tedshow_ (dbase_p, "rl");

      do i = 0 to dbase.bufnum;
         call tedshow_ (addr (DATABASE.cb(i)),
	  "..", ltrim(char(i)), "bcb");
      end;

   end dump_base;
dcl 1 DATABASE	based (dbase_p),
      2 zzzzzz	like dbase,
      2 cb	(0:DATABASE.bufnum) like b;
dump_stk: proc (lower);
dcl lower		fixed bin (21);
dcl seg_fault_error condition;
dcl j		fixed bin (21);
dcl tbp		ptr;
dcl str		char (2048)based;

      on condition (seg_fault_error)
      begin;
         call ioa_$ioa_switch (db_output, " curp=x|x top=x level=x next=x");
         goto seg_flt;
      end;
      call ioa_$ioa_switch (db_output, " curp=^p  top=^p  level=^d  next=^d",
         dbase.stk_info.curp, dbase.stk_info.top, dbase.stk_info.level,
         dbase.stk_info.next);
      if (dbase.seg_p (3) = null ()) | (dbase.stk_info.level = 0) | ^active
      then return;
      sv_p = dbase.stk_info.top;
dcl dd (2) char (80)var int static options(constant) init (
" lvl) this ...sv..... ...bcb.... (lines) .link. b.ex..",
"^04i) ^04i ^00000010p ^00000010p (^005i) ^06.3b ^4i,^4i,^4i,^4i^/^-b(^a) pn=^i");
      call ioa_$ioa_switch (db_output, dd (1));
      do i = dbase.stk_info.level to lower by -1;
         tbp = sv.bp;
         call tedcount_lines_ (tbp, 1, tbp -> b.maxl, j);
         call ioa_$ioa_switch (db_output, dd (2), i, sv.this, sv_p, tbp, j, sv.stackl, sv.ex.l.le,
	  sv.ex.l.re, sv.ex.r.le, sv.ex.r.re, tbp -> b.name, sv.pn);
         if (sv.pn > 0)
         then call ioa_$ioa_switch (db_output, "^2-""^va""", sv.pl (0),
	       substr (sv.pp (0) -> str, 1, sv.pl (0)));
         sv_p = sv.prev;
      end;
seg_flt:
      revert condition (seg_fault_error);
   end dump_stk;

bcb: proc;

      call heading;
      if (b.name = "")
      then do;
         call ioa_$ioa_switch (db_output, " ^10p EMPTY", bp);
      end;
      else do;
         call ioa_$ioa_switch (db_output, " ^10p old=^i,^i new=^i,^i",
	  bp, b.old.le, b.old.re, b.new.le, b.new.re);
         stkl = stkl + 1;
         stk (stkl) = "..";
         call tedshow_ (bp, "max cur b_ nb ex a0 a1 a2 cd gb na rt t0 t1 t2");
         stkl = stkl - 1;
         if b.mod_sw | b.terminate | b.get_bit_count | b.force_name
	  | b.no_io | b.not_pasted | b.initiate | b.ck_ptr_sw
	  then call ioa_$ioa_switch (db_output, "   ^[ mod^]^[ term^]^[ getbc^]^[ force^]"
	  || "^[ ^I/O^]^[ ^^paste^]^[ init^]^[ ckptr^]",
	  b.mod_sw, b.terminate, b.get_bit_count, b.force_name, b.no_io,
	  b.not_pasted, b.initiate, b.ck_ptr_sw);
         if (b.dname ^= "")
         then call ioa_$ioa_switch (db_output, "^12x^a^[ > ^a ^a ^a^[ [trust]^]^]",
	  b.dname, b.file_sw, b.ename, b.kind, b.cname,
	  b.trust_sw);
      end;
   end bcb;%page;
gvx_dumper: proc;
dcl ti		fixed bin;

      call ioa_$ioa_switch (db_output, "^[^14p^;^s^]max=^i tot=^i srch=^i mk=^i ic=^i", db_gv,
         comptr, gvx.max_len, gvx.tot_len, gvx.srch_len, gvx.mk_list, gvx.ic);

      ti = gvx.ic;			/* save the IC value	       */
      gvx_mark = "~";
      gvx.ic = 1;
      do while (gvx.ic < gvx.tot_len);
         if (gvx.ic = gvx.srch_len+1)
         then call ioa_$ioa_switch (db_output, "^[^14x^]   |--srch_len=^i", db_gv, gvx.srch_len);
         call cf_dumper;
         gvx.ic = gvx.ic + cf.siz;
      end;
      call ioa_$ioa_switch (db_output, "^[^14p^;^s^]   |---tot_len=^i", db_gv,
         addr (gvx.word (gvx.ic)), gvx.tot_len);
      gvx.ic = ti;			/* restore the IC value	       */

   end gvx_dumper;%skip(5);
cf_dumper: proc;

re_dump:
      if (gvx.ic > gvx.tot_len)
      then do;
         call ioa_$ioa_switch (db_output, "ERROR: ic=^i > tot=^i", gvx.ic, gvx.tot_len);
         return;
      end;
      cfp = addr (gvx.word (gvx.ic));
      call ioa_$ioa_switch_nnl (db_output, 
"^[^14p^;^s^]^1a^[^p^-^;^s^]^3i# ^2iop ^3isiz ^3ilen ",
         db_gv, cfp, gvx_mark, lg_sw, cfp, gvx.ic, cf.op, cf.siz, cf.len);
      if (cf.op >= -7) & (cf.op <= 22)
      then goto show (cf.op);
      call ioa_$ioa_switch (db_output, " ERROR");
      return;

show (-7):			/* test done, was success	       */
      call ioa_$ioa_switch (db_output, "success");
      return;
show (-6):			/* search test		       */
      call ioa_$ioa_switch (db_output, "t=^i f=^i //", cft.t, cft.f);
      exp_p = addr (cft.cexpml);
      goto regexp;
show (-5):			/* evaluation test		       */
      call ioa_$ioa_switch (db_output, "t=^i f=^i ^a", cft.t, cft.f, cft.da);
      return;
show (-4):			/* evaluation replacement	       */
      call ioa_$ioa_switch (db_output, "(r) ^a", cf.da);
      return;
show (-3):			/* x\= replacement		       */
      call ioa_$ioa_switch (db_output, "^a\=", cf.da);
      return;
show (-2):			/* & replacement		       */
      call ioa_$ioa_switch (db_output, "&");
      return;
show (-1):			/* literal replacement	       */
      call ioa_$ioa_switch (db_output, """^va""", cf.len, cf.da);
      return;
show (00):			/* end of program		       */
      call ioa_$ioa_switch (db_output, "EOP");
      return;
show (01):			/* ( address processing	       */
      call ioa_$ioa_switch (db_output, "(^i,^i)", cfa.ad1, cfa.ad2);
      return;
show (04):			/* K - kopy-append		       */
show (05):			/* M - move-append		       */
show (06):			/* k - kopy		       */
show (07):			/* m - move		       */
      call ioa_$ioa_switch (db_output, "^a(^.3b) ^i", substr (op_mnem, cf.op, 1), cfmk.cb_r,
         cfmk.link);
      return;
show (11):			/* t - type to user_output	       */
show (12):			/* T - type to error_output	       */
      call ioa_$ioa_switch (db_output, "^a|^a|", substr (op_mnem, cf.op, 1), cf.da);
      return;
show (17):			/* { - evaluation		       */
      call ioa_$ioa_switch (db_output, "^a", cf.da);
      return;
show (18):			/* a - append		       */
show (19):			/* c - change		       */
show (20):			/* i - insert		       */
      call ioa_$ioa_switch (db_output, "^a ^va\f", substr (op_mnem, cf.op, 1), cf.len, cf.da);
      return;
show (08):			/* s - substitute		       */
show (15):			/* u - lowercase translate	       */
show (16):			/* U - uppercase translate	       */
      call ioa_$ioa_switch (db_output, "^a/.../", substr (op_mnem, cf.op, 1));
      exp_p = addr (cfx.cexpml);
regexp:
      call tedsrch_$dis_exp (exp_p);
      return;

dcl exp_p		ptr;

show (02):			/* p - print		       */
show (03):			/* P - print w/ linenumber	       */
show (09):			/* d - delete		       */
show (10):			/* = - linenumber		       */
show (13):			/* l - linefeed to user_output       */
show (14):			/* L - linefeed to error_output      */
show (22):			/* > -stop global if, goto	       */
      call ioa_$ioa_switch (db_output, "^a", substr (op_mnem, cf.op, 1));
      return;
show (21):			/* SP !!			       */
      call ioa_$ioa_switch (db_output, "SP shouldn't be here");
      return;

/****				        00000000011111111112222      */
/****				        12345678901234567890123      */
dcl op_mnem	char (22) int static init ("(pPKMkmsd=tTlLuU{aci >");

   end cf_dumper;%skip(3);
dcl com_err_	entry() options(variable);
dcl tedsrch_$dis_exp entry (ptr);
dcl last_bname	char(16) int static init ("");
dcl (
    addr, after, before, char, hbound, index, length, ltrim, max, min, null, ptr, substr, unspec, verify
    )		builtin;

bf: entry; indent = 17; return;
dcl indent	fixed bin int static init (26);
mlf: entry; move_right = ""b; return;
mln: entry; move_right = "1"b; return;
dcl move_right	bit (1) int static init (""b);
lgf: entry; lg_sw = ""b; return;
lgn: entry; lg_sw = "1"b; return;
dcl lg_sw	bit (1) int static init (""b);
%include tedgvd;
%include tedcommon_;
%include tedbcb;
%include tedbase;
%include tedstk;
dcl tedcount_lines_ entry (		/* return # lines in string	       */
		ptr,		/* -> buffer in which to count       */
		fixed bin (21),	/* where string begins in segment    */
		fixed bin (21),	/* where string ends in segment      */
		fixed bin (21)	/* # lines		 [OUT] */
		);


   end tedshow_;
  



		    tedsort_.pl1                    10/07/88  1311.2rew 10/07/88  1305.3      288477


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-08-03,RWaters), approve(88-08-03,MCR7950), audit(88-09-29,Huen),
     install(88-10-07,MR12.2-1146):
     Bug fixes for MR12.2.
                                                   END HISTORY COMMENTS */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

/*							       */
/*   _|_              |                        _|_		       */
/*    |      _      _ |   ___     _      _      |			       */
/*    |     / \    / \|  /  _    / \   |/ \     |			       */
/*    |    (__/   (   |  \_/ \  (   )  |        |			       */
/*    \_    \_/    \_/|   ___/   \_/   |        \_		       */
/*                                                   -----		       */
/*							       */

/**** <<<<----- dcl_tedsort_.incl.pl1 tedsort_			       */
tedsort_:				/* sort in a buffer		       */
   proc (ain_p, ain_l, adata_p, adata_l, temp_p, out_l, msg, rc);
dcl (
    ain_p		ptr,		/* -> key specifications	       */
    ain_l		fixed bin (21),	/*   length thereof		       */
    adata_p	ptr,		/* -> string to be sorted	       */
    adata_l	fixed bin (21),	/*   length thereof		       */
    temp_p	(3) ptr,		/* working segments		       */
				/*  (1) temp seg		       */
				/*  (2) temp seg		       */
				/*  (3) output seg		       */
    out_l		fixed bin (21),	/* length of result		 [OUT] */
    msg		char (168) var,	/* error details		       */
    rc		fixed bin (35)	/* return code		 [OUT] */
    )		parm;		/* ----->>>>		       */

/****    03/19/74  Dave Ward initial coding			       */
/****    04/09/74  Jim Falksen expanded it			       */
/****    02/17/82  jaf	reworked for split buffer		       */
/****    07/08/88  RW #198 phx20146:  infinite loop when given j/1/          */

/**** Sort the "records" in a string into a new string.  Either a	       */
/**** "regular" (fast) sort or a "special" (user supplied collating	       */
/**** sequence) may be specified.  Sorting may be on multiple keys	       */
/**** defined in the specification string. Two temporary segments must       */
/**** also be supplied as well as the output segment.		       */

/**** [1] The first string contains the specification of keys.  If this      */
/**** is a null string then reqular sort is selected with the whole	       */
/**** record as a key, in ascending order.  Syntax of the specification:     */
/****							       */
/****	?  |  {'ooo}{P1{,P2}... } | s={cs}			       */
/****							       */
/****	"?"  => display current special collating sequence	       */
/****	'ooo => octal specifier of record delimiter. Default is '012       */
/****	Pi   => {k}f  |  ={f}  |  s				       */
/****	     k    => "a" | "A" for ascending sort (default)	       */
/****	             "d" | "D" for descending sort.		       */
/****	     f    => m,m  1st m is beginning offset, 2nd is length	       */
/****		   m:m  1st m is beginning offset, 2nd is ending one     */
/****		   m,-  old form for "m:$"			       */
/****		m    => n    number, measured from beginning of record   */
/****		        $    end of record			       */
/****		        $-n  number, measured from end of record	       */
/****	     "="  => duplicate record handling (see below)	       */
/****	     "s"  => use special collating sequence		       */

/****	"s=" => set special collating sequence to default		       */
/****     "s=cs" => modify default by specification "cs" (Jset format)       */

/**** An "=" key indicates that no duplicates are wanted.  The last one      */
/**** will be kept.  The =n1,n2 form defines a field beginning at n1 with    */
/**** length of n2.  The =n1:n2 form defines a field beginning at n1 and     */
/**** ending at n2.  The count of how many of this kind of record existed is */
/**** to be placed in this field.				       */

/**** [2] The second string contains the records to be sorted.  A	       */
/**** "record" is a string of characters delimited by the record	       */
/**** delimiter character on the right, and including this character.  If    */
/**** the input string does not terminate with a record delimiter it is      */
/**** treated as if one follows the last character.  The default record      */
/**** delimiter is NL.					       */

/**** [3] The caller must set "temp_p(1)" and "temp__p(2)" to two aligned    */
/**** areas.  The first area must contain atleast as many (36 bit) words     */
/**** as the number of records to sort.  The second area must be twice       */
/**** this length.  "temp_p(3)" points to the area to receive the sorted     */
/**** string.						       */

/**** [4] The length of the sorted result is returned via "out_l". If the    */
/**** "=" specification is not given, the output length will equal the       */
/**** input length. Otherwise is could be longer or shorter.	       */

/**** [5} "rc" is a value indicating whether the keys were proper.	       */
/****	rc=0 =>	normal completion				       */
/****	rc=1 =>	syntax error in specification, expr_l points to it       */
/****	rc=2 =>	only 1 input record, nothing was put in output string    */
%page;
start:
      if Minit			/* if first time into this proc      */
      then do;			/*   initialize it		       */
         reset = MASTER;
         call set;
      end;
      rc = 0;			/* keys OK.		       */
      eq_field = ""b;
      no_dupl, spec_sw = "0"b;
      spec_p = ain_p;
      spec_i = 1;
      spec_l = ain_l;
      call get_delim;
      call get_keys;
      nk = max (nk, 1);

/**** Isolate the "records" in the input.			       */
      Rp = temp_p (1);		/* 1st temp segment.	       */
      R (1) = 1;			/* first line at beginning	       */
      input_i = 1;
      input_l = adata_l;
      input_p = adata_p;
      num_rec = 1;
      do while (input_i <= input_l);
				/* find end of record	       */
         j = index (substr (input, input_i), rec_delim);
         if (j < 1)
         then j = input_l - input_i + 1;
         input_i = input_i + j;
         num_rec = num_rec + 1;
         if (num_rec > 65536)
         then do;			/* Segment exceeded.	       */
	  num_rec = 65536;
	  input_i = input_l + 1;	/* End examination for "records".    */
         end;
         else R (num_rec) = input_i;
      end;

/* Sort the input. Construct sort index.			       */
      num_rec = num_rec - 1;		/* Adjust	to actual # of records.    */
      if (num_rec = 1)		/* don't bother if only 1 record     */
      then do;
         rc = 2;
         return;
      end;
      SLp = temp_p (2);		/* 2nd temp segment.	       */

      Op = temp_p (3);		/* output string segment	       */
      Oe = 0;

      call SORT;

      out_l = Oe/* - 1*/;
      rc = 0;
      return; %skip (2);
key_error:
      ain_l = spec_i;
      rc = 1;
      return; %page;
/**** <<<<----- dcl_tedsort_.incl.pl1 tedsort_$show		       */
show:				/* print special collating sequence  */
   entry;
/*dcl (							       */
/*				/* no arguments		       */
/*     )		parm;		/*  ----->>>>		       */

dcl jnum		fixed bin (21),
    jchar		char (4) based (addr (jnum));

show:
      if Minit
      then do;
         reset = MASTER;
         call set;
      end;
      Lp = addrel (addr (L), 1);
      L = " ";
      do i = 0 to 510;
         do jnum = 0 to 511;
	  if rank (M (jnum)) = i
	  then do;
	     M1 = substr (jchar, 4, 1);
	     if (M1 < "!") | (M1 > "~")
	     then do;
	        L = L || "\";
	        L = L || OC (fixed (M11));
	        L = L || OC (fixed (M12));
	        L = L || OC (fixed (M13));
	     end;
	     else L = L || M1;
	     if length (L) > 72
	     then do;
	        call ioa_ (L);
	        L = "\c";
	     end;
	  end;
         end;
         if L = "\c"
         then L = "";
         else if (substr (L, length (L), 1) ^= " ")
         then L = L || " ";
      end;
      call ioa_ (L);
      return; %page;
/**** <<<<----- dcl_tedsort_.incl.pl1 tedsort_$set		       */
set:				/* set special collating sequence    */
   entry (setting);
dcl (
    setting	char (*)		/* user's specification	       */
    )		parm;		/* ----->>>>		       */


      Lp = addrel (addr (L), 1);
				/* Reset the mapping array (M). */
      call cu_$arg_count (ii, 0);
      reset = MASTER;
      if ii ^= 0
      then reset = reset || setting;
      call set;
      return;

set_error:
      return; %page;
set: proc;			/* set the mapping array	       */

      Minit = "0"b;
      l = length (reset);
      NS = 1;
      if db_sort
      then call ioa_$ioa_switch (db_output,
         "^i-->^i",NS,l);
      do while (pair (ff1, ll1, bb1, ff2, ll2, bb2));
         if ((ff2 - ll2) ^= 0)
         & (abs (ff2 - ll2) ^= abs (ff1 - ll1))
         then do;
	  msg = "Jun) Unequal number of range members";
	  goto set_error;
         end;
         if (ff2 = ll2)
         then bb2 = 0;
         j = ff2;
         do i = ff1 to ll1 by bb1;
	  M (i) = byte (j);
	  j = j + bb2;
         end;
         if db_sort
         then call ioa_$ioa_switch (db_output,
	  "^i->^i",NS,l);
      end;
      return;

   end set; %skip (4);
pair: proc (f1, l1, b1, f2, l2, b2) returns (bit (1));
				/* returns 1 if proper pair exists   */

dcl (f1,				/* first "from" value	       */
    f2,				/* last "from" value	       */
    l1,				/* "from" increment		       */
    l2,				/* first "to" value		       */
    b1,				/* last "to" value		       */
    b2				/* "to" increment		       */
    )		fixed bin (21) parm;

      if NK (f1, l1, b1) then do; return ("0"b); end;
      if ^NK (f2, l2, b2)
      then do;
         if db_sort
         then call ioa_$ioa_switch (db_output,
	  "^(  ^i,^i,^i^)", f1,l1,b1, f2,l2,b2);
         return ("1"b);
      end;
      msg = "Jnp) Reset string is not pairs.";
      goto set_error;

   end pair; %skip (4);
NK: proc (af, al, ab) returns (bit (1));
				/* returns 1 if value ^exist	       */

dcl (af		fixed bin (21),	/* first pair value		       */
    al		fixed bin (21),	/* last pair value		       */
    ab		fixed bin (21)	/* increment value (+1 | -1)	       */
    )		parm;

      if K (af)
      then return ("1"b);
      al = af;
      ab = 1;
      if (NS < l)
      then do;
         if (substr (reset, NS, 2) = "->")
         then do;
	  NS = NS + 2;
	  if K (al)
	  then do;
	     msg = "Jmv) Missing value after ""->""";
	     goto set_error;
	  end;
	  if al < af
	  then ab = -1;
	  else ab = 1;
         end;
      end;
value_present:
      return ("0"b);

   end NK; %page;
K: proc (j) returns (bit (1));
				/* returns 1 if no value present     */
dcl j		fixed bin (21) parm;

      if (NS > l)
      then goto no_value;
      if (substr (reset, NS, 1) ^= "'")
      then do;
         j = fixed (unspec (substr (reset, NS, 1)));
         NS = NS + 1;
         goto value_present;
      end;
				/* => Escaped character. */
      NS = NS + 1;
      if (NS+2 > l)
      then goto no_value;		/* not enough left to process	       */
      if (verify (substr (reset, NS, 3), "01234567") = 0)
      then do;
         unspec (octals) = unspec (substr (reset, NS, 3));
         j = bin (octals (3)||octals (6)||octals(9));
         NS = NS + 3;
         goto value_present;
      end;
no_value:
      return ("1"b);
value_present:
      return (""b);
dcl octals	(9) bit (3)unal;


   end K; %skip (10);
dcl OC		(0:7) char (1) int static
		init ("0", "1", "2", "3", "4", "5", "6", "7");
dcl i1		fixed bin (35);%skip(3);
get_delim: proc;

dcl j		fixed bin (21);

      rec_delim = "
";
      if (spec_l = 0)
      then return;
      spec_i = 1;
      if (spec_c (spec_i) = "s")
      then do;
         spec_sw = "1"b;
         spec_i = spec_i + 1;
      end;
      if (spec_c (spec_i) = "'")
      then do;
         j = cv_oct_check_ (substr (spec, spec_i+1, 3), i1);
         if (i1 ^= 0)
         then do;
	  spec_i = spec_i + i1;
	  msg = "Sno) Non-octal digit in delimiter specification.";
	  goto key_error;
         end;
         rec_delim = byte (j);
         spec_i = spec_i + 4;
         if (spec_c (spec_i) = ",")
         then spec_i = spec_i + 1;
      end;

   end get_delim; %page;
get_keys: proc;

      nk = 0;

      do while (spec_i <= spec_l);
         nk = nk + 1;		/* Count the keys.		       */
         keys.order (nk) = "1"b;	/* Assume	ascending.	       */
         ch = spec_c (spec_i);
         spec_i = spec_i + 1;
         if (ch = "s")
         then do;			/* Calling for special sequence      */
	  nk = nk - 1;		/*  (doesn't count as a key)	       */
	  spec_sw = "1"b;
         end;			/* leave do -> last char used	       */
         else do;
	  got_pair = ""b;
dcl key_type	fixed bin;
	  key_type = index ("=adAD", ch);
	  if (key_type > 3) then key_type = key_type - 2;
/* RW 88 */
	  if (key_type = 0) then do;
                 spec_i = spec_i - 1;
	       if (spec_i = spec_l) then do;                        /*#198*/
		  msg = "Jms) Missing 2nd value";                 /*#198*/
		  goto key_error;                                 /*#198*/
		  end;                                            /*#198*/
	  end;

	  if (spec_i < spec_l)
	  then if (spec_c (spec_i) ^= ",")
	  then do;
	     call get_pair (keys.loc1 (nk), keys.loc2 (nk), keys.n_n (nk));
	     got_pair = "1"b;
	  end;
	  if (key_type = 1)		/* "="			       */
	  then do;
	     eq_field = got_pair;
	     eq_loc = keys.loc1 (nk);
	     eq_leng = keys.loc2 (nk);
	     eq_n_n = keys.n_n (nk);
	     nk = nk - 1;
	     no_dupl = "1"b;
	     if got_pair
	     then do;
	        if eq_n_n & (eq_loc-eq_leng > 11)
	        | ^eq_n_n & (eq_leng > 12)
	        then do;
		 msg = "Jll) = field length > 12";
		 goto key_error;
	        end;
	     end;
	     got_pair = "1"b;
	  end;
	  else if (key_type = 3)	/* "d"			       */
	  then keys.order (nk) = "0"b;
	  if ^got_pair
	  then do;
	     keys.loc1 (nk) = 1;	/* first char of record	       */
	     keys.n_n (nk) = "1"b;	/* n:n format		       */
	     keys.loc2 (nk) = 0;	/* last char of record	       */
	  end;
	  if (spec_i < spec_l)
	  then do;
	     if (spec_c (spec_i) = ",")
	     then spec_i = spec_i + 1;
	     else do;
	        msg = "Jmc) Missing comma.";
	        goto key_error;
	     end;
	  end;
         end;
      end;
      if (nk = 0)
      then do;
         nk = 1;
         keys.order (1) = "1"b;	/* plug in default values first      */
         keys.loc1 (1) = 1;		/* first char of record	       */
         keys.n_n (1) = "1"b;		/* n:n format		       */
         keys.loc2 (1) = 0;		/* last char of record	       */
      end;

dcl ch		char (1);
dcl got_pair	bit (1);
get_pair: proc (v1, v2, n_n);

dcl ((v1, v2)	fixed bin (21),
    n_n		bit (1) aligned
    )		parm;


      if ^get_single (v1)
      then do;
         msg = "Kuk) Unknown key type";
         goto key_error;
      end;
      if (spec_c (spec_i) = ":")
      then do;
         n_n = "1"b;		/* n:n form		       */
         spec_i = spec_i + 1;
      end;
      else if (spec_c (spec_i) = ",")
      then do;
	  spec_i = spec_i + 1;
         if (spec_c (spec_i) = "$")
         then do;
	  msg = "Jnd) $ not allowed as a length.";
	  goto key_error;
         end;
         n_n = ""b;		/* n,l form		       */
         if (spec_c (spec_i) = "-")
         then do;
	  spec_i = spec_i + 1;
	  v2 = 0;
	  n_n = "1"b;
	  return;
         end;
      end;
      else do;
         msg = "Jms) Missing 2nd value";
         goto key_error;
      end;
      if ^get_single (v2)
      then goto key_error;

   end get_pair;
         

get_single: proc (v) returns (bit (1));

dcl v		fixed bin (21);
dcl ch		char (1);
      ch = "";
      if (spec_c (spec_i) = "$")
      then do;
         v = 0;
         spec_i = spec_i + 1;
         if (spec_i > spec_l)
         then return("1"b);
         if (spec_c (spec_i) ^= "-")
         then return("1"b);
         spec_i = spec_i + 1;
         ch = "-";
      end;
      if ^num (v)
      then do;
         msg = "Jmn) Missing number";
         return (""b);
      end;
      if (ch = "-")
      then v = -v;
      return ("1"b);

   end get_single;
   end get_keys; %skip (3);
num: proc (v) returns (bit (1));
				/* returns 1 if integer found	       */
dcl v		fixed bin (21) parm;

      i = verify (substr (spec, spec_i), "0123456789");
      if (i = 0)
      then i = spec_l - spec_i + 1;
      else i = i - 1;
      v = fixed (substr (spec, spec_i, i));
      spec_i = spec_i + i;
      if v < 1 then do;
         rc = 1;
         return ("0"b);
      end;
      return ("1"b);

dcl i		fixed bin;

   end num; %page;
SORT: proc;

/**** SL, of length numrec, is the ordering of the data to be sorted.	       */
/**** Using the comparison procedures Jcmp or jcmp, return SL ordered	       */
/**** according to the comparisons.				       */

/**** cmp has two input parameters.  These are two entries from the lst      */
/**** that point to the next two data elements to be sorted.  If the	       */
/**** data element pointed to by the first parameter is "next" then cmp      */
/**** returns a zero, 0, else returns a one, 1.			       */

/**** calc lengths of lists and their start pointers in a linear set.	       */

      t = 0;
      l = num_rec;
      do n = 1 by 1 while (l > 1);
         s (n) = t;			/* start of the next list.	       */
         if mod (l, 2) = 1
         then l = l + 1;		/* make the length even.	       */
         t = t + l;			/* accumulate the lengths.	       */
         SL (t) = 0;
         l = divide (l, 2, 24, 0);	/* next list 1/2 length the present  */
      end;
      n = n - 1;

/**** pointers to input list.					       */
      do i = 1 to num_rec;
         SL (i) = i;
      end;

/* fill in all lists. */
      do i = 2 to n;
         if db_sort then call ioa_$ioa_switch_nnl (db_output,
	  "list ^d^/", i);
         lft = s (i - 1);
         rit = s (i);
         do j = 1 by 2 to (rit - lft);
	  x = lft + j;
	  v1 = SL (x);
	  v2 = SL (x + 1);
	  call COMPARE;
	  rit = rit + 1;
	  SL (rit) = v1;
	  if db_sort then call ioa_$ioa_switch_nnl (db_output,
	     "^-SL(^d)=^d^/", rit, v1);
         end;
      end;


/* calculate the list of pointers in o */
      count = 1;
      y = s (n) + 1;
      do i = 1 to num_rec;
         v1 = SL (y);
         v2 = SL (y + 1);
         if (v1 = 0) & (v2 = 0)
         then i = num_rec;		/* End "i" loop.		       */
         else do;
	  call COMPARE;		/* next output value.	       */
	  if (v1 < 0)
	  then count = count + 1;
	  if (v1 < 0) & no_dupl
	  then do;
	     if db_sort then call ioa_$ioa_switch_nnl (db_output,
	        "^-drop(^d)^d^/", v1, count);
	  end;
	  else do;
dcl (tloc, tlen)	fixed bin (21);	/* field location/length	       */
dcl (ilen, olen)	fixed bin (21);	/* input/output lengths	       */
	     l = abs (SL (abs (v1)));
	     f = R (l);
	     ilen, olen = R (l + 1) - f;
	     if db_sort then call ioa_$ioa_switch_nnl (db_output,
	        "^-put(^d)^d^/", v1, count);
	     if no_dupl & eq_field
	     then do;		/* put count into record	       */
	        if (eq_loc < 1)	/* figure begin key location	       */
	        then tloc = ilen;	/* counting from the end	       */
	        else tloc = 1;	/* counting from the beginnning      */
	        tloc = tloc + eq_loc - 1;   /* calc where field starts     */
	        if (tloc < 1)
	        then do;		/* falls off the front, increment    */
/****		 olen = ilen - tloc + 1;  /* ..length so will be @1      */
		 olen = ilen - tloc;      /* ..length so will be @1      */
		 tloc = 1;
	        end;
	        if eq_n_n
	        then do;		/* =n:n form		       */
		 if (eq_leng+1 > olen)/* is location beyond end?	       */
		 then olen = eq_leng + 1; /* push out 'till can fit      */
		 tlen = eq_leng - tloc + 1;  /* calc field length	       */
	        end;
	        else do;		/* =n,l form		       */
		 tlen = eq_leng;
		 if (tlen + tloc > olen)
		 then olen = tloc + tlen;
	        end;
				/* done like this so will be padded  */
				/*  with blanks if necessary.	       */
				/* think about 4 char record with    */
				/*      =3,3  or  =$-8,3	       */
	        substr (O, Oe + 1, olen) = substr (input, f, ilen-1);
	        substr (O, Oe + olen, 1) = rec_delim;
dcl accum		pic "(12)9";
	        accum = count;
	        substr (O, Oe + tloc, tlen)
		 = substr (accum, 13 - tlen, tlen);
	     end;
	     else substr (O, Oe + 1, olen) = substr (input, f, ilen);

	     count = 1;
	     Oe = Oe + olen;
	  end;
	  v1 = abs (v1);
	  SL (v1) = 0;		/* delete	the last winner.	       */
	  do j = 2 to n;		/* get the next	winner.	       */
	     v1 = abs (v1);
	     lft = s (j - 1);
	     if mod (v1, 2) = 1
	     then v2 = v1 + 1;
	     else v2 = v1 - 1;
	     x = divide (v1 + 1, 2, 24, 0);
	     v1 = SL (v1 + lft);
	     v2 = SL (v2 + lft);
	     call COMPARE;
	     SL (x + s (j)) = v1;
	     v1 = x;
	  end;
         end;
      end;

/*  declarations. */
dcl t		fixed bin (21);
dcl n		fixed bin (21);
dcl v1		fixed bin (21);
dcl v2		fixed bin (21);
dcl count		fixed bin (21);
dcl l		fixed bin (21);
dcl x		fixed bin (21);
dcl j		fixed bin (21);
dcl y		fixed bin (21);
dcl lft		fixed bin (21);
dcl rit		fixed bin (21);
dcl i		fixed bin (21);
/****dcl accum		char (12);			       */
dcl s		(36) fixed bin (21);/* Indices to "bottoms" of lists. */


/* . . . COMPARE . . . */

COMPARE: proc;

      if (v1 = 0)
      then v1 = v2;
      else do;
         if (v2 ^= 0)
         then do;
	  if (Jcmp (SL (abs (v1)), SL (abs (v2))) = 1)
/*	  cv = Jcmp (SL (abs (v1)), SL (abs (v2)));
	  if (cv = 1)					       */
	  then v1 = v2;
	  if equal & (v1 > 0)
	  then do;
	     SL (v1) = -v1;
	     v1 = -v1;
	  end;
         end;
      end;

   end COMPARE;
   end SORT; %page;
Jcmp: proc (p1, p2) returns (fixed bin (21));
/**** This procedure compares two records on the "nk" key fields.  Three     */
/**** cases to consider:					       */

/**** I	Key fields (partially or all) within both records.	       */
/****	Compare key fields in both records, but not beyond extent of       */
/****	either record, and return record (index to it) according to the    */
/****	keys order field. "1"b => ascending "0"b=> descending.	       */

/**** II	Key field	within one record but outside	of the other. Ascending    */
/****	order returns the record the key field is outside of.	       */
/****	Descending the record the key field is inside of.		       */

/**** III	Key field outside of both records. Continue comparing on	       */
/****	remaining key fields. Note that key fields are first "mapped"      */
/****	through the array "M". If the value produced is octal 777 then     */
/****	the key field character is skipped, otherwise its mapped value     */
/****	is compared.					       */

      equal = "0"b;
      Fn (1) = R (abs (p1));		/* 1st char of 1st record.	       */
      Fn (2) = R (abs (p2));		/* 1st char of 2nd record.	       */
      Ln (1) = R (abs (p1) + 1);	/* 1st char after 1st record.	       */
      Ln (2) = R (abs (p2) + 1);	/* 1st char after 2nd record.	       */
      if db_sort
      then call ioa_$ioa_switch_nnl (db_output,
         "^[J^;j^]: ^d(^d:^d):^d(^d:^d)^/", spec_sw,
	    p1, Fn (1), Ln (1), p2, Fn (2), Ln (2));
      do i = 1 to nk;		/* Compare 1st & 2nd records by each */
				/*  key.			       */
         f = keys.loc1 (i);		/* begin key info		       */
         l = keys.loc2 (i);		/* end key info		       */
         nn = keys.n_n (i);		/* key form info 1->n:n 0->n,l       */
         if db_sort
         then call ioa_$ioa_switch_nnl (db_output,
	  "^2i) f=^i l=^i ^[A^;D^]^[n:n^;n,l^]", i, f, l,
	  keys.order (i), nn);
         do ii = 1 to 2;
	  if (f < 1)		/* figure begin key location	       */
	  then fn (ii) = Ln (ii);
	  else fn (ii) = Fn (ii);
	  fn (ii) = fn (ii) + f - 1;
	  if (Fn (ii) > fn (ii)) | (fn (ii) >= Ln (ii))
	  then do;		/* Key does not begin in record,     */
	     fn (ii), ln (ii) = 0;	/* ..thus key is null.	       */
	  end;
	  else do;
	     if nn		/* is it n:n form		       */
	     then do;
	        if (l < 1)
	        then ln (ii) = Ln (ii);
	        else ln (ii) = Fn (ii);
	     end;
	     else ln (ii) = fn (ii);	/* it is n,l form		       */
	     ln (ii) = min (Ln (ii) - 1, ln (ii) + l - 1);
	     ln (ii) = max (Fn (ii) - 1, ln (ii));
	  end;
	  if db_sort
	  then call ioa_$ioa_switch_nnl (db_output,
	     "  (^d,^d)^[^/^]",
	     fn (ii), ln (ii), (ii=2));
         end;
         if (fn (1) > 0)		/* key within 1st record?	       */
         then do;
	  if (fn (2) > 0)		/* key within 2nd record?	       */
	  then do;		/* Keys:  in 1st,  in 2nd	       */
	     if spec_sw
	     then do;
	        if keys.order (i)
	        then order_num = 1;	/*  -- Ascending		       */
	        else order_num = 2;	/*  -- Descending		       */
	        r = CC (fn (order_num), ln (order_num)+1,
		 fn (3 - order_num), ln (3 - order_num)+1);
	        if (r < 2)
	        then return (r);
	     end;
	     else do;
	        ln (1) = ln (1) - fn (1) + 1;
	        ln (2) = ln (2) - fn (2) + 1;
	        order_num = fixed (keys.order (i)); /* "1"b-asc  "0"b-desc */
	        if "0"b
	        then call ioa_$ioa_switch (db_output,
		 "^i""^a"":^i""^a""",
		 ln (1), substr (input, fn (1),ln (1)),
		 ln (2), substr (input, fn (2),ln (2)));
	        if substr (input, fn (1), ln (1))
		 > substr (input, fn (2), ln (2))
	        then return (order_num); /* 1-asc 0-desc		       */
	        if substr (input, fn (1), ln (1))
		 < substr (input, fn (2), ln (2))
	        then return (1 - order_num); /* 0-asc 1-desc	       */
	     end;
	  end;
	  else do;		/* Keys:  in 1st, out 2nd	       */
	     if keys.order (i)
	     then return (1);	/* Ascending => 2nd record first.    */
	     else return (0);	/* Descending=> 1st record first.    */
	  end;
         end;
         else do;
	  if fn (2) > 0		/* key within 2nd record?	       */
	  then do;		/* Keys: out 1st,  in 2nd	       */
	     if keys.order (i)
	     then return (0);	/* Ascending => 1st record first.    */
	     else return (1);	/* Descending=> 2nd record first.    */
	  end;
	  else do;		/* Keys: out 1st, out 2nd	       */
	  end;			/* Continue with next key	       */
         end;
      end;

      equal = "1"b;			/* ALL keys equal. Return records in */
				/*  input order.		       */
      if (abs (p1) < abs (p2))
      then return (0);
      return (1);

dcl (p1, p2)	parm fixed bin (21);
dcl (Fn, Ln, fn, ln) (2) fixed bin (21);
dcl (l, f, i, ii, r) fixed bin (21);
dcl nn		bit (1);
dcl order_num	fixed bin;

/* Procedure internal to Jcmp. */

CC: proc (LHE1, RHE1, LHE2, RHE2) returns (fixed bin (21));

dcl (LHE1,			/* where 1st line begins	       */
    RHE1,				/* where 1st line ends	       */
    LHE2,				/* where 2nd line begins	       */
    RHE2				/* where 2nd line ends	       */
    )		fixed bin (21) parm;

/**** Compare "mapped" chars of the key fields left to right. If the mapped  */
/****  char equals octal 777 then skip it.			       */

/* Calculate right key field bounds.				       */

      do while ((LHE1 < RHE1) & (LHE2 < RHE2));
         c1 = M (rank (input_c (LHE1)));
         if c1 = octal777
         then LHE1 = LHE1 + 1;
         else do;
	  c2 = M (rank (input_c (LHE2)));
	  if c2 = octal777
	  then LHE2 = LHE2 + 1;
	  else do;
	     if c1 < c2 then return (0);
	     if c1 > c2 then return (1);
	     LHE1 = LHE1 + 1;
	     LHE2 = LHE2 + 1;
	  end;
         end;
      end;
      do while (LHE1 < RHE1);
         c1 = M (rank (input_c (LHE1)));
         if c1 = octal777
         then LHE1 = LHE1 + 1;
         else return (1);		/* record 1 is longer :: higher      */
      end;
      do while (LHE2 < RHE2);
         c2 = M (rank (input_c (LHE2)));
         if c2 = octal777
         then LHE2 = LHE2 + 1;
         else return (0);		/* record 2 is longer :: higher      */
      end;
      return (2);			/* All chars in key fields equal.    */

dcl (c1, c2)	char (1) aligned;
   end CC;
   end Jcmp;

/*   /* . . . TED_JCOMP_ . .  */
/**** <<<<----- dcl_tedsort_.incl.pl1 tedsort_$compare		       */
compare:				/* compare strings w/ spec collate   */
   entry (p1, tp1, rcomp);
dcl (
    p1		ptr,		/* points to seg containin/g strings */
    tp1		ptr,		/* points to R array	       */
    rcomp		bit (3)		/* the 3 bits represent <=>	       */
    )		parm;		/* ----->>>>		       */


/*	The caller has initialized the R array
   R(1) R(2) defining the first field
   R(3) R(4) defining the second one
   Both fields are in the segment pointed to by p1	*/

dcl Jcomp		fixed bin (21);


      if Minit
      then do;
         reset = MASTER;
         call set;
      end;
      Rp = tp1;
dcl Ip		ptr;
      Ip = p1;
      nk = 1;
      keys.order (1) = "1"b;
      keys.loc1 (1) = 1;
      keys.loc2 (1) = 0;
      Jcomp = Jcmp (1, 3);
      if equal
      then rcomp = "010"b;
      else if Jcomp = 0
      then rcomp = "100"b;
      else rcomp = "001"b;
      return; %page;
/*		  Declarations for Global Variables		       */

dcl no_dupl	bit (1);
dcl equal		bit (1);
dcl eq_field	bit (1);
dcl eq_loc	fixed bin (21);
dcl eq_leng	fixed bin (21);
dcl eq_n_n	bit (1);
dcl reset		char (256) var;
dcl spec_sw	bit (1);

dcl octal777	char (1) static internal init ("�"); /* Octal 777. */
dcl rec_delim	char (1);
/****    I		char (Il) aligned based (Ip),		       */
dcl O		char (262000) aligned based (Op);

dcl 1 keys	(1000) aligned,
      2 order	bit (1),		/* 1- descending		       */
      2 n_n	bit (1),		/* 1- "n:n" form    0- "n,l" form    */
      2 loc1	fixed bin (21),	/* >=0 => M form    <0  => $-M form  */
				/*    loc1 is keybegin-1	       */
      2 loc2	fixed bin (21);	/* n_n=0 => loc2 = actual length     */
				/* n_n=1 => loc2 = keyend-1	       */
				/*          with M/$-M as above      */
dcl input_l	fixed bin (21);
dcl input_p	ptr;
dcl input_c	(input_l) char (1) based (input_p);
dcl input		char (input_l) based (input_p);
dcl input_i	fixed bin (21);
dcl nk		fixed bin (21);
dcl ff1		fixed bin (21);
dcl ff2		fixed bin (21);
dcl ll1		fixed bin (21);
dcl ll2		fixed bin (21);
dcl bb1		fixed bin (21);
dcl bb2		fixed bin (21);
dcl cv_oct_check_	entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl j		fixed bin (21);
dcl ii		fixed bin;
dcl i		fixed bin (21);
dcl num_rec	fixed bin (21);
dcl NS		fixed bin (21);
dcl f		fixed bin (21);
dcl l		fixed bin (21);

dcl Op		ptr;
dcl Rp		ptr;
dcl Lp		ptr;
dcl SLp		ptr;
dcl Oe		fixed bin (21);

dcl M1		char (1) aligned;

dcl 1 MB		based (addr (M1)),
      2 M11	bit (3),
      2 M12	bit (3),
      2 M13	bit (3);

dcl L		char (256) var;
dcl ioa_		entry () options (variable);
dcl ioa_$ioa_switch entry () options (variable);
dcl ioa_$ioa_switch_nnl entry () options (variable);
dcl cu_$arg_count	entry (fixed bin, fixed bin (35));

dcl R		(65536) fixed bin (21) based (Rp);
dcl SL		(0:65535) fixed bin (21) based (SLp);
dcl spec_l	fixed bin (21);
dcl spec_p	ptr;
dcl spec_c	(spec_l) char (1) based (spec_p);
dcl spec		char (spec_l) based (spec_p);
dcl spec_i	fixed bin (21);

dcl Minit		bit (1) int static init ("1"b);
dcl M		(0:511) char (1) static internal;
dcl MASTER	char (42) int static
		init ("'000->'177'000->'177'200->'777'777a->zA->Z");

dcl (
    abs, addr, addrel, bin, byte, divide, fixed, index, length, max, min,
    mod, rank, substr, unspec, verify
    )		builtin;
%include tedbase;
%include tedcommon_;
%include tedbcb;

   end tedsort_;
   



		    tedsrch_.pl1                    12/18/84  0939.0rew 12/18/84  0907.8      337221


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

/*							       */
/*    _|_              |                       |			       */
/*     |      _      _ |   ___     _      _    | _		       */
/*     |     / \    / \|  /  _   |/ \    / \   |/ \		       */
/*     |    (__/   (   |  \_/ \  |      (      |   |		       */
/*     \_    \_/    \_/|   ___/  |       \_/   |   |		       */
/*                                                    -----		       */
/*							       */

/* ted utility procedure to search addressed portion of buffer with	       */
/*  specified regular expression				       */

tedsrch_:				/* dummy entry		       */
   proc ();
   return;

/* UPDATE HISTORY (finally)					       */
/* EL#   date	TR	comments				       */
/* --- 84-??-??          implement an output switch for debugging	       */
/* 146 84-10-10 phx17390 /^..*a/ loops when "a" is first char of buffer      */
/*              phx17429 global-if "/^..*X/ P" loops on lines like "X"       */
/*              phx17531 /^...*>/ also loops when line begins with ">"       */
/* 150 84-10-12 phx17701 interprets "/ * /" incorrectly.		       */

/**** input string, which is expression				       */
dcl in_p		ptr;		/* -> expression		       */
dcl in_l		fixed bin (21);	/*   length thereof		       */
dcl in_s		char (in_l) based (in_p); /* expression as a string      */
dcl in_c		(in_l) char (1) based (in_p);	  /* expression as chars   */

/**** data refering to the string being searched			       */
dcl file_str	char (part.right_loc) based (b.cur.sp);
dcl file_char	(part.right_loc) char (1) based (b.cur.sp);
/**** A buffer consists of an upper part and a lower part, either of which   */
/****  may be empty. The next 4 variables describe the part being worked in. */
dcl 1 part,
      2 min_left	fixed bin (21),	/* lowest location to consider       */
      2 left_loc	fixed bin (21),	/* location (in buffer) of left end  */
      2 cur_loc	fixed bin (21),	/* current place		       */
      2 right_loc	fixed bin (21),	/* right end		       */
      2 left_size	fixed bin (21),	/* how much of the left part is left */
      2 this	fixed bin;	/* which part of file are we in      */

dcl (ami_sw, ame_sw)bit (1);
dcl first_char_matched fixed bin (21);
dcl last_char_matched fixed bin (21);
dcl (lb, ub)	fixed bin (21);	 /* lower/upper bounds	       */
dcl (i, ii, j, l, sl, type) fixed bin (21);
dcl rep_no	fixed bin;
dcl mct		fixed bin;
dcl concealsw	bit (1);
dcl ch		char (1);
dcl ch1		char (1);
dcl NL		char (1) int static options (constant) init ("
");

dcl re_p		ptr;
dcl 1 re		based (re_p),	/* copy of compiled regexp	       */
      2 maxl	fixed bin,	/* max length of compiled expr       */
      2 len	fixed bin,	/* length of this compiled expr      */
      2 sws,
        3 flag	bit (18) unal,
        3 NL_sw	bit (1) unal,	/* was literal NL given in expr      */
        3 strmode	bit (1) unal,	/* was compiled in string mode       */
        3 fill	bit (16) unal,
      2 parts	char (re.len);	/* actual compiled expression	       */
dcl FLAG		bit (18) unal int static options (constant)
		init ("252525"b3);

dcl (rep_p, lrep_p) ptr;		/* -> part/last part	       */
   
dcl 1 rep		based (rep_p),	/* regexp part- string	       */
      2 typ	fixed bin (8)unal,	/* what kind of entry	       */
      2 lbd	fixed bin (8)unal,	/* min occurances to find	       */
      2 ubd	fixed bin (8)unal,	/* max occurances (0 -> infinity)    */
      2 len	fixed bin (8)unal,	/* length of string which follows    */
      2 str	char (rep.len),	/*  literal data if needed	       */
      2 next	char (1);		/* where next part is based	       */


dcl ioa_		entry options (variable);
dcl (ioa_$ioa_switch,
     ioa_$ioa_switch_nnl) entry options (variable);
dcl (
     addr, fixed, index, length, min, null, string, substr, unspec, verify
     )		builtin; %page;
/**** <<<<----- dcl_tedsrch_.incl.pl1 tedsrch_$init_exp		       */
init_exp:				/* initialize an expression area     */
    entry (acreg_p, ain_l);
/*dcl (							       */
/*  acreg_p	ptr,		/* -> compiled expression area  [IN] */
/*  ain_l		fixed bin (21)	/*   length of area in words	       */
/*  )		parm;		/* ----->>>>		       */

      re_p = acreg_p;
      re.maxl = (ain_l - 3) * 4;
      re.len = 0;
      string (re.sws) = ""b;
      return;%skip(4);
/**** <<<<----- dcl_tedsrch_.incl.pl1 tedsrch_$compile		       */
compile:				/* compile a regular expression      */
   entry (ain_p, ain_l, acreg_p, astrmode, alitmode, msg, acode);
dcl (
    ain_p		ptr,		/* -> regular expression to search   */
    ain_l		fixed bin (21),	/*   length thereof		       */
    acreg_p	ptr,		/* -> compiled expression area  [IN] */
    astrmode	bit (1)aligned,	/* 0- line mode     1- string mode   */
    alitmode	bit (1)aligned,	/* 0- reg expr      1- literal expr  */
    msg		char (168) var,	/* error message		 [OUT] */
    acode		fixed bin (35)	/* error status code	 [OUT] */
    )		parm;		/* ----->>>>		       */

      re_p = acreg_p;
      acode = 0;
      in_p = ain_p;
      in_l = ain_l;

      re.len = 0;			/* no regular expression	       */
      re.flag = FLAG;
      rep_p = addr (re.parts);
      lrep_p = null();
      rep.len = 0;
      call start_sub_expression (STR_1);
%skip(2);
      if alitmode			/* the whole expr is used as-is      */
      then do;
         i = 1;			/* since the hole might be in the    */
				/*  middle of the area to be	       */
				/*  searched, all searchs will be    */
				/*  broken following NLs.	       */
get_more:
         ii = index (substr (in_s, i), NL);
         if (ii = 0)
         then ii = in_l - i + 1;
         rep.len = ii;
         rep.str = substr (in_s, i, rep.len);
         if (ii = 0)
         then goto all_done;
         call start_sub_expression (STR);
         goto get_more;
      end;

      concealsw = ""b;		/* init concealment switch	       */
      re.strmode = astrmode;		/* save current line/string mode     */
      re.NL_sw = "1"b;		/* assume literal NL	       */
      do i = 1 to in_l;		/* pre-process and copy regexp       */
         ch = in_c (i);		/* pick up a char from expression    */
         if concealsw
         then do;
	  concealsw = ""b;		/* reset concealment switch	       */
	  goto tstar;		/* process char as normal char       */
         end;%skip(2);
         if (ch = "^") & (i = 1)	/* if "^" 1st char in the regexp     */
         then do;
	  ch = NL;		/* replace with NL if so	       */
	  rep.typ = I_STR;		/* TYPE:	/^string   /	       */
	  goto move_ch;		/* place new-line in sub-expression  */
         end;			/*  in place of "^"		       */
         if (ch = "$") & (i = in_l)	/* check for "$", as last char */
         then do;
	  ch = NL;		/* replace with NL if so	       */
	  re.NL_sw = ""b;
         end;%skip(2);
         if (ch = "\")
         then do;
	  ch1 = in_c (i + 1);
	  unspec (ch1) = unspec (ch1) | "000100000"b;   /* make lowercase  */
	  if (ch1 = "c")		/* "\c"			       */
	  then do;
	     i = i + 1;
	     concealsw = "1"b;
	     goto skip;
	  end;
	  if (ch1 = "x")
	  then if (in_c (i + 2) = "[")
	  then do;		/* expression extention	       */
	     i = i + 3;
	     call extention;
	     goto skip;
	  end;
         end;%skip(2);
         if (ch = ".")		/* special regexp ctl char	       */
         then do;
	  if (i < in_l)
	  then if (in_c (i + 1) = "*")
	  then do;		/*  ".*"			       */
	     i = i + 1;		/* yes, skip over it	       */
	     call start_sub_expression (DOTSTAR);
	     lb, ub = 0;
	     goto skip;		/* skip to end of loop	       */
	  end;
	  if (rep.typ = DOTSTAR) & (rep.len = 0)  /* ".*."	       */
	  then next_type = DOTSTAR;
	  else next_type = STR;
dcl next_type	fixed bin;
	  call start_sub_expression (DOT);
	  rep.len = 1;
	  rep.str = ".";
	  lb = verify (substr (in_s, i), ".")-1;
	  if (lb < 0)
	  then lb = in_l - i + 1;
	  ub = lb;
	  i = i + ub - 1;
	  call start_sub_expression (next_type);
	  goto skip;		/* skip to end of loop	       */
         end;
         if (ch = "*")
         then do;
	  if (lrep_p = null ())
	  then do;
no_star_char:
	     msg = "R??) No char for * to apply to.";
	     goto err_exit;
	  end;
	  if (lrep_p -> rep.typ = STAR)
	  | (lrep_p -> rep.typ = NOT_CHAR)
	  | (lrep_p -> rep.typ = DOTSTAR)
	  then goto no_star_char;
	  if (lrep_p -> rep.typ = DOT)
	  then do;
	     rep_p = lrep_p;
	     rep.typ = DOTSTAR;
	     rep.lbd = rep.lbd - 1;
	     rep.ubd = 0;
	     rep.len = 0;
	     goto skip;
	  end;
	  if (lrep_p -> rep.typ = I_STR) & (lrep_p -> rep.len = 1)
	  then goto no_star_char;
	  if (lrep_p -> rep.len = 1)
	  then do;
	     lrep_p -> rep.typ = STAR;
	     goto skip;
	  end;
/**** Whats left at this point is STR_1, I_STR or STR with more than 1 char  */
	  rep_p = lrep_p;
	  ch = substr (rep.str, rep.len, 1);
	  rep.len = rep.len - 1;
	  call start_sub_expression (STAR);
	  rep.len = 1;
	  rep.str = ch;
	  call start_sub_expression (STR);
	  goto skip;
         end;
tstar:
         if (i < in_l)
         then if (in_c (i + 1) = "*")
	    then do;		/* check for char followed by "*"    */
	       i = i + 1;		/*  skip over it		       */
	       call start_sub_expression (STAR);
	       lb, ub = 0;		/* ub=0 --> no-limit	       */
	       rep.len = 1;
	       rep.str = ch;
	       do ii = (i + 1) to in_l /* pick up following ch's	       */
		while (in_c (ii) = ch);
		if (ii < in_l)
		then if (in_c (ii + 1) = "*")
		then goto skp2;
		i = i + 1;	/* skip over ch		       */
		rep.lbd = rep.lbd + 1; /* raise minimum		       */
		lb = lb + 1;				/* #150*/
	       end;
skp2:
	       call start_sub_expression (STR);
	       goto skip;		/* skip to end of loop	       */
	    end;
	    if (rep.typ = DOT)
	    then call start_sub_expression (STR);
move_ch:
	    rep.len = rep.len + 1;	/* normal char not followed by "*",  */
	    substr (rep.str, rep.len, 1) = ch;
	    if (ch = NL)		/* Due to the gap, NLs may require   */
	    then do;		/* ..special handling.	       */
	       if (rep.len = 1) & (rep.typ = I_STR)
	       then;		/* Not if its from "/^"	       */
	       else if re.NL_sw	/* ..or from "$/"		       */
	       then call start_sub_expression (STR);
				/* break the string at this point    */
	    end;
skip:
      end;
      if (rep.len = 0) & (rep.typ = DOTSTAR)	/* TYPE:	/   .* <nil> /   */
      then do;
         rep.typ = DOTSTARnil;
         rep.len = 1;
         rep.str = NL;
         re.NL_sw = ""b;
      end;
all_done:
      call start_sub_expression (MATCH);
      re.len = re.len + 4;
      if db_srch
      then call dump_entry (re.len);
      return;%page;
/**** <<<<----- dcl_tedsrch_.incl.pl1 tedsrch_$search		       */
search:				/* search for expression	       */
   entry (acreg_p, abp, asi, ase, ami, ame, ame2, msg, acode);
dcl (
/****acreg_p	ptr,		/* -> compiled expression	       */
    abp		ptr,		/* -> buffer ctl block for file      */
    asi		fixed bin (21),	/* beginning of string to search     */
    ase		fixed bin (21),	/* end of string to search	       */
    ami		fixed bin (21),	/* beginning of match	       */
    ame		fixed bin (21),	/* end of match		       */
    ame2		fixed bin (21)	/* end of string used for match      */
/****msg		char (168)var,	/* error message return	 [OUT] */
/****acode	fixed bin (35)	/* error status code	 [OUT] */
    )		parm;		/* ----->>>>		       */

dcl BOL		bit (1);		/* tells if ^x... type	       */
      re_p = acreg_p;
      bp = abp;
      if (re.len = 0) | (re.flag ^= FLAG)
      then do;
         msg = "E/u) // undefined.";
         goto err_exit;
      end;%skip(5);
      BOL = ""b;
      part.min_left = asi;		/* Set low-water-mark.	       */
				/* We will never search below this.  */
%skip (2);
/*		  : : : SEARCH FOR EXPRESSION : : :		       */

      if ""b then do;
really_retry:
         if db_srch & lg_srch
         then call ioa_$ioa_switch (db_output, "<RE-TRY>");
      end;
      part.this = 0;
      call check_bounds;		/* setup, check for empty buffer     */
      if (part.cur_loc > part.right_loc)
      then call check_bounds;		/* search fails on empty buffer area */
      if ""b then do;
retry:
         if db_srch & lg_srch
         then call ioa_$ioa_switch (db_output, "<re-try>");
/**** from location 1 */
         if (first_char_matched = 0)	/* restart regexp search	       */
         then part.cur_loc = part.cur_loc + part.left_size;
/****    then part.cur_loc = part.cur_loc + 1;   changed 82-11-29	       */
         else part.cur_loc = first_char_matched + 1;
         if (part.cur_loc > part.right_loc)
         then call check_bounds;	/* starting at next line in buffer   */
				/*  area			       */

      end;
      rep_p = addr (re.parts);
      rep_no = 1;
      first_char_matched, last_char_matched = 0; /*  nothing found yet       */
      ami_sw, ame_sw = ""b;
      if db_srch & lg_srch
      then call ioa_$ioa_switch (db_output, "^i|^i<^i<^i",
         part.min_left, part.left_loc, part.cur_loc, part.right_loc);
search:
      type = rep.typ;		/* get sub-expression type code      */
      lb = rep.lbd;
      ub = rep.ubd;
      sl = rep.len;			/* get length of literal char string */

      if db_srch
      then do;
         if (rep_no = 1)
         then call ioa_$ioa_switch (db_output, "    #  typ,min,max,len");
         call ioa_$ioa_switch_nnl (db_output,
	  "l^i,cur^i,r^i^19.1t ^i:^i^40.1t",
	  part.left_loc, part.cur_loc, part.right_loc,
	  first_char_matched, last_char_matched);
         call dump_entry (rep_no);
      end;
      if (type > max_type)
      then do;
invalid_type:
         call ioa_ ("tedsrch_: Invalid type ^i", type);
         goto err_exit;
      end;
      mct = 0;
      part.left_size = part.right_loc - part.cur_loc + 1;
dcl max_type	fixed bin defined Ematch;
      goto srch (type); %skip (3);
dcl STR_1		fixed bin int static init (0) options (constant);
srch (00): /**** "/string-----/"	match 1st normal string	       */
again_1:
      if (part.left_size >= rep.len)	/* enough left for string to fit?    */
      then j = index (substr (file_str, part.cur_loc), rep.str);
      else j = 0;
      if (j = 0)			/* if no match, maybe search failed  */
      then do;
         call check_bounds;		/* if we come back,		       */
         goto again_1;		/*  there is still more to search    */
      end;
      type = STR;			/* if more needed, must be HERE      */
      goto srch_end_4; %skip (3);
dcl I_STR		fixed bin int static init (1) options (constant);
srch (01): /**** "/^string----/"	match 1st initial string	       */
      BOL = "1"b;
again_2:
      if (part.cur_loc = part.left_loc)   /* check for start of line     */
      then do;
dcl kr char (1);
         if (part.left_loc = b.b_.l.le) /* if at beginning of lower part     */
	  | (b.b_.l.re < b.b_.l.le)	/* or if no lower part at all	       */
         then kr = NL;		/* ..make believe a NL is before it  */
         else kr = b_c (b.b_.l.re);	/* otherwise take last char of lower */
      end;
      else if (part.cur_loc > part.left_loc)
      then kr = file_char (part.cur_loc-1);   /* take char just in front     */
      else do;
         signal condition (Error);dcl Error condition;
      end;
      if (kr ^= NL)
      then do;			/* skip remainder of partial line    */
find_NL_1:
         l = index (substr (file_str, part.cur_loc), NL);
         if (l = 0)			/* COULD A LINE END UP SPLIT?	       */
         then do;			/* ...not supposed to (I think)      */
	  if (part.this = 1)
	  then do;
	     call check_bounds;
	     goto find_NL_1;
	  end;
	  call fail;		/* no next line to search	       */
         end;
         part.cur_loc = part.cur_loc + l; /* point to next line     */
         if (part.cur_loc > part.right_loc)
         then call check_bounds;	/* check for last line	       */
      end;

/**** try initial string on 1st line				       */
      if (part.left_size < sl-1)	/* gotta be enough chars left	       */
      then do;			/* if not, regexp search failed..    */
         call check_bounds;		/* ..unless there is still more data */
         goto again_2;
      end;
      if (substr (file_str, part.cur_loc, sl-1)	  /* don't use the leading */
         = substr (rep.str, 2, sl-1))   /* NL for this one		       */
      then do;
         j = 1;
      end;
      else do;			/* string compare failed on 1st line */
         ii = 0;			/* search remainder of buffer area   */
         j = index (substr (file_str, part.cur_loc), rep.str);
         if (j = 0)			/* no match, regexp search failed..  */
         then do;
	  call check_bounds;	/* ..unless there is still more data */
	  goto again_2;
         end;
         j = j + 1;
      end;
      sl = sl - 1;			/* don't include the initial NL      */
      goto srch_end_4; %skip (3);
dcl DOTSTAR	fixed bin int static init (2) options (constant);
dcl DOTSTARnil	fixed bin int static init (8) options (constant);
srch (02): /****  "/---.*string/"	match next string		       */
srch (08): /****  "|.*|"		match "rest"		       */
				/* find end of line containing       */
				/*  string found so far	       */
/**** STRING MODE .*XXX WILL NOT HACK SPANNING THE GAP		       */
      if ^re.strmode
      then do;
         j = index (substr (file_str, part.cur_loc), NL); /* look for NL     */
         if (j > 0)			/* if none found		       */
         then part.left_size = j;       /* ..take all that's left	       */
      end;
      if (rep.typ = DOTSTARnil)	/* this ended in .*		       */
      then sl = part.left_size;	/* so take all there is left	       */
      else sl
         = index (substr (file_str, part.cur_loc, part.left_size), rep.str);
				/* search rest of ? for string       */
      if (sl <= lb)			/* not found		   #146*/
/*    if (sl = 0)			/* not found		   #146*/
      then do;
/**** location 1 */
         goto retry;		/* .. restart regexp search	       */
      end;
/*    if (sl <= lb)			/* not enough "dots" available?      */
/*    then goto re/try;					       */
      mct = ub;			/* found what we need	       */
      if (rep.typ = DOTSTAR)
      then sl = sl + rep.len - 1;	/* the total length is the length    */
				/*  skipped over plus the length of  */
				/*  the string searched for.	       */
      goto srch_end_3; %skip (3);
dcl STR		fixed bin int static init (3) options (constant);
srch (03): /****  "/---string---/"	match next literal string	       */
				/* attempt to match string in place  */
      if (part.left_size < sl)	/* enough chars left?	       */
      then goto keep_trying;
      if (substr (file_str, part.cur_loc, sl) ^= rep.str)
      then goto keep_trying;
      goto srch_end_2; %skip (3);
dcl STAR		fixed bin int static init (4) options (constant);
srch (04): /****  "/----x*----/"	match any occurences of a char       */
      ch = rep.str;			/* get the "x" from "x*"	       */
      if (first_char_matched > 0)	/* if match already started,	       */
      then do;			/* ..no special action needed.       */
x_star:
         do sl = part.cur_loc to part.right_loc
	  while (file_char (sl) = ch);
         end;
         sl = sl - min (part.right_loc, part.cur_loc);
         if (sl < lb)		/* is minimum amount present?	       */
         then goto retry;					/* #150*/
         mct = min (ub, sl);		/* take up to max		   #150*/
         goto srch_end_3;
      end;
/**** since haven't figured out how to optimize any of the initial cases,    */
/****  just keep doing what has always been done.			       */
      goto x_star;
star_x:				/* haven't figured out how to do     */
				/*  / *str/ yet		       */
				/*  /\[3:7" "]str/ either	       */
				/*  /   *str/ is mostly here	       */

/*				/* initial matching		      * /
      if ^re.strmode
      then do;
         j = index (substr (file_str, part.cur_loc), NL); /* look for NL    * /
         if (j > 0)			/* if none found		      * /
         then part.left_size = j;       /* ..take all that's left	      * /
      end;
      if (lb > 0)			/* do we need at least one?	      * /
      then do;			/* see if one is out there	      * /
         sl = index (substr (file_str, part.cur_loc, part.left_size), ch);
         if (sl = 0)		/* not found, no use looking in this* /
         then do;			/* ..area any more		      * /
	  part.cur_loc = part.cur_loc + part.left_size;
	  if (part.cur_loc > part.right_loc)
	  then call check_bounds;	/* starting at next line in buffer  * /
				/*  area			      * /
	  goto re#try;		/* .. restart regexp search	      * /
         end;
         part.cur_loc = part.cur_loc + sl - 1;
         goto x_star;
      end;
				/* min is zero		      * /
      trp = rep_p;			/* lets go look at what's next      * /
      rep_p = addr (rep.next);
      if (rep.typ = STR)
      then do;
         sl = index (substr (file_str, part.cur_loc, part.left_size), rep.str);
         if (sl = 0)		/* not found, no use looking in this* /
         then do;			/* ..area any more		      * /
	  part.cur_loc = part.cur_loc + part.left_size;
try_again:
	  if (part.cur_loc > part.right_loc)
	  then call check_bounds;	/* starting at next line in buffer  * /
				/*  area			      * /
	  goto re#try;		/* .. restart regexp search	      * /
         end;
         sl = sl - 1;
         if (sl < lb)		/* did we even pass over enough     * /
         then do;			/* ..characters?		      * /
	  part.cur_loc = part.cur_loc + sl; /* ..No		      * /
	  goto try_again;
         end;
         
         part.cur_loc = part.cur_loc + sl - 1;
         goto x_star;
      end;
      if (part.left_size < sl)	/* enough chars left?	      * /
      then goto keep_trying;
      goto srch_end_2;*/%skip (3);
dcl DOT		fixed bin int static init (5) options (constant);
srch (05): /****  "/---\x[n.]---/"	match specific number of any char    */
/****	       "/---.---/" "/---.....---/"			       */
      if (part.left_size < lb)	/* is that enough?		       */
      then do;
         call fail;			/* HANDLE split & stringmode */
      end;
      if (ub = 0)
      then ub = part.left_size;
      sl = min (part.left_size, ub);
      if ^re.strmode		/* in linemode "." may not match     */
      then do;			/* ..a NL			       */
         j = index (substr (file_str, part.cur_loc, sl), NL) -1;
         if (j >= 0)
         then sl = j;
         if (sl < lb)
         then goto really_retry;
      end;
      mct = ub;
      goto srch_end_3; %skip (3);
dcl NOT_CHAR	fixed bin int static init (6) options (constant);
srch (06): /****  "/---\x[^"c"]---/"	match absence of a char	       */
      if (substr (file_str, part.cur_loc, 1) = rep.str)
      then goto keep_trying;
      goto srch_end_2; %skip (3);
dcl XX		fixed bin int static init (7) options (constant);
srch (07): /****  "/^\x[^"c"]---/"	match absence of a char initially    */
      if XX=XX then
      goto invalid_type;%skip (3);
dcl Bmatch	fixed bin int static init (9) options (constant);
srch (09): /****  "/---\x[<]---/"	begin the match here	       */
      ami = part.cur_loc;
      ami_sw = "1"b;
      goto srch_end_0;%skip (3);
dcl Ematch	fixed bin int static init (10) options (constant);
srch (10): /****  "/---\x[>]---/"	end the match here		       */
      ame = last_char_matched;
      ame_sw = "1"b;
      goto srch_end_0;%skip (3);
srch_end_4:
      part.cur_loc = part.cur_loc + j - 1;
srch_end_3:
      if (first_char_matched = 0)
      then do;
         first_char_matched = part.cur_loc;
         part.min_left = first_char_matched + 1;  /* not go below here again */
      end;
srch_end_2:
      last_char_matched = part.cur_loc + sl - 1;
      part.cur_loc = last_char_matched + 1;
srch_end_0: 
      mct = mct + 1;
      if db_srch & lg_srch
      then do;
dcl lgl		fixed bin (21);
         lgl = last_char_matched - first_char_matched + 1;
         call ioa_$ioa_switch (db_output,
	  "^i,^i,^i ^i:^i ""^va""", lb, mct, ub,
	  first_char_matched, last_char_matched, lgl,
	  substr (file_str, first_char_matched, lgl));
      end;
      if (mct < lb)
      then goto srch (type);
      if ""b
      then do;
keep_trying:
         if (mct < lb)
         then goto really_retry;
         ub = mct;			/* Got here because min have been    */
				/*  found, max have not. Must make   */
				/*  it be a success.	       */
      end;
      if (mct < ub)
      then goto srch (type);
      rep_p = addr (rep.next);	/* move to next sub-expression       */
      rep_no = rep_no + 1;
      if (rep.typ ^= MATCH)
      then do;
         if (part.cur_loc > part.right_loc)
         then do;			/* search until specified buffer     */
	  call check_bounds;	/*  area exhausted		       */
         end;
         goto search;
      end;
dcl MATCH		fixed bin int static options (constant) init (-1);
				/* end of expr, match succeeds       */
      ame2 = last_char_matched;
      if ^re.strmode		/* if line mode		       */
         & ^re.NL_sw		/*  and "$" was used	       */
         & (last_char_matched >= first_char_matched) /* and not null string  */
      then if (file_char (last_char_matched) = NL) /* last char NL, don't    */
	 then last_char_matched = last_char_matched - 1;	 /* inc in match */
      if db_srch
      then call ioa_$ioa_switch (db_output,
         "^-[^d:^d ^d:^d] ^d^[(^d:^d)^;:^2s^]^d",
         b.b_.l.le, b.b_.l.re, b.b_.r.le, b.b_.r.re,
         first_char_matched, ami_sw|ame_sw, ami, ame, last_char_matched);
      if ^ami_sw
      then ami = first_char_matched;
      if ^ame_sw
      then ame = last_char_matched;
      if BOL & (ame = ame2)		/* make sure s/^...// doesn't wipe   */
      then ame2 = ame2 + 1;		/* ..whole line		       */
      acode = 0;			/* tell caller match found	       */

exit:
      return;
err_exit:
      acode = 2;
      return;

fail: proc;			/* made a proc so I can find out     */
				/*  where a fail came from.	       */
      acode = 1;			/* here if regexp search failed      */
      if db_srch
      then call ioa_$ioa_switch (db_output,
         "^-[^d:^d ^d:^d] X:X",
         b.b_.l.le, b.b_.l.re,
         b.b_.r.le, b.b_.r.re);
      goto exit;
   end fail;%skip(3);
start_sub_expression: proc (new_type);

dcl new_type	fixed bin;

      if (rep.len ^= 0)		/* if sub-expression outstanding     */
      then do;
         rep.lbd = lb;
         rep.ubd = ub;
         re.len = re.len + rep.len + 4;
         if db_srch
         then call dump_entry (re.len);
         lrep_p = rep_p;
         rep_p = addr (rep.next);
      end;
      rep.len = 0;
      lb, ub = 1;
      rep.typ = new_type;

   end start_sub_expression;%page;
extention: proc;			/* data inside \x[  ]	       */

/* ========================================================================= 
		   extention definition & wishlist
    tedread_ptr_ converts these obsolete forms into the described form:
	\[n]x    => \x[n"x"]
	\[n].    => \x[n.]
	\[n]\c.  => \x[n"."]

   metalanguage used:
	1) comments are inside {}'s.
	2) <form...> means any number of <form>'s
	3) <[min]>   means an optional <min> }
   ========================================================================= 

extention ::= \[ <form...> ]

<form>	::= <[min]> <[max]> <element>
	  | <element> *	{a* => 0:a}

<min>	::= <digits>	{min # wanted, default: 1}
<max>	::= : <digits>	{max # wanted, default: min}
            | :		{infinite # OK}

<element>	::= " <char...> "	{match a string}
	  |   <set>	{test for char being a member of a set}
	  | ^ <set>	{test for char NOT in a set (NYA)}

<set>	::= <simple>	{use a simple set}
	  | s( <simple'...> ){build a compound set (NYA) }

<simple'>	::= " <char...> "	{each char is added to the set}
	  |   <simple>	{each implied char is added to the set}
	  | ^ <simple>	{each implied char is removed from the set}
	  | ^ " <char> "	{the char is removed from the set}

<simple>	::= .		{everything but NL (unless string mode)}
	  | p		{printable		NYA}
	  | w		{whitespace(SP HT FF VT)	NYA}
	  | u		{uppercase		NYA}
	  | l		{lowercase		NYA}
	  | a		{upper+lower+"_"		NYA}
	  | x		{hex degit		NYA}
	  | d		{decimal digit		NYA}
	  | o		{octal digit		NYA}
	  | b		{binary digit		NYA}
	  | 
   ========================================================================= */

dcl (llb, lub)	fixed bin;	/* local lower/upper bounds	       */
dcl beg_num	fixed bin;
dcl not_sw	bit (1);

loop:
      i = i + verify (substr (in_s, i), " ") - 1;
      if (in_c (i) = "]")
      then do;
         call start_sub_expression (STR);
         return;
      end;
      call start_sub_expression (MATCH);/* flush pending expression	       */
      llb, lub = -2;		/* set "empty"		       */
/**** lower bound number					       */
      beg_num = i;
      ii = verify (substr (in_s, i), "0123456789") - 1;
      if (ii > 0)
      then do;
         llb, lub = fixed (substr (in_s, i, ii));
         if (lub = 0)
         then lub = -1;		/* set "zero-seen"		       */
         i = i+ii;
         i = i + verify (substr (in_s, i), " ") - 1;
      end;
/**** upper bound number					       */
      if (in_c (i) = ":")
      then do;
         i = i + 1;
         if (llb = -2)
         then llb = 1;
         lub = 0;			/* init to infinity		       */
         i = i + verify (substr (in_s, i), " ") - 1;
         ii = verify (substr (in_s, i), "0123456789") - 1;
         if (ii > 0)
         then do;
	  lub = fixed (substr (in_s, i, ii));
	  i = i + ii;
	  i = i + verify (substr (in_s, i), " ") - 1;
         end;
      end;
/**** active term						       */
      ch = in_c (i);
      if (ch = "^")
      then do;
         i = i + 1;
         i = i + verify (substr (in_s, i), " ") - 1;
         ch = in_c (i);
         not_sw = "1"b;
      end;
      else not_sw = ""b;
      if (ch = ".")
      then do;
         if not_sw
         then do;
	  msg = "Rnd) ""^."" is meaningless";
x_exit:
	  msg = msg || " in \x[]. """;
	  msg = msg || substr (in_s, 1, i);
	  msg = msg || """";
	  goto err_exit;
         end;
         if (lub ^= -1)
         then do;
	  call start_sub_expression (DOT);
	  rep.len = 1;
	  rep.str = ".";
         end;
         i = i + 1;
         i = i + verify (substr (in_s, i), " ") - 1;
      end;
      else if (ch = """")
      then do;
         if (re.len = 0)
         then next_type = STR_1;	/* first match		       */
         else next_type = STR;	/* continuing match		       */
         call start_sub_expression (next_type);
more_str:
         i = i + 1;
         ii = index (substr (in_s, i), """") - 1;
         j = rep.len;
         rep.len = rep.len + ii;
         substr (rep.str, j+1, ii) = substr (in_s, i, ii);
         i = i + ii + 1;
         if (in_c (i) = """")
         then do;
	  rep.len = rep.len + 1;
	  substr (rep.str, rep.len, 1) = """";
	  goto more_str;
         end;
         if not_sw
         then do;
	  if (rep.len ^= 1)
	  then do;
	     msg = "Rnc) ""^"" cannot apply to multi-char string";
	     goto x_exit;
	  end;
	  rep.typ = NOT_CHAR;
         end;
      end;
      else if (ch = "<")
      then do;
         if (lrep_p ^= null())	/* ignore if first, that's what      */
         then do;			/* ..you get anyway		       */
	  call start_sub_expression (Bmatch);
	  call no_min_max ("<");
	  i = i + 1;
	  rep.len = 1;
	  rep.str = "<";
         end;
      end;
      else if (ch = ">")
      then do;
         call start_sub_expression (Ematch);
         call no_min_max (">");
         i = i + 1;
         rep.len = 1;
         rep.str = ">";
      end;
      else do;
         msg = "Ruc) Unknown char";
         goto x_exit;
      end;
/**** "*" operator, cannot exist with [nn][:nn]			       */
      i = i + verify (substr (in_s, i), " ") - 1;
      if (in_c (i) = "*")
      then do;
         call no_min_max ("*");
         if (rep.typ = DOT)
         then do;
	  msg = "Rds) "".*"" not allowed";
	  goto x_exit;
         end;
         else llb, lub = 0;		/* set 0:infinity		       */
         i = i + 1;
      end;
/**** set default bounds if needed				       */
      if (llb = -1)
      then llb = 1;
      if (lub = -1)
      then lub = llb;		/* llb > lub is ERROR	       */
      lb = llb;			/* llb/lub perhaps not needed	       */
      ub = lub;
      goto loop;

no_min_max: proc (chr);
dcl chr char (1);
         if (llb ^= -1) | (lub ^= -1)
         then do;
	  msg = "Rcs) ""nn:nn values incompatable with """;
	  msg = msg || chr;
	  msg = msg || """. ";
	  goto x_exit;
         end;
      end no_min_max;
   end extention;%page;
dis_exp: entry (acreg_p);		/* redisplay compiled expression     */


      re_p = acreg_p;

      call ioa_$ioa_switch (db_output,
         "^[^14p^;^s^].   #RE len=(^i)^i^[ NL_sw^;^]^[ strmode^;^]
^[^14x^]    #  typ,min,max,len", db_gv, re_p, re.maxl, re.len, NL_sw, strmode,
         db_gv);

      if (re.len = 0) | (re.flag ^= FLAG)
      then return;
      rep_no = 1;
      rep_p = addr (re.parts);
more:
      call dump_entry (rep_no);
      if (rep.typ ^= MATCH)
      then do;
         rep_p = addr (rep.next);
         rep_no = rep_no + 1;
         goto more;
      end;
      return;%page;
check_bounds: proc;
/**** In these 3 cases, the As represent the address range.		       */
/**** Case 0:     (empty)					       */
/**** Case 1: xxAAAxxx...xxxxx	not split			       */
/**** Case 2: xxxxxAAA...Axxxx	split			       */
/**** Case 3: xxxxxxxx...xAAAx	not split			       */

/**** part.this = 2 does not mean you are processing in the upper part. It   */
/**** means that you are either in the right of a split range or the range   */
/**** is not split at all.					       */

      if (part.this = 0)
      then do;			/* nowhere yet		       */
         if (b.cur.sn = 0)		/* buffer is empty?		       */
         then call fail;
         if (part.min_left = b.b_.l.re + 1) /* if just above lower,	       */
         then do;			/* ..switch to upper	       */
	  if (b.b_.r.re < b.b_.r.le)	/* ..unless upper is empty.	       */
	  then call fail;
	  part.min_left = b.b_.r.le;
         end;
         part.cur_loc = part.min_left;	/* start by assuming string is       */
         part.this = 2;		/* ..not split		       */
         part.right_loc = ase;

         if (part.min_left <= b.b_.l.re) /* string start in lower part?      */
         then do;			/* --YES			       */
	  part.left_loc = b.b_.l.le;	/* set left end to lower part	       */
	  if (ase > b.b_.l.re)	/* string extend out of lower part?  */
	  then do;		/* --YES			       */
	     part.right_loc = b.b_.l.re; /* set right end to end of lower  */
	     part.this = 1;		/* indicate there's another to go    */
	  end;
         end;
         else do;
	  part.left_loc = b.b_.r.le;
         end;
         part.min_left = part.min_left + 1;  /* prevent loop on re-try       */
      end;
      else if (part.this = 1)		/* have been operating in 1st part   */
         & (b.b_.r.le <= b.b_.r.re)	/* & upper part isn't empty	       */
      then do;
         part.left_loc,
	  part.cur_loc = b.b_.r.le;	/* continue in the 2nd part	       */
         part.right_loc = ase;
         part.left_size = part.right_loc - part.cur_loc + 1;
         part.this = 2;
         return;
      end;
      else			/* have been operating in 2nd part   */
         call fail;			/*   nowhere to go from here	       */
      if db_srch
      then call ioa_$ioa_switch (db_output,
         "min=^i(^i)l^i,cur^i,r^i", part.min_left, part.this,
         part.left_loc, part.cur_loc, part.right_loc);
      return;

   end check_bounds; %page;

dump_entry: proc (num);

dcl num		fixed bin;

dcl (i, ndx)	fixed bin;
dcl ch		char (1);
dcl result	char (256)var;
/* format: off */
dcl mark		(-2:17) char (8) int static options (constant) init (
/* -1 */		"!/",	"",
/*  0 */		"/",	"!",
/*  1 */		"/^", 	"!",
/*  2 */		"!.*",	"!",
/*  3 */		"!",	"!",
/*  4 */		"!",	"*!",
/*  5 */		"!.!",	"",
/*  6 */		"!NOT""",	"""",
/*  7 */		"!/^NOT""","""",
/*  8 */		"!.*<NIL>","!");
/* format: on */

         ndx = rep.typ * 2;
         call ioa_$ioa_switch_nnl (db_output,
	  "^[^14p^;^s^]    #^2i^2i ^3i,^3i,^3i ^a", db_gv,
	  rep_p, num, rep.typ, rep.lbd, rep.ubd, rep.len, mark (ndx));
         ndx = ndx + 1;
         if (mark (ndx) ^= "")
         then do;
	  result = "";
	  do i = 1 to rep.len;
	     if (length (result) > 250)
	     then do;
	        call ioa_$ioa_switch_nnl (db_output,
		 "^va", length (result), result);
	        result = "";
	     end;
	     ch = substr (rep.str, i, 1);
	     if (ch = NL)
	     then result = result || "\NL";
	     else if (ch = "	")
	     then result = result || "\HT";
	     else if (ch = "\")
	     then result = result || "\\";
	     else result = result || ch;
	  end;
	  call ioa_$ioa_switch_nnl (db_output,
	     "^va", length (result), result);
         end;
         call ioa_$ioa_switch (db_output,
	  mark (ndx));

end dump_entry;
	  

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

%include tedcommon_;
%include tedbcb;
%include tedbase;

   end tedsrch_;
   



		    tedutil_.pl1                    10/07/88  1311.2rew 10/07/88  1305.7      379404


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-08-03,RWaters), approve(88-08-03,MCR7950), audit(88-09-29,Huen),
     install(88-10-07,MR12.2-1146):
     Bug fixes for MR12.2.
                                                   END HISTORY COMMENTS */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

/*                                              _			       */
/*    _|_              |          _|_     o      |		       */
/*     |      _      _ |           |     __      |		       */
/*     |     / \    / \|  |   |    |      |      |		       */
/*     |    (__/   (   |  |   |    |      |      |		       */
/*     \_    \_/    \_/|   \_/|    \_    _|_    _|_		       */
/*                                                    -----		       */
/*							       */

/* Contains:	tedset_ptr_				       */
/*		tedread_ptr_				       */
/*		tederror_					       */
/*		tedcall_					       */
/*		tedresetread_				       */
/*		tedend_buffer_				       */
/*		tedcount_lines_				       */
/*		tedck_ptr_				       */

/* UPDATE HISTORY						       */
/* EL#   date	TR	comments				       */
/* ---		added debug output switch			       */
/* 136 84-10-08 phx16686 don't lose input typed up to \b(not-exist)	       */
/* 148 84-10-10 phx17488 "^>+1 r not-there" executes char after the NL       */
/* 156 84-10-17 phx18195 prohibit 1) invoking buffer in INPUT mode	       */
/*		              2) modifying buffer being executed.	       */
/*		(Also renamed execute parameters to make things a little */
/*		 easier to read)				       */
/* 193 88-07-08 phx19382 RW "loc" may be zero & b_c(0) is a subscript error  */

tedutil_:				/* just a pretty face	       */
   proc;
      return;

dcl (tp, new_bp)	ptr,		/* temporary storage	       */
    (ti, tti, te, i, j, k, escl, srchl) fixed bin (21);
dcl ii		fixed bin (21);
dcl i21		fixed bin (21);
dcl j24		fixed bin (21);
dcl jj		fixed bin (21);
dcl used		fixed bin (21);

dcl concealsw	bit (1);
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (21),
		fixed bin (2), ptr, fixed bin (35));
dcl com_err_	entry () options (variable);
dcl ioa_		entry () options (variable);
dcl cu_$af_arg_count entry (fixed bin, fixed bin (35));
dcl cu_$cp	entry (ptr, fixed bin (21), fixed bin (35));
dcl ioa_$nnl	entry () options (variable);
dcl ioa_$ioa_switch entry () options (variable);
dcl hcs_$get_uid_seg entry (ptr, bit (36), fixed bin (35));


dcl NL		char (1) int static init ("
");


dcl str		char (262144) based aligned;
				/* for use w/substr&index functions  */
dcl iox_$get_line	entry (ptr, ptr, fixed bin (21), fixed bin (21),
		fixed bin (35));
dcl iox_$user_input ptr ext static;
dcl iox_$error_output ptr ext static;
dcl iox_$control	entry (ptr, char (*), ptr, fixed bin (35));

/* dcl 1 DATABASE	based (dbase_p),
      2 zzzzzz	like dbase,
      2 cb	(DATABASE.bufnum) like b; /* expands to arbitrary size   */
%page;
/**** <<<<----- dcl_tedset_ptr_.incl.pl1 tedset_ptr_		       */
tedset_ptr_:			/* find label in local buffer	       */
   entry (adb_p, kharv, kode);
dcl (
    adb_p		ptr,		/* -> database		       */
    kharv		char (*),		/* label to find		       */
    kode		fixed bin (35)	/* return code		       */
    )		parm;		/* ----->>>>		       */

dcl lab		char (20);
dcl labl		fixed bin (21);

      dbase_p = adb_p;
      if (kharv = "BREAK")
      then do;
         kode = 0;
         return;
      end;
      if (dbase.at_break = 2)
      then do;
         dbase.at_break = 0;
         kode = 0;
         return;
      end;
      labl = 2 + length (kharv);
      substr (lab, 3) = kharv;
      substr (lab, 1, 1) = NL;
      substr (lab, 2, 1) = ":";
      bp = dbase.stk_info.curp;	/* current buffer control block      */
      if ^b.tw_sw
      then do;						/* #148*/
         if (ex_EOD = ex_last)	/* make whole buffer available       */
         then ex_EOD = b.b_.r.re;
         ex_last = b.b_.r.re;
      end;						/* #148*/
      if (substr (lab, 3, 2) = "+0")
      then substr (lab, 3, 1) = "-";
      if (substr (lab, 3, 1) = NL)	/* >\012 means last char of buffer   */
      then do;			/*  this may or may not be a NL      */
         if (ex_last = b.b_.r.re)	/* if end-range is end-buffer	       */
	  & (b.b_.r.re < b.b_.r.le)	/* ..& right part is empty	       */
         then call set_exec (b.b_.l.re);/* ..set to end of left part	       */
         else call set_exec (ex_last);	/* ..otherwise use end-range	       */
         kode = 0;
         return;
      end;
      else if (substr (lab, 3, 1) = "+")
      then do;
         do i = 2 to index ("123456789", substr (lab, 4, 1));
	  if (ex_next > ex_EOD)
	  then j = 0;					/* #148*/
	  else						/* #148*/
	     j = index (substr (ex_s, ex_next), NL);
	  if (j = 0)		/* didn't find it		       */
	     & (ex_EOD ^= ex_last)	/* ..but range is split, look again  */
	  then j = index (substr (b_s, b.b_.r.le, ex_last - b.b_.r.le + 1), NL);
	  if (j = 0)
	  then goto label_not_found;
	  call set_exec (ex_next + j);
         end;
         kode = 0;
         return;
      end;
      else if (substr (lab, 3, 1) = "-")
      then do;
         jj = b.b_.r.le;		/* reference upper part	       */
         if (ex_next < jj)		/* if not executing there	       */
         then jj = 1;		/* ..then reference lower part       */
         do i = index ("0123456789", substr (lab, 4, 1)) to 0 by -1;
	  j = index (reverse (substr (b_s, jj, ex_next - jj)), NL);
	  if (j > 0)
	  then call set_exec (ex_next - j);
	  else do;
	     if (i = 0)
	     then do;
	        ex_next = jj;
	        kode = 1;
	        return;
	     end;
	     if (ex_EOD = ex_last)	/* if in upper part		       */
	     then do;		/* ..move to lower part	       */
	        jj = 1;
	        call set_exec (b.b_.l.re);
	     end;
	     else goto label_not_found;
	  end;
         end;
         call set_exec (ex_next + 1);
         kode = 0;
         return;
      end;
      else do;
         j = 0;
         if (labl <= b.b_.l.re)
         then do;
	  if (substr (b_s, 1, labl - 1) = substr (lab, 2, labl - 1))
	  then do;		/* label at front of buffer,	       */
	     call set_exec (1);	/*  then set to there.	       */
	     kode = 0;
	     return;
	  end;
				/* find label, (at begin of a line)  */
	  j = index (substr (b_s, 1, b.b_.l.re), substr (lab, 1, labl));
         end;
         if (j = 0)
         then if (labl <= b.maxl - b.b_.r.le + 1)
	    then do;
	       if (substr (b_s, b.b_.r.le, labl - 1) = substr (lab, 2, labl - 1))
	       then do;		/* label at front of part 2,	       */
		call set_exec (b.b_.r.le); /*  then set to there.	       */
		kode = 0;
		return;
	       end;
				/* find label, (at begin of a line)  */
	       j = index (substr (b_s, b.b_.r.le), substr (lab, 1, labl));
	       if (j > 0)
	       then j = j + b.b_.r.le - 1;
	    end;
      end;
      if (j ^= 0)
      then do;
         call set_exec (j + 1);
         kode = 0;
         return;
      end;
      if (kode = 0)
      then do;
label_not_found:
         msg = "Bgo) ";		/* :*** not defined in b(***).       */
         msg = msg || substr (lab, 2, labl - 1);
         msg = msg || " not defined in b(";
         msg = msg || substr (b.name, 1, index (char (b.name, 17), " ") - 1);
         msg = msg || ").";
         call tederror_ (dbase_p, msg);
         kode = 10;
      end;
      return; %skip (4);
/**** Rewrote this routine to try to make things work, then		/* #156*/
/**** found that it couldn't be done.  So other places prohibit	/* #156*/
/**** the attempt entirely.					/* #156*/

init_exec: proc (left, right);				/* #156*/

dcl (left, right)	fixed bin (21);				/* #156*/

      if  db_util & lg_util & ^b.tw_sw
      then call tedshow_ (bp, "> exI b_ ex");			/* #156*/
      ex_last = right;					/* #156*/
      ex_lre = min (b.b_.l.re, right);				/* #156*/
      if (left > ex_lre)
      then ex_EOD = ex_last;					/* #156*/
      else ex_EOD = ex_lre;					/* #156*/
      goto common;						/* #156*/

set_exec: entry (left);					/* #156*/

      if  db_util & lg_util & ^b.tw_sw
      then call tedshow_ (bp, "> exS b_ ex");			/* #156*/
common:
      ex_next = left;					/* #156*/
      if (ex_next <= b.b_.l.re)	/* if next is in lower part,	       */
      then ex_EOD =			/* ..then EOD must be also	       */
         min (b.b_.l.re, ex_last);	/* ..but only what's available   #156*/
      else do;
         ex_EOD = ex_last;		/* ..else EOD is up top	   #156*/
         if (ex_next = b.b_.l.re + 1)	/* if next just dropped out of       */
         then ex_next = b.b_.r.le;	/* ..of lower, move up top.	   #156*/
         if (ex_next < b.b_.r.le)	/* if next is below upper, current   */
         then do;			/* ...is within gap - tsk,tsk	   #156*/
	  signal condition (ex_next_in_gap);
dcl ex_next_in_gap	condition;
	  ex_next = b.b_.r.le;
         end;
      end;						/* #148*/
      if  db_util & lg_util & ^b.tw_sw
      then call tedshow_ (bp, "< ex");				/* #156*/
   end init_exec; %skip (4);
tedwhere_: entry (adb_p);		/* +++ called by ted_eval_	       */
      dbase_p = adb_p;
      bp = dbase.stk_info.curp;
      call tedcount_lines_ (b.cur.sp, 1, ex_next - 1, j);
      call ioa_ ("b(^a), line ^d, level ^d[^a]", b.name, j,
         dbase.stk_info.level, dbase.recurs);
      return; %page;
no_input: proc;

dcl error_table_$end_of_info fixed bin (35) ext static;
dcl error_table_$io_no_permission fixed bin (35) ext static;
dcl timer_manager_$sleep entry (fixed bin (71), bit (2));

      if (code = error_table_$end_of_info)
      then ;
      else if (code = error_table_$io_no_permission)
      then call timer_manager_$sleep (10, "11"b);
      else call com_err_ (code, dbase.tedname, "Reading user_input");

   end no_input; %page;
break_input:
      if (dbase.at_break = 1)
      then do;
         if (mode = "INPUT") | (mode = "BREAK")
         then goto reloop;
re_break:
         call ioa_ ("**BREAK** (level,line,buffer). [Recursion=^i]",
	  dbase.recurs);
         call tedcount_lines_ (bp, 1, ex_next - 1, j);
         call ioa_ ("^-^3i ^4i b(^a)", dbase.stk_info.level, j, b.name);
         if (dbase.at_break = 2)
         then do;
	  k = index (reverse (substr (b_s, 1, ex_next - 1)), NL);
	  if (k = 0)
	  then k = 1;
	  else k = ex_next - k + 1;
dcl dec6		pic "zzzzz9";
	  dec6 = j;
	  msg = dec6 || "	";
	  if (k < ex_next)
	  then do;
	     msg = msg || substr (b_s, k, ex_next - k + 1);
	     msg = msg || "	";
	  end;
	  msg = msg || "<BREAK>
	";
	  k = index (substr (b_s, ex_next, 256), NL);
	  msg = msg || substr (b_s, ex_next, k);
	  call ioa_ ("^a", (msg));
         end;
         dbase.at_break = 2;
      end;
      dbase.err_go = "BREAK";
/****    if (mode = "INPUT")
         then do;
	  call ioa_ ("BREAK: not allowed. INPUT MODE");
	  substr (red_line, 1, 2) = "\f";
	  nelemt = 2;
	  return;
         end;						       */
bk_loop:
      call iox_$get_line (iox_$user_input, atp, ibe, nelemt, code);
      if (code ^= 0)
      then do;
         call no_input;
         goto bk_loop;
      end;
      if db_catch
      then call ioa_$ioa_switch_nnl (db_output,
         "====BRK^-^a", substr (red_line, 1, nelemt));
      if (nelemt = 3) & (substr (red_line, 1, 2) = "\?")
      then goto re_break;
      return;			/* tedset_ptr_ */%page;
/**** <<<<----- dcl_tedread_ptr_.incl.pl1 tedread_ptr_		       */
tedread_ptr_:			/* read a line from input stream     */
   entry (adb_p, atp, ibi, ibe, nelemt, mode);
dcl (
/****adb_p	ptr,		/* -> database		       */
    atp		ptr,		/* -> input buffer		       */
    ibi		fixed bin (21),	/* last char in use in buffer	       */
    ibe		fixed bin (21),	/* last char useable in buffer       */
    nelemt	fixed bin (21),	/* last char filled in buffer  [OUT] */
    mode		char (5)		/* mode in which read is being done  */
    )		parm;		/* ----->>>>		       */
dcl red_line	char (ibe) based (atp);
dcl red_char	(ibe) char (1) based (atp);
dcl tmode		char (5);
dcl db_input	bit (1);

      tmode = mode;
      db_input = db_ted & ((tmode="INPUT")|(tmode="BULK"));
reread:
      dbase_p = adb_p;
      concealsw = "0"b;
      bp = dbase.stk_info.curp;	/* get ptr to cur buffer ctl block   */
      nelemt = ibi;			/* make sure old line is gone	       */
      ti = ibi;
      te = ibe;
      if (dbase.at_break ^= 0)
      then goto break_input;
reloop:
      if db_util & ^b.tw_sw
      then call tedshow_ (bp, "ex");
      tti = ti;
      do while (ti <= te);
retry:
         if ex_next > ex_EOD		/* is part being read exhausted?     */
         then do;
	  if b.tw_sw		/* coming from user_input?	       */
	  then do;
	     if (rdy.len > 0) & (ex_EOD ^= 1) & (tmode = "EDIT")
	     then begin;
dcl rdyline	char (rdy.len);
	        rdyline = rdy_line;
	        call cu_$cp (addr (rdyline), rdy.len, code);
	     end;
refresh:	     begin;

	        if b.pseudo
	        then do;
		 b.b_.l.re = b.b_.l.le - 1;
		 b.b_.r.le = b.b_.r.re + 1;  /* make it look empty       */
		 call tedpromote_ (bp, 4069);
				/* dbase.rl.part1 = b.cur;	       */
	        end;

	        b.b_.l.re = 0;
loop:
	        call iox_$get_line (iox_$user_input, b.cur.sp, b.maxl,
		 b.b_.l.re, code);
	        if (code ^= 0)
	        then do;		/* not handling long records	       */
		 call no_input;
		 goto loop;
	        end;
	        if db_catch
	        then call ioa_$ioa_switch_nnl (db_output,
		 "====^a^-^a", tmode, substr (b_s, 1, b.b_.l.re));
	        call init_exec (1, (b.b_.l.re));
	        if (ex_EOD = 3) & (substr (b_s, 1, 3) = "\?
")
	        then do;
		 call tell_where (tmode);
		 ex_EOD = 0;
		 goto loop;	/* try again to get data for caller  */
	        end;

	     end refresh;
	  end;
	  else do;		/* here on end of buffer	       */
	     call tedend_buffer_ (dbase_p, 0); /* pop level by 1	       */
	     bp = dbase.stk_info.curp;/* re-establish prev buff ctl block  */
	  end;
	  goto retry;
         end;
         if (tmode = "EDIT") & (ti = 0) & (ex_EOD > ex_next)
         then if (substr (b_s, ex_next, 2) = "..")
	    then do;		/* NEED TO HANDLE ARBITRARY LENGTH!  */
	       call set_exec (ex_next + 2);
	       tp = addr (ex_c (ex_next));
	       kk = ex_EOD - ex_next + 1;
	       i21 = index (substr (b_s, ex_next, kk), NL);
	       if (i21 = 0)
	       then do;
		i21 = kk;
		call set_exec (ex_next + i21);
	       end;
	       else call set_exec (ex_next + i21 - 1);
	       call tedset_ck_ptr_ (dbase_p);
	       call cu_$cp (tp, i21, code);
dcl kk		fixed bin (21);
	       tp = atp;
	       substr (red_line, 1, 3) = "e";
	       ti = 3;
	       goto rdp (1);	/* add a NL		       */
	    end;
         srchl = min (ex_EOD - ex_next + 1, te - ti + 1);
         if (tmode = "BULK")
         then do;
	  if (substr (b_s, ex_next, 2) = ".
")	  then do;
	     call set_exec (ex_next + 2);
	     mode = "EOF";
	     goto end_read;
	  end;
	  k = index (substr (b_s, ex_next, srchl), NL);
				/* NEED to avoid line splitting?     */
         end;
				/* find a char needing attention     */
         else k = search (substr (b_s, ex_next, srchl), hot_chars);

dcl hot_chars	char (7) int static options (constant) init ("
\");

         if (k = 0)
         then k = srchl;
         else k = k - 1;
         if (k > 0)			/* move intervening chars, if any    */
         then do;
	  substr (red_line, ti + 1, k) = substr (b_s, ex_next, k);
	  if db_input then call ioa_$ioa_switch (db_output, 
	     "^a: (^p->red_line,ti+1(^i),^i)=^p->str,len=^i", tmode,
	     addr(red_line), ti+1, k, addcharno (b.cur.sp, ex_next-1), ti+k);
	  ti = ti + k;
	  call set_exec (ex_next + k);
         end;
         if (ti > te)		/* caller's buffer full?	       */
         then goto end_read;		/*  YES			       */
         if (ex_next > ex_EOD)	/* source exhausted?	       */
         then goto retry;		/*  YES			       */
         k = index (hot_chars, substr (b_s, ex_next, 1));
         if (^dbase.old_style | b.tw_sw) & (k > 3)
         then do;
	  if (tmode ^= "INPUT")
	  then do;
	     substr (red_line, ti + 1, 2) = "\c";
	     ti = ti + 2;
	  end;
	  goto move_ch;
         end;
         goto rdp (k);

rdp (1):				/* NL */
         ti = ti + 1;
         red_char (ti) = NL;
         if db_input then call ioa_$ioa_switch (db_output, 
	  "^a: (^p->red_line,ti+1(^i),i)=NL,len=^i", tmode,
	  addr(red_line), ti, ti);
         call set_exec (ex_next + 1);
         goto end_read; %skip (5);
dcl old_msg	char (47) int static options (constant) init (
		"^/^a: b(^a) contains a \03^a (old-style \^a).^/");

rdp (4):				/* \031 (old \c)		       */
         if b.tw_sw
         then goto move_ch;
         if ^b.bs.c
         then do;
	  call ioa_ (old_msg, dbase.tedname, b.name, "1", "C");
	  b.bs.c = "1"b;
         end;
         escl = 0;
esc (1):				/* "\c"			       */
         if (tmode = "INPUT")
         then goto always_conceal;
         k = index (hot_chars, substr (b_s, ex_next + escl + 1, 1));
         if (k = 2)			/* "\"			       */
         then do;
	  if (ex_next + escl < ex_EOD)	/* is there another char?      */
	  then do;
	     j = index (ESCAPES, substr (b_s, ex_next + escl + 2, 1));
	     if (j > ESCmax)
	     then j = j - ESCmax;
	     k = j + 3;
	  end;
	  else k = 0;
         end;
         if (k = 0)			/* not of interest		       */
	  | (k = 4)		/* \031 \c		       */
	  | (k = 7)		/* \034 \f		       */
         then do;
	  substr (red_line, ti + 1, escl + 2)
	     = substr (b_s, ex_next, escl + 2);
	  if db_input then call ioa_$ioa_switch (db_output, 
	     "^a: (^p->red_line,ti+1(^i),^i)=^p->str,len=^i", tmode,
	     addr(red_line), ti+1, escl + 2, addcharno (b.cur.sp, ex_next-1),
	     ti + escl + 2);
	  ti = ti + escl + 2;
         end;
         else do;
always_conceal:
	  if db_input then call ioa_$ioa_switch (db_output, 
	     "^a: (^p->red_line,ti+1(^i),1)=^p->str,len=^i", tmode,
	     addr(red_line), ti+1, addcharno (b.cur.sp, ex_next + escl), ti+1);
	  ti = ti + 1;
	  red_char (ti) = substr (b_s, ex_next + escl + 1, 1);
         end;
         call set_exec (ex_next + escl + 2);
         goto end_loop; %skip (5);
rdp (5):				/* \030 (old \b)		       */
         if b.tw_sw
         then goto move_ch;
         if ^b.bs.b
         then do;
	  call ioa_ (old_msg, dbase.tedname, b.name, "0", "B");
	  b.bs.b = "1"b;
         end;
         escl = 0;
esc (2):				/* "\b"			       */
         call set_exec (ex_next + escl + 1);
/**** Must the gap be accounted for here?			       */
         used = ex_EOD - ex_next + 1;
         call tedget_existing_buffer_ (dbase_p, addr (b_c (ex_next)),
	  used, new_bp, msg);	/* try to find named buffer	       */
         call set_exec (ex_next + used);
         if (new_bp = null ())	/* error if named buffer does	       */
         then do;			/*   not already exist	       */
rd_err:
	  if (tmode = "INPUT")
	  then msg = msg || "
INPUT mode terminated.";					/* #136*/
	  call tederror_ (dbase_p, msg);
	  call tedresetread_ (dbase_p); /* reset back to level 0	       */
	  if (tmode = "INPUT")
	  then do;					/* #136*/
	     mode = "EOF";					/* #136*/
	     goto end_read;					/* #136*/
	  end;						/* #136*/
	  goto reread;		/* and reread this call from scratch */
         end;
         if new_bp -> b.INPUT
         then do;						/* #156*/
	  msg = "Bmi) Cannot invoke b(";			/* #156*/
	  msg = msg || rtrim (new_bp -> b.name);		/* #156*/
	  msg = msg || "), it is in INPUT mode.";		/* #156*/
	  goto rd_err;					/* #156*/
         end;						/* #156*/
         if (dbase.stk_info.level > 500)
         then do;
	  msg = "Brc) Level > 500.";
	  goto rd_err;		/* check buffer recursion level      */
         end;
         call push_one (dbase.stk_info.next);
         if (ex_next = 1) & (ex_last = b.maxl)
         then b.not_pasted = "0"b;
         goto retry; %skip (5);
rdp (6):				/* \036 (old \r)		       */
         if b.tw_sw
         then goto move_ch;
         if ^b.bs.r
         then do;
	  call ioa_ (old_msg, dbase.tedname, b.name, "6", "R");
	  b.bs.r = "1"b;
         end;
         escl = 0;
esc (3):				/* "\r"			       */
         if (tmode = "INPUT")		/* in INPUT mode postpone the \r     */
         then do;			/* ..if there isn't a fair amount of */
	  if (te - ti < 256)	/* ..space left in the file to       */
	  then do;		/* ..receive it.		       */
	     te = ti - 1;		/* force EOBuffer		       */
	     goto end_read;
	  end;
         end;
         call set_exec (ex_next + escl + 1);
console_read:
         tp = addr (temp_fix);
dcl temp_fix	char (512);
         call iox_$get_line (iox_$user_input, tp, length (temp_fix),
	  j24, code);
         if (code ^= 0)
         then do;
	  call no_input;
	  goto console_read;
         end;
         if db_catch
         then call ioa_$ioa_switch_nnl (db_output,
	  "====READ^-^a", substr (temp_fix, 1, j24));
         j24 = min (j24, te - ti);
         substr (red_line, ti + 1, j24) /* move line (as much as	       */
	  = substr (tp -> str, 1, j24); /*  will fit) to caller's buffer  */
	  if db_input then call ioa_$ioa_switch (db_output, 
	     "^a: (^p->red_line,ti+1(^i),^i)=^p->str,len=^i", tmode,
	     addr(red_line), ti+1, j24, tp, ti+j24);
         ti = ti + j24;
         if (dbase.tedname = "qedx")
         then goto end_read;		/* qedx quits right there	       */
         else do;
	  if (red_char (ti) = NL)
	  then ti = ti - 1;		/* ted doesn't give up so easily     */
         end;
         if (j24 = 3) & (substr (tp -> str, 1, 1) = "\")
         then do;
	  if (substr (tp -> str, 2, 1) = "?")
	  then do;
	     call tell_where ("READ");
	     goto console_read;
	  end;
	  if (index ("fF", substr (tp -> str, 2, 1)) ^= 0)
	  then do;
	     mode = "\R\F";
	     goto read_exit;
	  end;
         end;
         goto retry; %skip (5);
dcl ESCAPES	char (14) int static options (constant) init
		("cbrfvx{[CBRFVX");
dcl ESCmax	fixed bin int static init (8) options (constant);
rdp (2):				/* "\"			       */
         j = index (ESCAPES, substr (b_s, ex_next + 1, 1));
         if (j = 0)
         then goto move_ch;
         if (j > ESCmax)
         then j = j - ESCmax;
         escl = 1;
         goto esc (j); %skip (5);
esc (5):				/* "\v"			       */
         if (substr (b_s, ex_next + 2, 1) = "{")
         then do;
	  call set_exec (ex_next + 1);/* "\v{"			       */
dcl 1 adr_hold	(0:2) like b.a_;
esc (7):				/* "\{"			       */
	  call set_exec (ex_next + 1);
	  adr_hold = b.a_;		/* keep what is there right now      */
	  b.present (1), b.present (2) = "0"b;
	  used = ex_EOD - ex_next + 1;
	  call tedeval_ (dbase_p, addr (b_c (ex_next)), used,
	     bp, null (), -1, result, msg, code);
	  call set_exec (ex_next + used);
	  b.a_ = adr_hold;		/* someone else might need it	       */
	  if (code ^= 0)
	  then goto rd_err;
	  j24 = min (length(result), te - ti);
	  substr (red_line, ti + 1, j24) = result;
	  if db_input then call ioa_$ioa_switch (db_output, 
	     "^a: (^p->red_line,ti+1(^i),^i)=^p->str,len=^i", tmode,
	     addr(red_line), ti+1, j24, addr (result), ti+j24);
	  ti = ti + j24;
	  goto retry;
         end;
esc (8):				/* "\[" */
         j = verify (substr (b_s, ex_next + 2), "0123456789");
         if (substr (b_s, ex_next + 1 + j, 1) = "]")
         then do;			/* convert \[n].   to \x[n.]	       */
				/* *    or \[n]\cx to \x[n"x"]       */
				/* *    or \[n]x   to \x[n"x"]       */
	  j24 = ti;
	  substr (red_line, ti + 1, 3) = "\x[";
	  ti = ti + 3;
	  substr (red_line, ti + 1, j - 1) = substr (b_s, ex_next + 2, j - 1);
	  ti = ti + j - 1;
	  call set_exec (ex_next + j + 2);
	  if (substr (b_s, ex_next, 1) = ".")
	  then do;
	     substr (red_line, ti + 1, 2) = ".]";
	     ti = ti + 2;
	  end;
	  else do;
	     if (substr (b_s, ex_next, 2) = "\c")
	        | (substr (b_s, ex_next, 2) = "\C")
	     then call set_exec (ex_next + 2);
	     substr (red_line, ti + 1, 4) = """?""]";
	     substr (red_line, ti + 2, 1) = substr (b_s, ex_next, 1);
	     ti = ti + 4;
	  end;
	  if db_input
	  then do;
	     k = ti - j24;
	     call ioa_$ioa_switch (db_output, 
	        "^a: (^p->red_line,ti+1(^i),^i)=""^a"",len=^i", tmode,
	     addr(red_line), j24+1, k, substr (red_line, j24+1, k), ti+k);
	  end;
	  call set_exec (ex_next + 1);
         end;
         else call ioa_ ("\[active_function] not implemented.");
esc (6):				/* "\x[" (just passed thru)	       */
         goto move_ch;
dcl result	char (500) var;
dcl code		fixed bin (35); %skip (5);
rdp (3):				/* "\037" BREAK		       */
         if (tmode = "INPUT")
	  | dbase.tedname = "qedx"
         then goto move_ch;
         call set_exec (ex_next + 1);
         if ^dbase.break_sw
         then goto end_loop;
         dbase.at_break = 1;
         red_char (ti + 1) = NL;
         goto end_read; %skip (5);
rdp (7):				/* \034 (old \f)		       */
         if b.tw_sw
         then goto move_ch;
         if ^b.bs.f
         then do;
	  call ioa_ (old_msg, dbase.tedname, b.name, "4", "F");
	  b.bs.f = "1"b;
         end;
         escl = 0;
esc (4):				/* "\f"			       */
rdp (0):
         if (tmode = "INPUT")
         then do;
	  mode = "EOF";
	  call set_exec (ex_next + 2);
	  if (substr (b_s, ex_next, 1) = NL)
	  then call set_exec (ex_next + 1);
	  goto end_read;
         end;
move_ch:
         ti = ti + 1;
         red_char (ti) = substr (b_s, ex_next, 1);
         call set_exec (ex_next + 1);
end_loop:
      end;
end_read:
/**** INPUT/BULK modes will not return at EOline, they will return at EOinfo */
/****  or EObuffer. Then last char used is updated for each line for -safe.  */
      nelemt = ti;			/* return last char in use	       */
dcl EL_sw		bit(1);

      if (ti = 0)
      & (mode ^= "EOF")		/* this happens when \037 is first   */
      then goto reloop;		/* ..thing on a line.	       */
      if (ti = 0)			/* next statement will blow up if    */
      then EL_sw = "1"b;		/* ..ti=0, prevent that.	       */
      else EL_sw = (substr (red_line, ti, 1) ^= NL) | (mode = "EOF");
      if (tmode = "EDIT") & dbase.edit_sw
         | (tmode = "INPUT") & dbase.input_sw
      then call ioa_$nnl ("**^a**	^a^[^/^]", mode,
         substr (red_line, tti+1, ti-tti), EL_sw);
      if (osw_p ^= null())
      then if (tmode = osmode) | (osmode = "ALL")
      then call ioa_$ioa_switch_nnl (osw_p, "**^a**^-^a^[^/^]", mode,
         substr (red_line, tti+1, ti-tti), EL_sw);
      if (ti <= te)
      then if (mode = "INPUT") | (mode = "BULK")
      then goto reloop;
read_exit:
      if db_ted
      then call ioa_$ioa_switch (db_output, "^a: ^i:^i:^i ^i", mode, ibi, ti, ibe, nelemt);
      return; %skip (4);
dcl osmode	char (8) int static init ("");
dcl osw_p		ptr int static init (null());
dcl iox_$look_iocb entry (char(*), ptr, fixed bin(35));
dcl ioa_$ioa_switch_nnl entry() options(variable);
dcl iox_$open	entry (ptr, fixed bin, bit(1) aligned, fixed bin(35));
dcl error_table_$not_closed fixed bin(35) ext static;
		
osw: entry (p1, p2);
dcl (p1,p2) char (*);
     call iox_$look_iocb (p1, osw_p, code);
     if (code ^= 0)
     then do;
        osw_p = null();
osw_err:
        call com_err_ (code, "ted(osw)", "^a", p1);
        return;
     end;
     call iox_$open (osw_p, 2, ""b, code);
     if (code ^= 0)
     then do;
        if (code ^= error_table_$not_closed)
        then goto osw_err;
     end;
     osmode = p2;
     return; %skip(4);     
tell_where: proc (mode);

dcl mode		char (5);

      call ioa_ ("^a^[(^a)^;^s^]: ^a MODE[^i]^[safe^]",
         dbase.tedname, (dbase.tedname = "ted"), ted_vers, mode,
         dbase.recurs, (dbase.dir_db ^= ""));

   end tell_where;%page;
tederror_:			/* save {& print} an error message   */
   entry (adb_p, a_msg);
dcl (
/****adb_p	ptr,		/* -> dabatase		       */
    a_msg		char (168) var	/* error message		       */
    )		parm;

      dbase_p = adb_p;
      if (length (a_msg) < 6)
      then dbase.err_msg = "???) " || a_msg;
      else dbase.err_msg = a_msg;
      if (dbase.err_go = " ") | (dbase.at_break ^= 0)
      then do;
         if db_util
         then call ioa_$ioa_switch_nnl (iox_$error_output, "^a",
	       substr (dbase.err_msg, 1, 5));
         call ioa_$ioa_switch_nnl (iox_$error_output, "^a^/",
	  substr (dbase.err_msg, 6));
         if (osw_p ^= null())
         then call ioa_$ioa_switch_nnl (osw_p, "^a^/",
	  substr (dbase.err_msg, 6));
      end;
      return;			/* tedread_ptr_ */%skip (4);
/**** <<<<----- dcl_tedcall_.incl.pl1 tedcall_			       */
tedcall_:				/* call a buffer		       */
   entry (adb_p, acode);
dcl (
/****adb_p	ptr,		/* -> database		       */
    acode		fixed bin (35)
    )		parm;		/* ----->>>>		       */

      acode = 0;
      dbase_p = adb_p;
      bp = dbase.stk_info.curp;
      used = rl_l - rl_i + 1;
      call tedget_existing_buffer_ (dbase_p, addr (rl_c (rl_i)),
         used, new_bp, msg);		/* try to find named buffer	       */
      rl_i = rl_i + used;
      if (new_bp = null ())		/* error if does not already exist   */
      then do;
         call tederror_ (dbase_p, msg);
         acode = 1;
         return;
      end;
      if (dbase.stk_info.level > 500)
      then do;
         msg = "Brc) Level > 500.";
         call tederror_ (dbase_p, msg);
         acode = 1;
         return;
      end;
      if (dbase.seg_p (3) = null())
      then call tedget_segment_ (dbase_p, null(), 3);
/**** make room for argument string				       */
      pstrp = addr (call_stk.space (dbase.stk_info.next));
      pstrl = dbase.stk_info.next;
      i = rl_l - rl_i;
      dbase.stk_info.next = dbase.stk_info.next + divide (i + 7, 8, 24, 0);
      substr (pstrp -> str, 1, i) = substr (rl_s, rl_i, i);
      call push_one (pstrl);
      if (i > 0)			/* if argstring is non-null	       */
      then do;			/*  parse the arguments	       */
         sv.pp (0) = pstrp;
         sv.pl (0) = i;
         delim = pchar (1);
         sv.pn = 1;
         sv.pp (1) = addr (pchar (2));
         sv.pl (1) = 0;
         do ii = 2 to i;
	  if (substr (pstrp -> str, ii, 2) = "\C")
	     | (substr (pstrp -> str, ii, 2) = "\c")
	  then do;
	     if (pchar (ii + 2) = delim)
	     then goto use_pch;
	  end;
	  if (pchar (ii) = delim)
	  then do;
	     sv.pn = sv.pn + 1;
	     sv.pp (sv.pn) = addr (pchar (ii + 1));
	     sv.pl (sv.pn) = 0;
	  end;
	  else do;
use_pch:
	     sv.pl (sv.pn) = sv.pl (sv.pn) + 1;
	  end;
         end;
         dbase.stk_info.next = dbase.stk_info.next + sv.pn * 2 + 2;
      end;
      return /* tedcall_ */;
dcl delim		char (1);
dcl pstrp		ptr;
dcl pchar		(1:2000) char (1) based (pstrp);
dcl pstrl		fixed bin (21);%page;
/**** <<<<----- dcl_tedend_buffer_.incl.pl1 tedend_buffer_		       */
tedend_buffer_:			/* pop buffer recursion 1 level      */
   entry (adb_p, ecode);
dcl (
/****adb_p	ptr,		/* -> database		       */
    ecode		fixed bin (35)	/* 1- already at level 0, 0- ok      */
    )		parm;		/* ----->>>>		       */
      i = ecode;
      dbase_p = adb_p;
      if (dbase.stk_info.level = 0)	/* check recursion level	       */
      then do;
         ecode = 1;			/* error if level already 0	       */
         return;			/* return error condition to caller  */
      end;
      call pop_one;
      if (i = COM) & (dbase.stk_info.level = 0)
      then ecode = 1;
      else ecode = 0;
      return;			/* and return to caller	       */
%skip (4);
pop_one: proc;

      if db_util
      then call tedshow_ (dbase_p, "stkall");
      bp = dbase.stk_info.curp;	/* current execution buffer	       */
      b.invoking = ""b;		/* clear execution range	       */
      unspec (b.ex) = unspec (tedcommon_$no_data);
      sv_p = dbase.stk_info.top;	/* pop a stack frame and restore...  */
      dbase.stk_info.top = sv.prev;	/* ...top of stack		       */
      dbase.stk_info.next = sv.this;	/* ...free location		       */
      dbase.stk_info.curp, bp = sv.bp;	/* ...buffer control block	       */
      b.ex = sv.ex;			/* ...read limits		       */
      b.invoking = (unspec (b.ex) ^= unspec (tedcommon_$no_data));
      b.a_ (0) = sv.a0;
      b.stackl = sv.stackl;
      dbase.stk_info.level = dbase.stk_info.level - 1;

   end pop_one; %page;
push_one: proc (this);

dcl this		fixed bin (21);

      dbase.stk_info.level
         = dbase.stk_info.level + 1;	/* bump recursion level	       */
      dbase.stk_info.curp = new_bp;	/* make new buffer current	       */
      if (dbase.seg_p (3) = null())
      then call tedget_segment_ (dbase_p, null(), 3);
      sv_p			/* create stack frame and save...    */
         = addr (call_stk.space (dbase.stk_info.next));
      sv.prev = dbase.stk_info.top;	/* ...current top of stack	       */
      sv.bp = bp;			/* ...current buffer control block   */
      sv.ex = b.ex;			/* ...execution limits	       */
      sv.a0 = b.a_ (0);		/* ..."." value		       */
      sv.stackl = b.stackl;		/* ...AND keep track of where this   */
      b.stackl = rel (sv_p);		/*    data is for relocation	       */
      sv.this = this;		/* ...free location		       */
      sv.pn = 0;			/* ...start as if no args	       */
      sv.pp (0) = null();
      sv.pl (0) = 0;
      dbase.stk_info.next = dbase.stk_info.next + size (sv);
      dbase.stk_info.top = sv_p;	/* push the stack frame	       */
      bp = dbase.stk_info.curp;	/* new current buffer	       */
      b.invoking = "1"b;					/* #156*/
      call init_exec (b.a_.l.re (1),  b.a_.r.le (2));		/* #156*/
      if db_util & lg_util
      then call tedshow_ (dbase_p, "stkall");

   end push_one; %skip (4);
tedresetread_:			/* abort to buffer level 0	       */
   entry (adb_p);

      dbase_p = adb_p;
      if dbase.stk_info.level ^= 0	/* if buffer recursion level > 0     */
      then do;
         call ioa_ ("Executing (level,line,buffer). [Recursion=^i]",
	  dbase.recurs);
         bp = dbase.stk_info.curp;	/* current buffer		       */
         do while (dbase.stk_info.level ^= 0);/* release buff recursion stk  */
	  call tedcount_lines_ (bp, 1, ex_next - 1, j);
	  call ioa_ ("^-^3i ^4i b(^a)", dbase.stk_info.level, j, b.name);
	  call pop_one;
         end;
      end;
      bp = dbase.stk_info.curp;	/* get pointer to level 0 ctl block  */
      ex_next = ex_last + 1;		/* set buffer exhausted	   #156*/
      if reset_read
      then call iox_$control (iox_$user_input, "resetread", null (), code);
      return; %page;
set_req_line: entry;

      if (rdy.len ^= 0)
      then do;
         free rdy_line;
         rdy.len = 0;
      end;
      call cu_$arg_ptr (1, tp, i21, code); dcl arg char (i21) based (tp);
      if (code ^= 0)
      then do;
         return;
      end;
      rdy.len = i21;
      allocate rdy_line;
      rdy_line = arg;
      return;

dcl 1 rdy		int static,
      2 len	fixed bin (21) init (0),
      2 pt	ptr;

dcl rdy_line	char (rdy.len) based (rdy.pt);

get_req_line: entry;

      call cu_$af_arg_count (l, code);
      if (code ^= 0)
      then call ioa_ ("^a", rdy_line);
      else do;
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl af_val	char (af_len) var based (af_ptr);
dcl af_len	fixed bin (21);
dcl af_ptr	ptr;
dcl l		fixed bin;
         call cu_$af_return_arg (l + 1, af_ptr, af_len, code);
         af_val = rdy_line;
      end;
      return;			/* tedend_buffer_ */%page;

/**** <<<<----- dcl_tedcount_lines_.incl.pl1 tedcount_lines_	       */
tedcount_lines_:			/* return # lines in string	       */
   entry (abp, asi, ase, alct);
dcl (
    abp		ptr,		/* -> buffer in which to count       */
    asi		fixed bin (21),	/* where string begins in segment    */
    ase		fixed bin (21),	/* where string ends in segment      */
    alct		fixed bin (21)	/* # lines		 [OUT] */
    )		parm;		/* ----->>>>		       */

dcl lct		fixed bin (21);
dcl loc		fixed bin (21);

      bp = abp;
      lct = 0;
      if db_util
      then call ioa_$ioa_switch_nnl (db_output,
         ".lct:sn=^i", b.cur.sn);
      if (b.cur.sn ^= 0)		/* any data in buffer?	       */
      then do;
         call count ((asi), min (ase, b.b_.l.re));
         call count (max (b.b_.r.le, asi), ase);
         if (b.b_.r.re < b.b_.r.le)	/* upper part empty		       */
         then loc = min (ase, b.b_.l.re);
         else loc = ase;
         
/* RW 88 */
         if (loc ^= 0) then                                           /* #193*/
             if (b_c (loc) ^= NL) then
		lct = lct + 1;
      end;
      alct = lct;
      if db_util
      then call ioa_$ioa_switch (db_output, " =^i", alct);
      return;

count: proc (ti, te);
dcl (ti		fixed bin (21),	/* beginning point		       */
    te		fixed bin (21)	/* ending point		       */
    )		parm;

dcl lti		fixed bin (21);	/* local ti		       */
dcl str		char (te) based (b.cur.sp);
dcl II		fixed bin (21);

      lti = ti;
      do while (lti <= te);
         II = index (substr (str, lti), NL);
         if (II ^= 0)		/* a NL found		       */
         then do;
	  lct = lct + 1;		/* count one line		       */
	  lti = lti + II;		/* move past it		       */
         end;
         else lti = te + 1;
      end;
      if db_util
      then call ioa_$ioa_switch_nnl (db_output, " ^i:^i ^i", ti, te, lct);

   end count; %page;
tedck_ptr_:			/* check on flagged ^read seg        */
   entry (aabp);
dcl (
    aabp		ptr		/* -> buffer control block	       */
    )		parm;

dcl error_table_$invalidsegno fixed bin (35) ext static;
dcl tuid		bit (36);

      bp = aabp;
      call hcs_$get_uid_seg (b.cur.sp, tuid, code);
      if (code = error_table_$invalidsegno)
      then goto re_init;
      if (code ^= 0)
      then do;
         call com_err_ (code, dbase.tedname,
	  "Checking on b(^a) segment ^a>^a", b.name, b.dname, b.ename);
         goto re_init;
      end;
      if (tuid = b.uid)
      then goto ck_out;
re_init:				/* assume can't do anything with     */
				/*  that pointer */
      call hcs_$initiate_count (b.dname, b.ename, "", ii, 0, tp, code);
      if (tp = null ())
      then do;
         b.b_ = tedcommon_$no_data;
         dbase.not_read_ct = max (0, dbase.not_read_ct - 1);
         call com_err_ (code, dbase.tedname,
	  "Trying to reconnect segment ^a>^a to b(^a)",
	  b.dname, b.ename, b.name);
         b.dname = "";
         b.file_sw = "0"b;
         b.terminate = "0"b;
         b.mod_sw = "0"b;
         b.get_bit_count = "0"b;
         b.not_pasted = "0"b;
         goto ck_out;
      end;
      addr (b.cur.sp) -> its.segno = addr (tp) -> its.segno;
      call hcs_$get_uid_seg (b.cur.sp, b.uid, code);
      ii = divide (ii, 9, 24, 0);
      if (ii ^= b.maxl)
      then do;
         call com_err_ (0, dbase.tedname,
	  "Segment ^a>^a connected to b(^a) changed size from ^i to ^i",
	  b.dname, b.ename, b.name, b.b_.r.re, ii);
         b.maxl, b.b_.r.re, b.b_.l.re, b.b_.l.re = ii;
         b.b_.l.le = 1;
      end;
ck_out:
      b.ck_ptr_sw = "0"b;
      return; %page;

dcl (
    addcharno, addr, char, divide, index, length, max, min, null, rel, reverse,
    rtrim, search, size, substr, unspec, verify
    )		builtin;

dcl (ex_next	defined b.ex.l.le,	/* next char to execute	       */
    ex_EOD	defined b.ex.l.re,	/* last char in part to execute      */
    ex_lre	defined b.ex.r.le,	/* last char in left part to execute */
    ex_last	defined b.ex.r.re)	/* last char to execute	       */
		fixed bin (21);				/* #156*/
dcl ex_s		char (b.ex.l.re) based (b.cur.sp);
dcl ex_c		(b.ex.l.re) char (1) based (b.cur.sp);
%include tedbcb;
%include tederror_;
%include tedstk;
%include tedbase;
%include tedcommon_;
%include its;
dcl tedset_ck_ptr_	entry (ptr);
dcl tedget_existing_buffer_ entry (	/* find a named buffer	       */
		ptr,		/* -> database		       */
		ptr,		/* -> string containing buffer name  */
		fixed bin (21),	/*   length of string	  [IN] */
				/*   how much was used	 [OUT] */
		ptr,		/* buffer control block (OUT)        */
		char (168)var	/* error message text	       */
		);

/*dcl tedget_buffer_entry (		/* find (or create) a buffer	       */
/*		ptr,		/* -> database		       */
/*		ptr,		/* -> string containing buffer name  */
/*		fixed bin (21),	/*   length of string	  [IN] */
/*				/*   how much was used	 [OUT] */
/*		ptr,		/* buffer control block (OUT)        */
/*		char (168)var	/* error message text	       */
/*		);					       */


dcl tedeval_	entry (		/* process evaluations	       */
		ptr,		/* -> database		       */
		ptr,		/* -> evaluation string	       */
		fixed bin (21),	/*   length thereof 	  [IN] */
				/*   amount used up 	 [OUT] */
		ptr,		/* -> buffer control block	       */
		ptr,		/* -> matched string in \g{...}      */
				/*    null otherwise	       */
		fixed bin (21),	/*  length of string in \g{...}      */
				/* <0 in \{...}, 0 otherwise	       */
		char (500) var,	/* output string, if any	       */
		char (168) var,	/* error message, if any	       */
		fixed bin (35)	/* return code		       */
		);


dcl tedshow_	entry options (variable);
%include tedsrch_;
dcl tedget_segment_ entry (		/* get a segment to work in	       */
		ptr,		/* -> database		       */
		ptr,		/* -> gotten segment	 [OUT] */
		fixed bin,	/* sequence # of it         [IN/OUT] */
				/* if >0 upon entry, it will then    */
				/*  fill that entry in seg_p array   */
				/* otherwise it will take any one    */
		);


dcl tedpromote_	entry (		/* get a larger data buffer	       */
		ptr,		/* -> buffer to promote	       */
		fixed bin (21)	/* amount not fitting	       */
		);


   end tedutil_;


		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved