ted_ax_.pl1                     11/23/82  1459.7rew 11/23/82  1458.1       31464



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

ted_ax_:				/* append w/speedtype expansion      */
       proc (ted_support_p, msg, code);

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

      if (inp.de > 0)
      then do;			/* something already in buffer       */
         i = inp.se - inp.sb + 1;
         substr (ostr, out.de + 1, i) = substr (istr, inp.sb, i);
         inp.sb = inp.sb + i;		/* adjust for doing append	       */
         out.de = out.de + i;
         call checkpoint (inp.sb, out.de);
      end;
      goto start;

ted_ix_:				/* insert w/speedtype expansion      */
         entry (ted_support_p, msg, code);

      if (inp.de = 0)
      then do;
empty:
         msg = "Abe) Buffer empty.";
         code = tederror_table_$Error_Msg;
         return;
      end;
      inp.se = inp.sb;
      goto start;

ted_cx_:				/* change w/speedtype expansion      */
      entry (ted_support_p, msg, code);

      if (inp.de = 0)
      then goto empty;
      inp.sb = inp.se + 1;		/* delete range specified	       */
      call checkpoint (inp.sb, out.de);

start:
      if (ted_support_version_2 ^= ted_support.version)
      then do;
         code = error_table_$unimplemented_version;
         return;
      end;
loop:
      call iox_$get_line (iox_$user_input, /* get a line of input	       */
         addr (buffer), length (buffer), i, code);
      if (i = 1)
      then do;			/* if empty, can't do much to it     */
         substr (ostr, out.de + 1, 1) = substr (buffer, 1, 1);
         out.de = out.de + 1;
      end;
      else do;			/* look for trailing controls	       */
         if (substr (buffer, 1, i - 1) = "\F")
	  | (substr (buffer, 1, i - 1) = "\f")
         then goto finish;

         if (substr (buffer, 1, i - 1) = "\?")
         then do;
	  call ioa_ ("*INPUT MODE - speedtype");
	  goto loop;
         end;

         call speedtype_expand_ (addr (buffer), i, addr (ochr (out.de + 1)),
	  out.ml - out.de, j, code);
         out.de = out.de + j;
      end;
      call checkpoint (inp.sb, out.de);
      goto loop;

finish:
      current = out.de;		/* tell ted where "." is	       */
      if (inp.de > 0)
      then do;			/* there is more data in buffer      */
         i = inp.de - inp.sb + 1;	/* ..copy it to output	       */
         substr (ostr, out.de + 1, i) = substr (istr, inp.sb, i);
         out.de = out.de + i;
         inp.se = inp.de + 1;		/* we have already copied	       */
      end;
      req.nc = req.cc;		/* let rest of req line be used      */
      code = tederror_table_$Copy_Set;%page;
%include ted_support;
dcl (i, j)	fixed bin (21);
dcl iox_$user_input ptr ext static;
dcl iox_$get_line	entry (ptr, ptr, fixed bin (21), fixed bin (21),
		fixed bin (35));
dcl ioa_		entry options (variable);
dcl speedtype_expand_ entry (ptr, fixed bin (21), ptr, fixed bin (21),
		fixed bin (21), fixed bin (35));
dcl buffer	char (500);

   end ted_ax_;




		    ted_tabout_.pl1                 11/23/82  1459.7rew 11/23/82  1458.5       68184



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

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

ted_gtabout_:			/* process out pseudo-tabs globally  */
      proc (ted_support_p, msg, code);
      mode = "g";
      goto global;

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

ted_vtabout_:			/* process out pseudo-tabs globally  */
      entry (ted_support_p, msg, code);
      mode = "v";
global:
      if (ted_support.version ^= ted_support_version_2)
      then do;
         code = error_table_$unimplemented_version;
         return;
      end;
      call proc_expr (ted_support_p, msg, code);
      if (code ^= 0)
      then return;
      goto common;

ted_tabout_:			/* process out pseudo-tabs	       */
      entry (ted_support_p, msg, code);
      mode = " ";

      if (ted_support.version ^= ted_support_version_2)
         & (ted_support.version ^= 1)
      then do;
         code = error_table_$unimplemented_version;
         return;
      end;

