


		    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 stri