common:
      delim = rchr (req.cc);
      req.cc = req.cc + 1;		/* process the tab specs	       */
      substr (tabmarks, 1, 1) = delim;
      tab = " ";
      last_tab = 0;
      tabchar = rchr (req.cc);
      j = req.cc + 1;
      if (rchr (j) = delim)		/* if none specified,	       */
      then do;			/*  use system settings	       */
gb2b:
         do j = 11 to length (tab) by 10;
	  substr (tab, j, 1) = "L";
	  last_tab = j;
         end;
         req.cc = req.cc + 1;
         goto gb2a;
      end;
      num = 0;
      do req.cc = j to req.de;	/* walk across request line	       */
         tc = rchr (req.cc);
         nd = index (tabmarks, tc);
         if (nd ^= 0)
         then do;
	  if (num = 0)
	  then goto skipit;
	  if (num > length (tab) - 4)
	  then do;
	     msg = "Sts) Tabstob >";
	     pic3 = length (tab) - 4;
	     msg = msg || pic3;
	     code = tederror_table_$Error_Msg;
	     return;
	  end;
	  last_tab = max (num, last_tab);   /* remember rightmost stop     */
	  if (nd > 5)
	  then nd = nd - 3;		/* account for upper case	       */
	  if (nd < 3)
	  then nd = 3;
				/* plug in the stop		       */
	  substr (tab, num, 1) = substr (tabmarks, nd, 1);
	  num = 0;
	  if (rchr (req.cc + 1) = ",")
	  then req.cc = req.cc + 1;
	  if (rchr (req.cc + 1) = delim)
	  then do;
	     req.cc = req.cc + 1;
	     goto gb2a;
	  end;
	  if (tc = delim)
	  then goto gb2a;
         end;
         else do;
	  nd = index ("0123456789", tc);
	  if (nd = 0)
	  then do;
	     msg = "Sbd) Bad decimal digit.";
	     code = tederror_table_$Error_Msg;
	     return;
	  end;
	  num = num * 10 + nd - 1;
         end;
skipit:
      end;
      if (mode = " ")
      then code = tederror_table_$No_Delim2;
      else code = tederror_table_$No_Delim3;
      return;
gb2a:
      code = 0;
      req.nc = req.cc + 1;
      last_tab = last_tab - 1;
      if (mode = " ")
      then call worker;
      else call do_global (worker, mode, ted_support_p, msg, code);
      if (code = 0)
      then do;
         current = out.de;		/* tell ted where "." now is	       */
         code = tederror_table_$Copy_Set;  /* tell ted to finish up	       */
      end;
      return;%page;
worker: proc;
      
         visi, viso = 0;
         save_de = out.de;
         tabdone = "0"b;
         do ic = inp.sb to inp.se;
	  ch = ichr (ic);
	  if (viso >= last_tab)	/* if we're beyond last stop	       */
	  then if (ch = tabchar)	/* ..and its a tab		       */
	  then do;		/* ..just place a SP in its place    */
	     ch = " ";
	     tabdone = "1"b;	/* this switch is necessary because  */
	  end;			/* ..tabchar may be \040	       */
	  if (ichr (ic + 1) = BSP)
	  then do;		/* grab all parts of an overstrike   */
	     ochr (out.de + 1) = ch;
	     out.de = out.de + 1;
	     do while (ichr (ic + 1) = BSP);
	        substr (ostr, out.de + 1, 2) = substr (istr, ic + 1, 2);
	        out.de = out.de + 2;
	        ic = ic + 2;
	     end;
	     visi = visi + 1;	/* input visual		       */
	     viso = viso + 1;	/* ..and output visual go up	       */
	  end;
	  else if (ch = tabchar) & ^tabdone
	  then do;		/* HEY! found a tab		       */
	     SPct = 1;
	     do j = viso to length (tab) - 3   /* look for the next stop   */
	        while (substr (tab, j + 2, 1) = " ");
	        SPct = SPct + 1;
	     end;
	     if (substr (tab, j + 2, 1) = "L") /* if it is a left-set      */
	     then do;		/* ..add the needed space on right   */
	        substr (ostr, out.de + 1, SPct) = " ";
	        out.de = out.de + SPct;
	     end;
	     else do;
	        if (substr (tab, j + 2, 1) = "C") /* if centering,	       */
	        then L = divide (SPct, 2, 24, 0); /* ..use half the space  */
	        else L = SPct;	/* ..otherwise use it all	       */
	        R = SPct - L;	/* then what is left over?	       */
	        hold_leng = out.de - save_de;  /* pull out tabb'ed data    */
	        hold = substr (ostr, save_de + 1, hold_leng);
	        hold_leng = hold_leng + R;  /* reset output length	       */
	        out.de = save_de;
	        substr (ostr, out.de + 1, L) = " ";  /* put in left SPs    */
	        out.de = out.de + L;
	        substr (ostr, out.de + 1, hold_leng) = hold;  /* then put  */
	        out.de = out.de + hold_leng;   /* ..back the data	       */
	     end;
	     if (ch = HT)		/* don't let an HT mess up the       */
	     then visi = visi + (10 - mod (visi, 10));  /* ..visual pos    */
	     else visi = visi + 1;
	     viso = viso + SPct;
	  end;
	  else if (ch = HT)		/* we check for this because the tab */
	  then do;		/* ..may not be an HT, but HT's      */
	     visi = visi + 1;	/* ..cause visual things which are   */
	     viso = viso + 1;	/* ..maintained		       */
	     if (mod (visi, 10) ^= 0)
	     then ic = ic - 1;
	     ochr (out.de + 1) = " ";
	     out.de = out.de + 1;
	  end;
	  else do;		/* just an ordinary character	       */
	     ochr (out.de + 1) = ch;
	     out.de = out.de + 1;
	     visi = visi + 1;
	     viso = viso + 1;
	     if (ch = NL)		/* This "ordinary" character happens */
	     then do;		/* ..to finish up a line	       */
	        visi, viso = 0;
	        tabdone = "0"b;
	        save_de = out.de;
	     end;
	  end;
	  if (substr (tab, viso + 1, 1) ^= " ")	  /* when we pass over     */
	  then save_de = out.de;	/* ..a stop, remember where we are   */
         end;

      end worker;%page;
dcl last_tab	fixed bin (24);
dcl tab		char (204);
%include ted_support;

dcl L		fixed bin (24);
dcl R		fixed bin (24);
dcl SPct		fixed bin (24);
dcl ch		char (1);
dcl delim		char (1);
dcl hold		char (200);
dcl hold_leng	fixed bin (24);
dcl ic		fixed bin (24);
dcl j		fixed bin (24);
dcl mode		char (1);
dcl nd		fixed bin (24);
dcl num		fixed bin;
dcl pic3		pic "zz9";
dcl save_de	fixed bin (24);
dcl tabchar	char (1);
dcl tabdone	bit (1);
dcl tabmarks	char (8) int static init ("/,LCRlcr");
dcl tc		char (1);
dcl visi		fixed bin (24);
dcl viso		fixed bin (24);
dcl BSP		char (1) int static init ("");
dcl HT		char (1) int static init ("	");
dcl NL		char (1) int static init ("
");

   end ted_gtabout_;




		    ted_tabin_.pl1                  11/23/82  1459.7rew 11/23/82  1458.4       30618



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

ted_tabin_:			/* convert SPs to HTs, rtrim	       */
     proc (ted_support_p, msg, code);

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

      if (ted_support.version ^= ted_support_version_2)
      then do;
         code = error_table_$unimplemented_version;
         return;
      end;
      req.nc = req.cc;		/* any request data after be used    */
      SPct, HTct, vis = 0;		/* assumes starting at beg-of-line   */
      do i = inp.sb to inp.se;	/* step thru all chars addressed     */
         ch = ichr (i);		/* get next char		       */
         ochr (out.de + 1) = ch;	/* and put it		       */
         out.de = out.de + 1;		/* ..to output segment	       */
         if (ch = SP)
         then do;			/* we have a space		       */
	  SPct = SPct + 1;		/* count the space string	       */
	  vis = vis + 1;		/* count the visible location	       */
	  if (mod (vis, 10) = 0)
	  then do;		/* if reached a tabstop..	       */
	     if (SPct > 1)
	     then do;		/* ..and more than one space here    */
	        out.de = out.de - SPct;
	        ochr (out.de + 1) = HT;  /* replace the spaces with an HT  */
	        out.de = out.de + 1;
	        HTct = HTct + 1;	/* (count how HTs here)	       */
	     end;
	     SPct = 0;		/* no spaces left over here	       */
	  end;
         end;
         else if (ch = HT)
         then do;			/* we have a tab		       */
	  if (SPct > 0)
	  then do;		/* ..and there were spaces before    */
	     out.de = out.de - SPct;
	     ochr (out.de + 1) = HT;	/* strip 'em out		       */
	     out.de = out.de + 1;
	  end;
	  SPct = 0;
	  vis = vis + mod (vis, 10);	/* keep track of visual position     */
	  HTct = HTct + 1;
         end;
         else if (ch = NL)
         then do;			/* we have hit end of line	       */
	  out.de = out.de - SPct - HTct - 1;   /* strip trailing HT,SPs    */
	  ochr (out.de + 1) = NL;
	  out.de = out.de + 1;
	  SPct, HTct, vis = 0;	/* reset for next line beginning     */
         end;
         else do;			/* "ordinary" char, it stays	       */
	  SPct, HTct = 0;		/* no SP,HTs pending	       */
	  if (ch = BSP)		/* don't let BSPs foul up the	       */
	  then vis = vis - 1;	/* ..visual position	       */
	  else vis = vis + 1;
         end;
      end;
      current = out.de;
      code = tederror_table_$Copy_Set;
      return;%page;
%include ted_support;


dcl lb		fixed bin (24),	/* first character to process	       */
    le		fixed bin (24);	/* last character to process	       */

dcl HTct		fixed bin (24);
dcl i		fixed bin (24);
dcl SPct		fixed bin (24);
dcl ch		char (1);
dcl vis		fixed bin (24);
dcl SP		char (1) int static init (" ");
dcl HT		char (1) int static init ("	");
dcl BSP		char (1) int static init ("");
dcl NL		char (1) int static init ("
");

   end ted_tabin_;




		    ted_comment_.pl1                11/23/82  1459.7rew 11/23/82  1458.3       42174



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

ted_comment_:			/* add comments to a file	       */
       proc (ted_support_p, msg, code);

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

      if (ted_support_version_2 ^= ted_support.version)
      then do;
         code = error_table_$unimplemented_version;
         return;
      end;
loop:
      ii = inp.se - inp.sb + 1;	/* how much range left	       */
      if (ii <= 0)
      then goto EOB;		/* WE'RE done!		       */
      i = index (substr (istr, inp.sb, ii), NL);
      if (i = 0)			/* calc line length		       */
      then i = ii;
      else i = i - 1;		/* must be >0 because if you type an */
      if (i > 0)			/* ..empty line with no NL, the user */
      then do;			/* ..doesn't get much indication     */
				/* type what is already on line      */
         call iox_$put_chars (iox_$user_output, addr (ichr (inp.sb)), i, code);
reask:				/* ask him what he wants to add      */
         call iox_$get_line (iox_$user_input, addr (buffer), length (buffer),
	  il, code);
         if (il > 2)		/* if answer was big enough, see     */
         then do;			/* ..if it ends with a control       */
	  ch2 = substr (buffer, il - 2, 2);
	  if (ch2 = "\d")		/* he wants that line deleted	       */
	  then do;
	     inp.sb = inp.sb + i + 1; /* so do it already		       */
	     goto loop;
	  end;

	  if (ch2 = "\f") | (ch2 = "\F")
	  then goto finish;		/* he wants to bail out early	       */

	  if (ch2 = "\i")
	  then do;		/* he wants to insert some data      */
	     if (i = 0)
	        | (il ^= 3)		/* but he didn't say it nice	       */
	     then do;
	        call iox_$put_chars (iox_$user_output, addr (msg_bad),
		 length (msg_bad), code);
	        goto loop;
	     end;
	     i = 0;		/* go get the data for insertion     */
	     goto reask;
	  end;
	  if (ch2 = "\a")		/* he wants data appended	       */
	  then do;
	     if (i > 0)
	     then do;
	        substr (ostr, out.de + 1, i)
		 = substr (istr, inp.sb, i); /* copy the input line      */
	        out.de = out.de + i;
	        inp.sb = inp.sb + i + 1;
	     end;
add1:
	     i = 0;
	     il = il - 3;		/* knock off the control chars       */
	     substr (ostr, out.de + 1, il)
	        = substr (buffer, 1, il);   /* copy the new data	       */
	     out.de = out.de + il + 1;
	     substr (ostr, out.de, 1) = NL;
	     call checkpoint (inp.sb - 1, out.de);
	     goto reask;
	  end;
         end;
         if (i > 0)
         then do;			/* just ordinary added data	       */
	  substr (ostr, out.de + 1, i) = substr (istr, inp.sb, i);
	  out.de = out.de + i;
	  inp.sb = inp.sb + i + 1;
         end;
         substr (ostr, out.de + 1, il) = substr (buffer, 1, il);
         out.de = out.de + il;
      end;
      else do;
         substr (ostr, out.de + 1, 1) = NL;
         out.de = out.de + 1;
         inp.sb = inp.sb + 1;
      end;
      call checkpoint (inp.sb - 1, out.de);
      goto loop;

EOB:
      if (inp.se = inp.de)
      then call iox_$put_chars (iox_$user_output, addr (msg_EOB),
         length (msg_EOB), code);
      else call iox_$put_chars (iox_$user_output, addr (NL), 1, code);

finish:
      current = out.de;		/* tell ted where "." now is	       */
      i = inp.de - inp.sb + 1;
      substr (ostr, out.de + 1, i) = substr (istr, inp.sb, i);
      out.de = out.de + i;
      req.nc = req.cc;		/* let 'em use the rest of line      */
      inp.se = inp.de + 1;
      code = tederror_table_$Copy_Set;
      return;%page;
%include ted_support;

dcl ch2		char (2);
dcl iox_$user_input ptr ext static;
dcl iox_$user_output ptr ext static;
dcl iox_$put_chars	entry (ptr, ptr, fixed bin (24), fixed bin (35));
dcl iox_$get_line	entry (ptr, ptr, fixed bin (24), fixed bin (24),
		fixed bin (35));
dcl i		fixed bin (24);
dcl ii		fixed bin (24);
dcl il		fixed bin (24);
dcl buffer	char (600);
dcl msg_EOB	char (7) int static options (constant) init ("
	EOB

");
dcl msg_bad	char (19) int static options (constant) init ("Improper use of \i
");
dcl NL		char (1) int static init ("
");

dcl (pointer, substr) builtin;

   end ted_comment_;




		    ted_dump_.pl1                   11/23/82  1459.7rew 11/23/82  1458.2       33192



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

ted_dump_:			/* output via terminal width	       */
          proc (ted_support_p, msg, code);

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

	i = get_line_length_ ("user_output");
          if (i > 110)
	then goto dumpl;
	if (i > 60)
	then goto dumps;

ted_dumpvs_:			/* output in 40 cols	       */
          entry (ted_support_p, msg, code);
	maxcc = 5;
	maxll = 17;
	goto start;

ted_dumps_:			/* ouput 60 columns		       */
          entry (ted_support_p, msg, code);
dumps:
	maxcc = 10;
	maxll = 34;
	goto start;

ted_dumpl_:			/* output 110 columns	       */
          entry (ted_support_p, msg, code);
dumpl:
	maxcc = 20;
	maxll = 71;
	goto start;

start:
	if (ted_support_version_2 ^= ted_support.version)
	then do;
	     code = error_table_$unimplemented_version;
	     return;
	end;
	if (inp.de = 0) then do;
Abe:
	     msg = "Abe) Buffer empty.";
	     code = tederror_table_$Error_Msg;
	     return;
	end;
	octal = " ";
	line, lineno = inp.lno;
	if string_mode
	then linebegin = 0;
	else do;
	     i = index (reverse (substr (istr, 1, inp.sb-1)), NL);
	     if (i = 0)
	     then linebegin = 0;
	     else linebegin = inp.sb-i;
	end;
	byte = inp.sb - linebegin;
	alpha = " ";
	j1, j2 = 1;
	do i = inp.sb to inp.se;
	     ch = ichr (i);
	     fromc = ch;
	     toc = "000";
	     to.b1 = from.b1;
	     to.b2 = from.b2;
	     to.b3 = from.b3;
	     substr (octal, j2, 3) = toc;
	     j2 = j2 + 3 + mod (j1+1, 2);
	     if (j1 = 10)
	     then j2 = j2 + 2;
	     if (ch < " ") & (ch ^= NL)
	     | (ch > "~")
	     then substr (alpha, j1, 1) = ".";
	     else substr (alpha, j1, 1) = ch;
	     j1 = j1 + 1;
	     if (j1 > maxcc)
	     | (i = inp.se)
	     | (ch = NL) then do;
		jjj = max (index (reverse (line), " "), 4);
		header = substr (line, 8-jjj);
		jjj = max (index (reverse (byte), " "), 5);
		header = header || substr (byte, 12-jjj);
		call ioa_ ("^a  ^va  ^a", header, maxll, octal, alpha);
		alpha = " ";
		octal = " ";
		if (ch = NL)
		then do;
		     lineno = lineno + 1;
		     line = lineno;
		     if ^string_mode
		     then linebegin = i;
		end;
		else line = 0;
		byte = i-linebegin+1;
		j1, j2 = 1;
	     end;
	end;
	req.nc = req.cc;
	current = inp.se;
	code = tederror_table_$Set;
	return;%page;
%include ted_support;

dcl (addr, index, mod, substr) builtin;

dcl  NL char (1)int static init ("
");
dcl  alpha char (20);
dcl  byte pic "zzzzzzzzzzz";
dcl  ch char (1);
dcl  fromc char (1)based (addr (from));
dcl  get_line_length_ entry (char (*)) returns (fixed bin);
dcl  header char (32)var;
dcl  i fixed bin (24);
dcl  ioa_ entry options (variable);
dcl  j1 fixed bin (24);
dcl  j2 fixed bin (24);
dcl  jjj fixed bin;
dcl  line pic "zzzzzzzz";
dcl  linebegin fixed bin (24);
dcl  lineno fixed bin (24);
dcl  maxcc fixed bin;
dcl  maxll fixed bin;
dcl  octal char (74);

dcl 1 from,
    2 b1 bit (3),
    2 b2 bit (3),
    2 b3 bit (3);
dcl  toc char (3)based (addr (to));
dcl 1 to,
    2 f1 bit (6),
    2 b1 bit (3),
    2 f2 bit (6),
    2 b2 bit (3),
    2 f3 bit (6),
    2 b3 bit (3);

     end ted_dump_;




		    ted_fina_.pl1                   11/23/82  1500.8rew 11/23/82  1458.5       82278



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

ted_fiad_:			/* fill/adjust a region	       */
   proc (ted_support_p, msg, code);
      adjust = "1"b;
      goto start;

ted_fina_:			/* fill/adjust a region	       */
   entry (ted_support_p, msg, code);
      adjust = ""b;
      goto start;

dcl (
    msg		char (168) var,	/* error message text	 [OUT] */
    code		fixed bin (35)	/* return code		       */
    )		parm;


dcl ioa_$nnl	entry () options (variable);
dcl ioa_		entry () options (variable);

dcl (NL		init ("
"),
     HT		init ("	")
    )		char (1) int static options (constant);


start:
      if (ted_support.version ^= ted_support_version_2)
      then do;
         code = error_table_$unimplemented_version;
         return;
      end;
      req.nc = req.cc;		/* any request data after be used    */
      code = 0;

      req.cc = req.cc + verify (substr (rstr, req.cc), " ") - 1;
      if (inp.de = 0)
      then call error ("Abe) Buffer empty.");
error: proc (err);

dcl err		char (*);

         msg = err;
         req.nc = req.cc;
         if adjust
         then msg = msg || " |fiad";
         else msg = msg || " |fina";
         code = tederror_table_$Error_Msg;
         goto exit;
      end error;
      zsb = inp.sb;
      zse = inp.se;

      delim = rchr (req.cc);		/* pick up str delimiter	       */
      if (delim = " ")
      then call error ("Sd1) No 1st delimiter.");
      matchloc = req.cc + 1;		/* index of first char of str1       */
      matchleng = index (substr (rstr, req.cc + 1), delim);
      if (matchleng = 0)
      then call error ("Sd2) No 2nd delimiter.");
      req.cc = matchloc + matchleng;
      matchleng = matchleng - 1;

      call get_num ("Slm) No left margin.");
      lmarg (1), lmarg (2) = num;

      if (rchr (req.cc) ^= ",")
      then call error ("Smc) Missing comma.");
      req.cc = req.cc + 1;
      call get_num ("Srm) No right margin.");
      if (num < lmarg (1))
      then call error ("Srl) Right margin < left margin.");
      rmarg = num;
      if (rchr (req.cc) = ",")
      then do;
         req.cc = req.cc + 1;
         call get_num ("Sni) No indent.");
         if (num > rmarg)
         then call error ("Sir) Indent > right margin.");
         lmarg (1) = num;
      end;
      if (rchr (req.cc) ^= delim)
      then call error ("Sd3) No 3rd delimiter.");
      req.nc = req.cc + 1;%page;
      putted = 0;
      marg = 1;
      left_set = "0"b;
      hole_ct = -1;
      visleng, wordleng = 0;
      firstime = "1"b;
      if (zsb < zse)
      then do;
         do while (zsb <= zse);
	  if firstime
	  then do;
	     ch = NL;
	     firstime = "0"b;
	  end;
	  else do;
	     ch = ichr (zsb);
	     zsb = zsb + 1;
	  end;
	  if (ch = NL)
	  then do;
	     call putword;
	     if (zsb <= zse)
	     then do;
	        if (ichr (zsb) = NL)
	        then do;
		 visleng, wordleng = 9999;
		 call putword;
		 marg = 1;
		 left_set = "0"b;
	        end;
	        else if (matchleng > 0)
	        then if (substr (istr, zsb, matchleng)
		      = substr (rstr, matchloc, matchleng))
		   then do;
		      zle = index (substr (istr, zsb, (zse - zsb + 1)), NL);
				/* find end of next line	       */
		      if (zle = 0)	/* worry about no NL	       */
		      then zle = zse; /* ..at end of buffer	       */
		      else zle = zsb + zle - 1;
		      visleng, wordleng = 9999;
		      call putword;
		      wordloc = zsb;
		      visleng, wordleng = zle - zsb;
		      putted = -wordleng;
		      if (out.de > 0)
		      then out.de = out.de - 1;
		      call putword;
		      if db_sw then call ioa_$nnl ("!!^/");
		      hole_ct = -1;
		      putted = 0;
		      zsb = zle;
		   end;
	     end;
	  end;
	  else if (ch = " ") | (ch = HT)
	  then call putword;
	  else do;
	     if (wordleng = 0)
	     then wordloc = zsb - 1;
	     wordleng = wordleng + 1;
	     if (ch ^= "")
	     then visleng = visleng + 1;
	     else visleng = visleng - 1;
	  end;
         end;
         if wordleng > 0
         then call putword;
      end;

      if (out.de = 0)
      then out.de = 1;
      substr (ostr, out.de, 1) = NL;
      current = out.de;
      code = tederror_table_$Copy_Set;
exit:
      return;

putword: proc;

      if (wordleng > 0)
      then do;
         if (putted + visleng > rmarg)
         then do;
	  if adjust
	  then call fixup;
	  hole_ct = -1;
	  putted = 0;
	  if (wordleng = 9999)
	  then do;
	     visleng, wordleng = 0;
	     if (out.de > 0)
	     then do;
	        if db_sw then call ioa_$nnl ("!^/");
	        substr (ostr, out.de, 1) = NL;
	        out.de = out.de + 1;
	     end;
	     return;
	  end;
         end;
         if (putted = 0)
         then do;
	  if db_sw then call ioa_$nnl ("^/^vx", lmarg (marg));
	  if (out.de > 0)
	  then substr (ostr, out.de, lmarg (marg)) = NL;
	  else substr (ostr, 1, lmarg (marg)) = " ";
	  putted = lmarg (marg) - 1;
	  out.de = out.de + lmarg (marg) - 1;
	  lineloc = out.de + 1;
         end;
         virtleng = wordleng;
         if (marg = 1)
         then if (visleng < lmarg (2) - lmarg (1))
	    then do;
	       virtleng = wordleng + (lmarg (2) - lmarg (1)) - visleng - 1;
	       visleng = lmarg (2) - lmarg (1) - 1;
	       lineloc = out.de + virtleng + 2;
	       hole_ct = hole_ct - 1;
	    end;
         if db_sw then call ioa_$nnl ("^va ", virtleng,
	       substr (istr, wordloc, wordleng));
         substr (ostr, out.de + 1, virtleng + 1)
	  = substr (istr, wordloc, wordleng);
         out.de = out.de + virtleng + 1;
         putted = putted + visleng + 1;
         hole_ct = hole_ct + 1;
         visleng, wordleng = 0;
         marg = 2;
      end;

   end putword; %page;

fixup: proc;			/* do the adjusting		       */

      if (putted ^= 0) & (hole_ct > 0) & (wordleng ^= 9999)
      then do;
         leftover = rmarg - putted + 1;
         temploc = 1;
         templeng = out.de - lineloc + 1;
         begin;
dcl temp_area	char (templeng + 1);
	  if db_sw
	  then call ioa_$nnl ("^/***^d holes (temp,^d,^d)=(ostr,^d,^d)",
		hole_ct, temploc, templeng + 1, lineloc, templeng);
	  substr (temp_area, temploc, templeng + 1)
	     = substr (ostr, lineloc, templeng);
	  if db_sw
	  then call ioa_$nnl ("^/");
	  out.de = lineloc - 1;
	  fill = divide (leftover, hole_ct, 17, 0);
	  leftover = mod (leftover, hole_ct);
	  if left_set
	  then incr = -1;
	  else do;
	     incr = 1;
	     leftover = leftover - hole_ct + 1;
	  end;
	  do i = 1 to hole_ct;
	     j = index (substr (temp_area, temploc, templeng), " ");
	     moveleng = j + fill + fixed ((leftover > 0), 17);
	     leftover = leftover + incr;
	     if db_sw then call ioa_$nnl ("^va", moveleng,
		   substr (temp_area, temploc, j));
	     substr (ostr, out.de + 1, moveleng)
	        = substr (temp_area, temploc, j);
	     out.de = out.de + moveleng;
	     temploc = temploc + j;
	     templeng = templeng - j;
	  end;
	  if (templeng > 0)
	  then substr (ostr, out.de + 1, templeng)
		= substr (temp_area, temploc, templeng);
	  if db_sw then call ioa_$nnl ("^a|^/",
		substr (ostr, out.de + 1, templeng));
	  out.de = out.de + templeng;
         end;
      end;
      left_set = ^left_set;
   end fixup;
dcl num		fixed bin (21);
dcl num_sw	bit (1);

get_num: proc (err);
dcl err		char (*);

      i = verify (substr (rstr, req.cc), "0123456789");
      if (i > 1)
      then do;
         num = fixed (substr (rstr, req.cc, i - 1));
         req.cc = req.cc + i - 1;
         if (num = 0)
         then i = 1;
      end;
      if (i = 1)
      then call error (err);

   end get_num; %page;

dcl zle		fixed bin (21);
dcl zsb		fixed bin (21);
dcl zse		fixed bin (21);
dcl concealsw	bit (1);
dcl delim		char (1);
dcl i		fixed bin (21);
dcl j		fixed bin (21);
dcl scan_leng	fixed bin (21);%page;
dcl adjust	bit (1);
dcl fill		fixed bin (21);
dcl firstime	bit (1);
dcl hole_ct	fixed bin (21);
dcl incr		fixed bin (21);
dcl left_set	bit (1);
dcl leftover	fixed bin (21);
dcl lineloc	fixed bin (21);
dcl lmarg		(2) fixed bin (21);
dcl marg		fixed bin (21);
dcl matchleng	fixed bin (21);
dcl matchloc	fixed bin (21);
dcl moveleng	fixed bin (21);
dcl pb		fixed bin (21);
dcl putted	fixed bin (21);
dcl rmarg		fixed bin (21);
dcl templeng	fixed bin (21);
dcl temploc	fixed bin (21);
dcl wordleng	fixed bin (21);
dcl wordloc	fixed bin (21);
dcl virtleng	fixed bin (21);
dcl visleng	fixed bin (21);
dcl ch		char (1);
%include ted_support;

dcl (addr, bin, divide, index, mod, substr, unspec) builtin;

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






		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved