



		    format_word_list.pl1            02/08/77  0952.6rew 01/31/77  1638.5      114867



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

format_word_list: fwl: proc;

/* Written by Jerry Stern */
/* modified by J. Stern 9/10/75 to add "-cols" option */
/* modified by J. Stern 12/3/76 to handle namedups */
/* modified by J. Stern 7/30/76 to fix bug (MCR 2088) */


dcl (seg_output, replace, got_pname) bit (1) aligned init ("0"b);
dcl (j, fi, ti) fixed bin (21);
dcl (ap, p, tp, np, xp) ptr init (null);
dcl (i, al) fixed bin;
dcl (wordlen, out_wordlen, printlen) fixed bin;
dcl  elen fixed bin;
dcl (cols, rows) fixed bin;
dcl  max_cols fixed bin;
dcl  last_col_rows fixed bin;
dcl (col_flags, next_col_flags) bit (72) aligned;
dcl  backspace char (1) aligned int static init ("");
dcl  arg char (al) based (ap);
dcl  code fixed bin (35);
dcl  dname char (168);
dcl (ename, oldname) char (32);
dcl  cleanup condition;
dcl  bc fixed bin (24);
dcl (c, r) fixed bin;
dcl  cs char (seglen) based;
dcl  seglen fixed bin (21);
dcl 1 page_array (6, 56),
    2 first fixed bin (21),
    2 len fixed bin unal,
    2 plen fixed bin unal;
dcl  page char (8000) varying;
dcl  nl char (1) aligned int static init ("
");
dcl  nl5 char (5) aligned int static init ("




");
dcl  nlff char (2) int static init ("
");
dcl (addr, index, substr, divide, length, null, addrel, search) builtin;
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin) returns (fixed bin (35));
dcl  com_err_ ext entry options (variable);
dcl  hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  expand_pathname_ ext entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  get_wdir_ ext entry returns (char (168));
dcl  hcs_$chname_seg ext entry (ptr, char (*), char (*), fixed bin (35));
dcl  hcs_$terminate_noname ext entry (ptr, fixed bin (35));
dcl  hcs_$delentry_seg ext entry (ptr, fixed bin (35));
dcl  hcs_$truncate_seg ext entry (ptr, fixed bin (21), fixed bin (35));
dcl  hcs_$set_bc_seg ext entry (ptr, fixed bin (24), fixed bin (35));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  nd_handler_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  error_table_$segnamedup ext fixed bin (35);
dcl  error_table_$namedup ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$entlong ext fixed bin (35);
dcl  error_table_$zero_length_seg ext fixed bin (35);
dcl  error_table_$inconsistent ext fixed bin (35);
dcl  iox_$user_output ext ptr;



	cols = 0;
	do i = 1 by 1 while (cu_$arg_ptr (i, ap, al) = 0); /* Examine args */
	     if substr (arg, 1, 1) ^= "-" then do;	/* not an option, must be pathname */
		if got_pname then go to badarg;	/* already have pathname => error */
		call expand_pathname_ (arg, dname, ename, code);
		if code ^= 0 then do;
		     call com_err_ (code, "format_word_list", arg);
		     return;
		end;
		got_pname = "1"b;
	     end;
	     else if arg = "-sm" then seg_output = "1"b;	/* "segment" output option */
	     else if arg = "-segment" then seg_output = "1"b;
	     else if arg = "-rp" then replace = "1"b;	/* "replace" option */
	     else if arg = "-replace" then replace = "1"b;
	     else if arg = "-cols" then do;
col_opt:		i = i + 1;			/* next arg is number of cols */
		code = cu_$arg_ptr (i, ap, al);
		if code ^= 0 then do;
		     call com_err_ (code, "format_word_list", "Attempting to get number of columns.");
		     return;
		end;
		cols = cv_dec_check_ (arg, code);	/* convert arg to fixed bin */
		if code ^= 0 then do;
		     call com_err_ (0, "format_word_list", "Non-numeric column specification.  ^a", arg);
		     return;
		end;
		if cols < 1 | cols > 6 then do;
		     call com_err_ (0, "format_word_list", "Number of columns is not between 1 and 6.");
		     return;
		end;
	     end;
	     else if arg = "-columns" then go to col_opt;
	     else do;
badarg:		call com_err_ (0, "format_word_list", "Unrecognized argument: ^a", arg);
		return;
	     end;
	end;
	if ^got_pname then do;			/* no pathname given */
	     code = error_table_$noarg;
gripe:	     call com_err_ (code, "format_word_list");
	     return;
	end;
	if seg_output & replace then do;		/* cannot have both options */
	     code = error_table_$inconsistent;
	     go to gripe;
	end;
	if replace then seg_output = "1"b;		/* let seg_output indicate either option */

	if seg_output then
	     if cols = 0 then cols = 6;		/* set default cols for seg output */
	     else;
	else do;					/* not seg output, check line length */
	     i = get_line_length_$switch (iox_$user_output, code);
	     if code ^= 0 then max_cols = 3;
	     else do;
		max_cols = divide (max (i-32, 0), 20, 17, 0) + 1;
		if max_cols > 6 then max_cols = 6;
		if cols > max_cols then do;
		     call com_err_ (0, "format_word_list", "Line length too small for specified number of columns.");
		     return;
		end;
	     end;
	     if cols = 0 then cols = max_cols;		/* set default for user_output */
	end;

	elen = index (ename, " ");			/* get entry name length */
	if elen = 0 then elen = 33;
	if substr (ename, elen - 3, 3) = ".wl" then elen = elen - 3; /* if suffix already there, shorten name length */
	if elen > 29 then do;			/* not enough room to add "fwl" suffix */
	     call com_err_ (error_table_$entlong, "format_word_list", "^a.fwl", ename);
	     return;
	end;
	substr (ename, elen, 3) = ".wl";		/* add the suffix */

	on cleanup call cleaner;

	call hcs_$initiate_count (dname, ename, "", bc, 0, p, code); /* Get ptr and length for word list seg */
	if p = null then go to err_exit;
	seglen = divide (bc, 9, 24, 0);		/* get character count */
	if seglen = 0 then do;
	     code = error_table_$zero_length_seg;
	     go to err_exit;
	end;

	if seg_output then do;			/* If segment output, make temp seg */
	     call hcs_$make_seg ("", "fwl_temp_", "", 01011b, tp, code);
	     if tp = null then do;
		ename = "fwl_temp_";
		dname = "(process directory)";
		go to err_exit;
	     end;
	     ti = 1;				/* init temp seg offset */

	     oldname = ename;			/* remember input seg name */
	     substr (ename, elen, 4) = ".fwl";		/* construct output seg name */

	     if ^replace then do;			/* create output seg */
		dname = get_wdir_ ();		/* in working dir */
		call hcs_$make_seg (dname, ename, "", 01011b, np, code);
		if np = null then go to err_exit;
	     end;
	end;


	rows, last_col_rows = 56;			/* use 56 rows per page */
	j = 1;					/* init word ptr */

/* Each pass thru the following loop produces one page of output */

	do while (j < seglen);			/* scan until word list is exhausted */

/* We now proceed to fill in the page array which has one entry
   for each word on the page.  The array is traversed in column major
   order while the input word list is scanned from beginning to end. */

	     next_col_flags = ""b;			/* init flags for first column */
	     do c = 1 to cols;			/* loop thru cols */
		col_flags = next_col_flags;		/* save flags for this column */
		next_col_flags = ""b;		/* init flags for next column */
		do r = 1 to rows;			/* loop thru rows */
		     if substr (col_flags, r, 1) then first (c, r) = 0; /* skip if flag set for this row */
		     else do;
			wordlen = index (substr (p -> cs, j + 1), nl); /* find end of next word */
			if wordlen = 0 then wordlen = seglen + 1 - j; /* if newline missing, assume one */
			i = index (substr (p -> cs, j, wordlen), backspace); /* test word for backspaces */
			if i ^= 0 then do;		/* if word contains backspaces, figure out "print length" */
			     printlen = i -2;	/* start at first backspace */
			     do i = i + 1 to wordlen - 1 while (printlen < 32); /* scan until max of 31 exceeded */
				if substr (p -> cs, j+i, 1) = backspace then /* this char is a backspace */
				     printlen = printlen - 1; /* decrement printlen */
				else printlen = printlen +1; /* increment printlen */
			     end;
			     if printlen = 32 then out_wordlen = i - 1; /* if printlen > 31, cut output by 1 */
			     else out_wordlen = i;	/* otherwise output full word */
			end;
			else if wordlen > 31 then do; /* no backspaces, so printlen = wordlen */
			     out_wordlen = 31;	/* if oversize word, cut output length to 31 */
			     printlen = 32;		/* set printlen to max */
			end;
			else out_wordlen, printlen = wordlen; /* wordlen small enough, so print whole word */
			if printlen > 19 then	/* space needed from next column ? */
			     if c ^= cols then substr (next_col_flags, r, 1) = "1"b; /* if not last col, set flag */

			first (c, r) = j;		/* save offset of first char in word */
			len (c, r) = out_wordlen;	/* save word length */
			plen (c, r) = printlen;	/* save print length */
			j = j + wordlen + 1;	/* increment word ptr */
			if j >= seglen then do;	/* end of word list? */
			     cols = c;		/* last page has c columns */
			     last_col_rows = r;	/* last column has r rows */
			     if cols = 1 then rows = last_col_rows; /* if only one col, last page has r rows */
			     go to init_page;
			end;
		     end;
		end;
	     end;

/* Now it's time to produce the actual text of the page.  The
   page array is traversed in row major order, thereby building the
   page a row, i.e. a line, at a time. */

init_page:     page = "";				/* null out page */
	     if seg_output then page = page || substr (nl5, 1, 2); /* if seg output, begin with 2 newlines */
	     else page = page || nl5;			/* If terminal output, begin with 5 new-lines */

	     do r = 1 to rows;			/* loop thru rows */
		do c = 1 to cols;			/* loop thru cols */
		     if c = cols then		/* if last column */
			if r > last_col_rows then go to end_of_row; /* anymore rows in last col? */
		     fi = first (c, r);		/* get word offset */
		     if fi ^= 0 then do;		/* if not zero due to large word in preceding column */
			wordlen = len (c, r);	/* get word length */
			printlen = plen (c, r);	/* get print length */
			page = page || substr (p -> cs, fi, wordlen); /* add word to page */
			if printlen = 32 then page = page || "?"; /* if oversize word, append "?" */
			if c < cols then do;	/* if not last column */
			     if printlen < 10 then go to two_tabs; /* add tabs to pad out column */
			     if printlen < 20 then go to one_tab;
			     if printlen < 30 then
two_tabs:			     page = page || "		"; else
one_tab:			     page = page || "	";
			end;
		     end;
		end;
end_of_row:	page = page || nl;			/* add newline at end of row */
	     end;

	     if ^seg_output then do;			/* Write page on the terminal */
		page = page || nl5;
		call iox_$put_chars (iox_$user_output, addrel (addr (page), 1), length (page), code);
	     end;
	     else do;				/* copy page into temp seg */
		page = page || nlff;
		substr (tp -> cs, ti, length (page)) = page;
		ti = ti + length (page);		/* increment temp seg offset */
	     end;
	end;

	if seg_output then do;			/* copy temp seg into permanent seg */
	     if replace then do;			/* if replace, rename input seg */
chname:		call hcs_$chname_seg (p, oldname, ename, code);
		if code ^= 0 then
		     if code ^= error_table_$segnamedup then
			if code = error_table_$namedup then do;
			     call nd_handler_ ("format_word_list", dname, ename, code);
			     if code ^= 0 then go to finish; /* user decided to abort or error in nd_handler_ */
			     go to chname;		/* conflicting name was removed, try again */
			end;
			else do;
			     ename = oldname;
			     go to err_exit;
			end;
		xp = p;
	     end;
	     else xp = np;
	     seglen = ti -1;
	     xp -> cs = tp -> cs;			/* copy seg */
	     call hcs_$truncate_seg (xp, divide (seglen+3, 4, 21, 0), code); /*  truncate to new length */
	     if code ^= 0 then go to err_exit;
	     call hcs_$set_bc_seg (xp, 9*seglen, code);	/* set bitcount */
	     if code ^= 0 then go to err_exit;
	end;

finish:	call cleaner;

cleaner:	proc;					/* cleanup handler */
	     if tp ^= null then call hcs_$delentry_seg (tp, code); /* delete temp seg */
	     do p = p, np;
		if p ^= null then call hcs_$terminate_noname (p, code); /* terminate input & output segs */
	     end;
	end cleaner;

	return;

err_exit:	call com_err_ (code, "format_word_list", "^a>^a", dname, ename);
	go to finish;

     end format_word_list;




		    sort_lines.pl1                  10/24/74  1554.7rew 10/24/74  1411.7       93276



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

sort_lines: sl: procedure;

/* Written by Jerry Stern */

dcl (segp, tp1, tp2, insegp, outp) ptr init (null),
    (i, j, seglen) fixed bin (24),
     bc fixed bin (24),
     ap ptr,
    (al, nargs, argno) fixed bin,
     arg char (al) based (ap),
     code fixed bin (35),
    (lines, olines, fi, li, fj, lj) fixed bin (24),
    (max_chars, max_lines) fixed bin (24),
    (brief, unique, ao, got_pname) bit (1) aligned,
     ename char (32),
     dirname char (168),
     whoami char (11) varying,
     cleanup condition,
     lc char (26) aligned int static init ("abcdefghijklmnopqrstuvwxyz"),
     uc char (26) aligned int static init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
     nl char (1) aligned int static init ("
");

dcl 1 c based aligned,
    2 a (seglen) char (1) unaligned;

dcl  seg char (seglen) based aligned;

dcl 1 A (131072) aligned based (Ap),
    2 p ptr unal,
    2 l fixed bin (24);

dcl  Ap ptr init (null);
dcl  sys_info$max_seg_size ext fixed bin (24);
dcl  subroutine_sw bit (1) aligned;
dcl  ch_string char (string_len) based;
dcl  string_len fixed bin (24);
dcl (pi, pj) ptr;

dcl  expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     error_table_$noarg ext fixed bin (35),
     error_table_$bigarg ext fixed bin (35),
     error_table_$fatal_error ext fixed bin (35),
     hcs_$delentry_seg ext entry (ptr, fixed bin (35)),
     hcs_$terminate_noname ext entry (ptr, fixed bin (35)),
     hcs_$truncate_seg ext entry (ptr, fixed bin, fixed bin (35)),
     hcs_$set_bc_seg ext entry (ptr, fixed bin (24), fixed bin (35)),
     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin) returns (fixed bin (35)),
     com_err_ ext entry options (variable),
     ioa_ ext entry options (variable),
     hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
     hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
     sort_strings_ ext entry (ptr, fixed bin (24));

dcl (addr, divide, null, substr, translate, index) builtin;


	whoami = "sort_lines";			/* remember entry point name */
	brief, unique, ao, got_pname, subroutine_sw = "0"b; /* init command options, etc. */

	do argno = 1 by 1 while (cu_$arg_ptr (argno, ap, al) = 0); /* scan arguments */
	     if substr (arg, 1, 1) ^= "-" then do;	/* not an option, must be pathname */
		if got_pname then go to badarg;	/* already have pathname, user goofed */
		call expand_path_ (ap, al, addr (dirname), addr (ename), code);
		if code ^= 0 then do;
		     call com_err_ (code, whoami, arg);
		     return;
		end;
		got_pname = "1"b;
	     end;
	     else if arg = "-uq" then unique = "1"b;	/* unique option requested */
	     else if arg = "-unique" then unique = "1"b;	/* " */
	     else if arg = "-bf" then brief = "1"b;	/* brief option requested */
	     else if arg = "-brief" then brief = "1"b;	/* " */
	     else if arg = "-ao" then ao = "1"b;	/* alphabetical order option requested */
	     else if arg = "-alphabet_order" then ao = "1"b; /* " */
	     else do;				/* I give up, what is it? */
badarg:		call com_err_ (0, whoami, "Unrecognized argument: ^a", arg);
		return;
	     end;
	end;

	if ^got_pname then do;			/* no pathname given */
	     call com_err_ (error_table_$noarg, whoami);
	     return;
	end;

	go to common;


sort_lines_: entry (a_insegp, a_seglen, a_lines, a_outp, a_unique, a_ao, a_code);

dcl (a_insegp, a_outp) ptr;
dcl (a_seglen, a_lines) fixed bin (24);
dcl (a_unique, a_ao) bit (1) aligned;
dcl  a_code fixed bin (35);

	whoami = "sort_lines_";			/* remember entry point name */
	subroutine_sw, brief = "1"b;			/* set subroutine switch, brief option implicit */
	insegp = a_insegp;				/* get input seg ptr */
	seglen = a_seglen;				/* get input seg length in chars */
	outp = a_outp;				/* get output seg ptr */
	unique = a_unique;				/* get unique switch */
	ao = a_ao;				/* get alphabetical order switch */
	a_code = 0;				/* set error code */


common:	on cleanup call cleaner;

	if ^subroutine_sw then do;
	     call hcs_$initiate_count (dirname, ename, "", bc, 0, insegp, code); /* initiate input segment */
	     if insegp = null then go to err_exit;	/* check for error */
	     outp = insegp;
	     seglen = divide (bc, 9, 18, 0);		/* get segment length in characters */
	end;

	max_chars = 4 * sys_info$max_seg_size;

	call make_temp_seg ("sl_temp0_", Ap);		/* make temp to hold array of line ptrs and lengths */
	call make_temp_seg ("sl_temp1_", tp1);		/* make temp to copy lines into */
	if ao then				/* if alphabetical sorting requested */
	     if seglen > divide (max_chars, 2, 24, 0) then /* if more than half a segment of input */
		call make_temp_seg ("sl_temp2_", tp2);	/* make another temp to copy lines into */


make_temp_seg: proc (tname, tp);			/* procedure to create a temp seg in the process directory */

dcl  tname char (32);				/* name of temp seg */
dcl  tp ptr;					/* ptr to temp seg */

	     call hcs_$make_seg ("", tname, "", 01011b, tp, code);
	     if tp = null then
		if subroutine_sw then do;		/* return error code */
		     a_code = error_table_$fatal_error;
		     go to finish;
		end;
		else do;				/* set up for com_err_ call */
		     ename = tname;
		     dirname = "(process directory)";
		     go to err_exit;
		end;

	end make_temp_seg;


/* The following loop parses the input segment into lines,
   copies each line to a temp seg, and stores a pointer to and
   the length of each line in an array.  However, if alphabetical
   sorting is requested, then each line is doubled in length,
   the second half being the original line, and the first half
   being the line with upper case letters translated to lower case.
   This causes ordinary ASCII sorting to result in alphabetical
   sorting.  Two temp segs are sometimes needed to hold a
   "doubled" copy of the input seg. */

	segp = tp1;				/* set temp ptr to first temp seg */
	fi, fj = 1;				/* init input and temp seg offsets */
	max_lines = divide (max_chars, 8, 24, 0);	/* need 2 words per line in the array segment */
	do lines = 1 to max_lines while (fi < seglen);	/* scan input until exhausted */
	     p (lines) = addr (segp -> c.a (fj));	/* save  line ptr */
	     li = index (substr (insegp -> seg, fi), nl); /* get line length */
	     if li = 0 then li = seglen + 1 - fi;	/* if final newline missing, rest of input is last line */
	     if ao then do;				/* if alphabetical sorting */
		lj = 2 * li;			/* double line length */
		if fj + lj > max_chars then do;	/* will this line fit in the temp seg ? */
		     segp = tp2;			/* begin using second temp seg */
		     p(lines) = tp2;		/* save new line ptr */
		     fj = 1;			/* reinitialize temp seg offset */
		end;
		substr (segp -> seg, fj, li) = translate (substr (insegp -> seg, fi, li), lc, uc);
		fj = fj + li;			/* after moving translated line, increment temp seg offset */
	     end;
	     else lj = li;				/* line length unchanged */
	     l (lines) = lj;			/* save line length */
	     substr (segp -> seg, fj, li) = substr (insegp -> seg, fi, li); /* copy line to temp seg */
	     fj = fj + li;				/* increment temp seg offset */
	     fi = fi + li;				/* increment input seg offset */
	end;

	if lines > max_lines then do;			/* we ran out of room in the array */
	     if subroutine_sw then a_code = error_table_$bigarg; /* punt */
	     else call com_err_ (0, whoami, "Number of lines exceeds limit");
	     go to finish;
	end;
	lines = lines -1;


	call sort_strings_ (Ap, lines);		/* sort it */


/* Now copy lines to output seg  (which could be the input seg) */

	j = 1;					/* init output seg offset */
	olines, lj = 0;				/* init output line count, previous line length */
	do i = 1 to lines;				/* loop thru lines */
	     pi = p (i);				/* get ptr to current line */
	     string_len = l (i);			/* get length of current line */
	     if ao then do;				/* line length was doubled for alphabetical sorting */
		li = divide (string_len, 2, 24, 0);	/* halve line length */
		fi = li + 1;			/* get index of second half of line */
	     end;
	     else do;
		li = string_len;			/* line length unchanged */
		fi = 1;				/* line position unchanged, i.e. index is 1 */
	     end;
	     if unique then				/* don't copy this line if it's a duplicate */
		if li = lj then			/* current line length = previous line length ? */
		     if substr (pi -> ch_string, fi, li) = substr (pj -> ch_string, fi, li) then /* lines match ? */
			go to skip;		/* skip duplicate line */
	     substr (outp -> seg, j, li) = substr (pi -> ch_string, fi, li); /* copy line */
	     pj = pi;				/* save line ptr */
	     lj = li;				/* save line length */
	     j = j + li;				/* increment output seg offset */
	     olines = olines + 1;			/* increment output line count */
skip:	end;
	seglen = j-1;

	if subroutine_sw then do;
	     a_seglen = seglen;			/* return output seg length */
	     a_lines = olines;			/* return number of output lines */
	end;

	else do;					/* for sort_lines command, take care of input/output seg */
	     if bc ^= 9*seglen then do;		/* if seg length changed */
		call hcs_$truncate_seg (outp, divide (seglen+3, 4, 21, 0), code); /* truncate to new length */
		if code ^= 0 then go to err_exit;
		call hcs_$set_bc_seg (outp, 9* seglen, code); /* set bitcount */
		if code ^= 0 then go to err_exit;
	     end;
	     if ^brief then call ioa_ ("number of lines = ^d", olines); /* print number of lines */
	end;

finish:	call cleaner;

cleaner:	proc;					/* cleanup handler */
	     do segp = Ap, tp1, tp2;
		if segp ^= null then call hcs_$delentry_seg (segp, code); /* delete temp segs */
	     end;
	     if ^subroutine_sw then
		if insegp ^= null then call hcs_$terminate_noname (insegp, code); /* terminate original segment */
	end cleaner;

	return;

err_exit:	call com_err_ (code, whoami, "^a>^a", dirname, ename);
	if subroutine_sw then a_code = code;
	go to finish;


     end sort_lines;




		    sort_strings_.pl1               10/24/74  1554.8rew 10/24/74  1411.7       31059



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

sort_strings_: proc (sptr, scount);

/*
   Algorithm 347
   AN EFFICIENT ALGORITHM FOR SORTING WITH MINIMAL STORAGE
   Richard C. Singleton
   CACM 12, Number 3, March 1969, pp. 185-7

   Converted to Multics PL/I by Paul A. Green - April 6, 1974

   Modified to sort adjustable character strings instead of fixed binary numbers
   by Jerry Stern - May 30, 1974
*/

dcl  sptr ptr;					/* pointer to array of string pointers and lengths */
dcl  scount fixed bin (24);				/* number of strings */

dcl 1 A (scount) aligned based (Ap) like t;		/* array of string pointers and lengths */
dcl  Ap ptr;					/* pointer to A */

dcl 1 t aligned,					/* temporary to hold one entry from A */
    2 p ptr unal,					/* pointer to string */
    2 l fixed bin (24);				/* length of string */

dcl 1 swap_temp aligned like t;

dcl  cstring char (262144) based;			/* template to reference a string described in A or t */

dcl (first, last, median, low, high) fixed bin (24);

dcl  depth fixed bin;

dcl 1 stack (0:20) aligned,
    2 first fixed bin (24),
    2 last fixed bin (24);

dcl (divide, substr) builtin;


	Ap = sptr;
	depth = 0;
	first = 1;
	last = scount;
	go to L4;


L1:	median = divide (first + last, 2, 24, 0);
	t = A (median);
	low = first;
	high = last;

	if substr (A (first).p -> cstring, 1, A (first).l) > substr (A (median).p -> cstring, 1, A (median).l)
	     then do;
	     A (median) = A (first);
	     A (first) = t;
	     t = A (median);
	end;

	if substr (A (last).p -> cstring, 1, A (last).l) < substr (A (median).p -> cstring, 1, A (median).l)
	     then do;
	     A (median) = A (last);
	     A (last) = t;
	     t = A (median);

	     if substr (A (first).p -> cstring, 1, A (first).l) > substr (A (median).p -> cstring, 1, A (median).l)
		then do;
		A (median) = A (first);
		A (first) = t;
		t = A (median);
	     end;

	end;

L2:	do high = high -1 by -1
		while (substr (A (high).p -> cstring, 1, A (high).l) > substr (t.p -> cstring, 1, t.l));
	end;

	do low = low +1 by 1
		while (substr (A (low).p -> cstring, 1, A (low).l) < substr (t.p -> cstring, 1, t.l));
	end;

	if low <= high then do;
	     swap_temp = A (high);
	     A (high) = A (low);
	     A (low) = swap_temp;
	     go to L2;
	end;

	if (high - first) > (last - low) then do;
	     stack.first (depth) = first;
	     stack.last (depth) = high;
	     first = low;
	end;

	else do;
	     stack.first (depth) = low;
	     stack.last (depth) = last;
	     last = high;
	end;

	depth = depth +1;

L4:	if (last - first) > 10 then go to L1;

	if first = 1 then
	     if first < last then go to L1;

	do first = first +1 to last;
	     t = A (first);
	     do low = first -1 by -1
		     while (substr (A (low).p -> cstring, 1, A (low).l) > substr (t.p -> cstring, 1, t.l));
		A (low +1) = A (low);
	     end;
	     A (low +1) = t;
	end;


	depth = depth -1;
	if depth >= 0 then do;
	     first = stack.first (depth);
	     last = stack.last (depth);
	     go to L4;
	end;
	return;

     end sort_strings_;




		    update_dict.pl1                 10/24/74  1554.8rew 10/24/74  1411.7      112716



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

update_dict: ud: proc;

/* Written by Jerry Stern */

dcl  vartemp char (64) varying;
dcl  suffix char (8) varying;
dcl  whoami char (16) varying;
dcl  cleanup condition;
dcl  temp_seg_name char (9);
dcl  tp ptr init (null);
dcl  code fixed bin (35);
dcl  bc fixed bin (24);
dcl  ti fixed bin (21);
dcl (argno, al) fixed bin;
dcl  ap ptr;
dcl  arg char (al) based (ap);
dcl  elen fixed bin;
dcl  verify_sw bit (1) aligned;
dcl (upd_sw, need_2_words, phase1) bit (1) aligned;
dcl (got_wl, got_dict) bit (1) aligned init ("0"b);
dcl  text char (9999) aligned based;

dcl 1 x aligned based (switchp),
    2 segp ptr init (null),
    2 seglen fixed bin (21),
    2 i fixed bin (21),
    2 len fixed bin,
    2 count fixed bin,
    2 word char (96),
    2 trword char (96),
    2 ename char (32) unal,
    2 dname char (168) unal;

dcl  switchp ptr;
dcl 1 wl aligned like x;
dcl 1 dict aligned like x;
dcl  xtext char (x.seglen) aligned based (x.segp);
dcl  upper_case char (26) aligned init static init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  lower_case char (26) aligned int static init ("abcdefghijklmnopqrstuvwxyz");
dcl  nl char (1) aligned int static init ("
");

dcl (addr, translate, divide, index, substr, null, verify) builtin;
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin) returns (fixed bin (35));
dcl  expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  com_err_ ext entry options (variable);
dcl  ioa_ ext entry options (variable);
dcl  hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$truncate_seg ext entry (ptr, fixed bin (21), fixed bin (35));
dcl  hcs_$set_bc_seg ext entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$delentry_seg ext entry (ptr, fixed bin (35));
dcl  hcs_$terminate_noname ext entry (ptr, fixed bin (35));
dcl (error_table_$entlong,
     error_table_$noentry,
     error_table_$zero_length_seg,
     error_table_$noarg) ext fixed bin (35);

	upd_sw, verify_sw = "1"b;			/* set switches for update_dict */
	whoami = "update_dict";			/* remember entry point name */
	temp_seg_name = "upd_temp_";			/* set temp seg name for update_dict */
	go to join;

reduce_word_list: rwl: entry;

	upd_sw, verify_sw = "0"b;			/* set switches for reduce_word_list */
	whoami = "reduce_word_list";			/* remember entry point name */
	temp_seg_name = "rwl_temp_";			/* set temp seg name for reduce_word_list */


join:	do argno = 1 by 1 while (cu_$arg_ptr (argno, ap, al) = 0); /* scan arguments */
	     if substr (arg, 1, 1) ^= "-" then		/* not an option */
		if ^got_wl then do;			/* this should be word list pathname */
		     switchp = addr (wl);
		     got_wl = "1"b;
expand:		     call expand_path_ (ap, al, addr (x.dname), addr (x.ename), code);
		     if code ^= 0 then do;
			call com_err_ (code, whoami, arg);
			return;
		     end;
		end;
		else if ^got_dict then do;		/* this should be dictionary pathname */
		     switchp = addr (dict);
		     got_dict = "1"b;
		     go to expand;
		end;
		else go to badarg;			/* have both pathnames, user in error */
	     else if ^upd_sw then go to badarg;		/* no options for reduce_word_list */
	     else if arg = "-nv" then verify_sw = "0"b;	/* no verification requested */
	     else if arg = "-no_verify" then verify_sw = "0"b;
	     else do;				/* bad option */
badarg:		call com_err_ (0, whoami, "Unrecognized argument: ^a", arg);
		return;
	     end;
	end;

	if ^got_wl then do;				/* word_list pathname missing */
noarg:	     call com_err_ (error_table_$noarg, whoami);
	     return;
	end;
	if ^got_dict then go to noarg;		/* dictionary pathname missing */

	elen = index (wl.ename, " ");			/* get word list name length */
	if elen = 0 then elen = 33;
	if substr (wl.ename, elen-3, 3) ^= ".wl" then	/* suffix not supplied */
	     if elen > 30 then do;			/* no room to add suffix */
		switchp = addr (wl);
entlong:		if switchp = addr (wl) then		/* if error on word list name */
		     suffix = ".wl";		/* use word list suffix */
		else suffix = ".dict.wl";		/* otherwise use dictionary suffix */
		call com_err_ (error_table_$entlong, whoami, "^a^a", x.ename, suffix);
		return;
	     end;
	     else substr (wl.ename, elen, 3) = ".wl";	/* add suffix */

	elen = index (dict.ename, " ");		/* get dictionary name length */
	if elen = 0 then elen = 33;
	if substr (dict.ename, elen-8, 8) ^= ".dict.wl" then /* suffix not supplied */
	     if elen > 25 then do;			/* no room to add suffix */
		switchp = addr (dict);
		go to entlong;
	     end;
	     else substr (dict.ename, elen, 8) = ".dict.wl"; /* add suffix */

	on cleanup call cleaner;

	switchp = addr (wl);			/* set up for possible transfer to err_exit */
	call hcs_$initiate_count (wl.dname, wl.ename, "", bc, 0, wl.segp, code); /* initiate the word list */
	if wl.segp = null then go to err_exit;
	wl.seglen = divide (bc, 9, 24, 0);		/* get char count */
	if wl.seglen = 0 then do;			/* word list empty */
	     code = error_table_$zero_length_seg;
	     go to err_exit;
	end;

	switchp = addr (dict);			/* set up for err_exit */
	call hcs_$initiate_count (dict.dname, dict.ename, "", bc, 0, dict.segp, code); /* initiate the dictionary */
	if dict.segp = null then
	     if ^upd_sw then go to err_exit;		/* must have dictionary for reduce_word_list */
	     else if code = error_table_$noentry then do; /* dictionary does not exist */
		call hcs_$make_seg (dict.dname, dict.ename, "", 01011b, dict.segp, code); /* create it */
		if code ^= 0 then go to err_exit;
		call com_err_ (0, whoami, "^a created", dict.ename);
		dict.seglen = 0;			/* init char count */
	     end;
	     else go to err_exit;
	else dict.seglen = divide (bc, 9, 24, 0);	/* get char count */

	call hcs_$make_seg ("", temp_seg_name, "", 01011b, tp, code); /* make temp output seg */
	if tp = null then do;
	     dict.ename = temp_seg_name;
	     dict.dname = "(process directory)";
	     go to finish;
	end;

	ti, wl.i, dict.i = 1;			/* init offsets for temp seg, word list, & dictionary */
	wl.count, dict.count = 0;			/* init word counts */
	need_2_words, phase1 = "1"b;			/* 2 words needed, begin phase 1 */
	switchp = addr (wl);
	call get_word;				/* get first word from word list */
	need_2_words = "0"b;			/* only 1 word needed now */
	switchp = addr (dict);
	call get_word;				/* get first word from dictionary */

get_word:	proc;					/* gets the next word from the word list or the dictionary */

repeat:	     if x.i > x.seglen then do;		/* no words left */
		if ^phase1 then go to report;		/* finished phase 2, wrap it up */
		if ^upd_sw then if switchp = addr (wl) then go to report; /* word_list exhausted, reduce_word_list done */
		go to leftovers;			/* one input seg exhausted, get leftovers */
	     end;

	     x.len = index (substr (xtext, x.i), nl);	/* get length of next word */
	     if x.len = 0 then do;			/* final newline missing, not a word list */
		vartemp = "^a does not end with a newline";
barf:		call com_err_ (0, whoami, vartemp, x.ename); /* gripe */
		go to finish;
	     end;
	     if x.len > 96 then do;			/* word length > 96, not a word list */
		vartemp = "^a contains a word exceeding 95 characters";
		go to barf;
	     end;
	     substr (x.word, 1, x.len) = substr (xtext, x.i, x.len); /* extract the word */
	     x.i = x.i + x.len;			/* increment seg offset */
	     if verify_sw then			/* verify lower-case only for update_dict */
		if switchp = addr (wl) then		/* verify the word_list, not the dictionary */
		     if verify (substr (x.word, 1, x.len-1), lower_case) ^= 0 then /* if not lower_case */
			go to repeat;		/* try the next word */
	     if phase1 then				/* still comparing, need lower case translation of word */
		substr (x.trword, 1, x.len) = translate (substr (x.word, 1, x.len), lower_case, upper_case);
	     return;

	end get_word;


put_word:	proc;					/* puts a word in the temp output seg */
	     substr (tp -> text, ti, x.len) = substr (x.word, 1, x.len); /* copy word */
	     ti = ti + x.len;			/* increment temp seg offset */
	     x.count = x.count + 1;			/* increment word count */
	end put_word;


/* The following loop implements "phase 1" of the algorithm.
   The current word list word is compared to the current dictionary
   word.  If appropriate, one of the words is added to the
   output.  Note that dictionaries are stored in alphabetical order
   rather than ASCII order.  Hence, an alphabetical comparison
   is performed.  First, lower case translations of the words are
   compared to see if the spelling differs.  If not, then the
   actual words are compared for differences in capitalization.
   Note also that reduce_word_list special cases words with the
   first letter capitalized or all letters capitalized as might appear
   in a title, beginning of a sentence, etc. */

loop:	if substr (wl.trword, 1, wl.len) < substr (dict.trword, 1, dict.len) then go to LT; /* less than */
	if wl.len = dict.len then
	     if substr (wl.trword, 1, wl.len) = substr (dict.trword, 1, wl.len) then /* same spelling */
		if substr (wl.word, 1, wl.len) < substr (dict.word, 1, wl.len) then go to LT; /* less than due to caps */
		else if substr (wl.word, 1, wl.len) = substr (dict.word, 1, wl.len) then go to EQ; /* equal */
	go to GT;					/* not less than or equal, must be greater than */

LT:	switchp = addr (wl);
	if ^upd_sw then				/* if reduce_word_list */
	     if wl.len = dict.len then		/* if word lengths equal */
		if substr (wl.trword, 1, wl.len) = substr (dict.word, 1, wl.len) then do; /* if spelled the same */
		     if verify (substr (wl.word, 2, wl.len -2), lower_case) = 0 then go to skip; /* first letter a cap */
		     if verify (substr (wl.word, 1, wl.len -1), upper_case) = 0 then go to skip; /* all caps */
		end;
	call put_word;				/* output word list word */
skip:	call get_word;				/* get next word list word */
	go to loop;

EQ:	need_2_words = "1"b;			/* replace both words */
GT:	switchp = addr (dict);
	if upd_sw then call put_word;			/* if update_dict, output dictionary word */
	call get_word;				/* get next dictionary word */
	if need_2_words then do;			/* both words were the same */
	     need_2_words = "0"b;
	     switchp = addr (wl);
	     call get_word;				/* get next word list word */
	end;
	go to loop;


/* One of the input segs has been exhausted.  All we do
   now is output the remaining words of the other input seg. */

leftovers: phase1 = "0"b;				/* begin phase 2 */
	if switchp = addr (wl) then switchp = addr (dict); /* one input seg exhausted, use the other */
	else switchp = addr (wl);
	if need_2_words then			/* didn't get next word yet */
loop2:	     call get_word;				/* get next word */
	call put_word;				/* output word */
	go to loop2;


/* Either both input segs are now exhausted or just the word list
   has been exhausted for reduce_word_list.  There's nothing left
   to do but report the results and copy the output. */

report:	if upd_sw then
	call ioa_ ("number of updates = ^d^/number of dictionary words = ^d", wl.count, wl.count + dict.count);
	else call ioa_ ("reduced number of words = ^d", wl.count);
	ti = ti -1;
	if upd_sw then switchp = addr (dict);		/* if update_dict, replace dictionary */
	else switchp = addr (wl);			/* otherwise, replace word list */
	substr (x.segp -> text, 1, ti) = substr (tp -> text, 1, ti); /* copy the output */
	call hcs_$truncate_seg (x.segp, divide (ti+3, 4, 21, 0), code); /* truncate to new length */
	if code ^= 0 then go to err_exit;
	call hcs_$set_bc_seg (x.segp, 9*ti, code);	/* set bit count */
	if code ^= 0 then go to err_exit;

finish:	call cleaner;

cleaner:	proc;					/* cleanup handler */
	     if tp ^= null then call hcs_$delentry_seg (tp, code); /* delete temp seg */
	     do wl.segp = wl.segp, dict.segp;
		if wl.segp ^= null then call hcs_$terminate_noname (wl.segp, code); /* terminate input segs */
	     end;
	end cleaner;

	return;

err_exit:	call com_err_ (code, whoami, "^a>^a", x.dname, x.ename);
	go to finish;

     end update_dict;




		    word_list.pl1                   12/15/76  1559.3rew 12/15/76  1543.3      211698



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

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

word_list: wl: proc;

/* Based on an idea by John Gilson
   Written by Jerry Stern          */
/* modified 9/3/75 by J. Stern to make find_word print line numbers */
/* Modified 760413 by PG to make find_word take an arbitrary number of words */
/* Modified 760825 by PG to add -header, and sort words to be found */
/* modified 10/1/76 by J. Stern to add correct_words entry */
/* modified 10/8/76 by J. Stern to remove underlining */

dcl (ap, nmp, mpp, mlp, clp, cpp, system_area_ptr) ptr;
dcl  system_area area (65536) based (system_area_ptr);
dcl  al fixed bin;
dcl  arg char (al) based (ap);
dcl  match_word char (match_len (wordx)) based (match_ptr (wordx));
dcl  match_len (n_words) based (mlp) fixed bin;
dcl  match_ptr (n_words) based (mpp) ptr;
dcl  corr_word char (corr_len (wordx)) based (corr_ptr (wordx));
dcl  corr_len (n_words) based (clp) fixed bin;
dcl  corr_ptr (n_words) based (cpp) ptr;
dcl  num_matches (n_args) based (nmp) fixed bin;
dcl (argno, n_args, n_words, wordx) fixed bin;
dcl  nosort bit (1) aligned init ("0"b);
dcl (brief, long) bit (1) aligned init ("0"b);
dcl  header_sw bit (1) aligned init ("0"b);
dcl (wl_sw, fwd_sw, cow_sw) bit (1) aligned init ("0"b);
dcl  got_pname bit (1) aligned init ("0"b);
dcl  invalid_sw bit (1) aligned;
dcl  count_lines bit (1) aligned;
dcl  ul_sw bit (1) aligned;
dcl  whoami char (16) varying;
dcl  ename char (32);
dcl  dname char (168);
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  bc fixed bin (24);
dcl (input_ptr, temp_ptr, output_ptr) ptr init (null);
dcl (input_len, temp_len) fixed bin (24);
dcl  input_cs char (input_len) based (input_ptr);
dcl  temp_cs char (1048576) based (temp_ptr);
dcl  strip_ptr ptr;
dcl  strip_cs char (1048576) based (strip_ptr);
dcl (token_ix, token_len, strip_ix, strip_len, word_ix, word_len, out_word_len, ul_ix, ul_len) fixed bin (24);
dcl (i, j, n, nli, last, line, output_words) fixed bin (24);
dcl  ul_buf char (300);
dcl  ul_cs char (ul_len) based (addr (ul_buf));
dcl  delims char (5) aligned int static init (" 	
");						/* SPACE, HT, VT, FF, NL */
dcl (left_delim, right_delim) char (4) aligned;
dcl  delim_name (5) char (4) aligned int static init ("<SP>", "<HT>", "<VT>", "<FF>", "<NL>");
dcl  nl char (1) aligned int static init ("
");

dcl (error_table_$noarg,
     error_table_$wrong_no_of_args,
     error_table_$badopt,
     error_table_$bigarg,
     error_table_$zero_length_seg,
     error_table_$entlong) fixed bin (35) ext;

dcl (addr, divide, index, null, reverse, search, substr, sum, verify, length) builtin;
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  expand_pathname_ ext entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_system_free_area_ entry (ptr);
dcl  hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  com_err_ ext entry options (variable);
dcl  ioa_ ext entry options (variable);
dcl  get_wdir_ ext entry returns (char (168));
dcl  hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$truncate_seg ext entry (ptr, fixed bin (21), fixed bin (35));
dcl  hcs_$delentry_seg ext entry (ptr, fixed bin (35));
dcl  hcs_$set_bc_seg ext entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$terminate_noname ext entry (ptr, fixed bin (35));
dcl  sort_lines_ ext entry (ptr, fixed bin (24), fixed bin (24), ptr, bit (1) aligned, bit (1) aligned, fixed bin (35));

	wl_sw = "1"b;				/* remember we came in via the word_list entry */
	whoami = "word_list";
	system_area_ptr = null;
	nmp = null;				/* these arrays are not used in word_list */
	mpp = null;
	mlp = null;
	clp = null;
	cpp = null;
	call cu_$arg_count (n_args);			/* How many arguments? */
	if n_args < 1 then do;			/* need at least one */
word_list_usage:
	     code = error_table_$noarg;
word_list_usage_2:
	     call com_err_ (code, whoami, "^/Usage: word_list path -control_args-");
	     return;
	end;
	go to join;

find_word: fwd: entry;

	fwd_sw = "1"b;				/* remember we came in via the find_word entry */
	whoami = "find_word";
	call cu_$arg_count (n_args);			/* get number of arguments */
	if n_args < 2 then do;			/* need at least two */
find_word_usage:
	     call com_err_ (error_table_$noarg, whoami, "^/Usage: find_word path word1 word2 ... wordN -control_args-");
	     return;
	end;

	clp, cpp = null;
	n_words = n_args;				/* n_args is upper bound on number of match words */
	go to allocations;

correct_words: cow: entry;

	cow_sw = "1"b;				/* remember we came in via the correct_words entry */
	whoami = "correct_words";
	call cu_$arg_count (n_args);			/* get number of arguments */
	if n_args < 3 then do;
correct_words_usage:
	     call com_err_ (error_table_$noarg, whoami, "^/Usage:  correct_words path word1 correction1 ... wordN correctionN -control_args-");
	     return;
	end;
	n_words = divide (n_args, 2, 17, 0);		/* half n_args is upper bound on number of word/correction pairs */
allocations:
	call get_system_free_area_ (system_area_ptr);
	allocate match_len in (system_area);
	allocate match_ptr in (system_area);
	allocate num_matches in (system_area);
	num_matches (*) = 0;
	if ^cow_sw then go to join;
	allocate corr_len in (system_area);
	allocate corr_ptr in (system_area);

join:	n_words = 0;
	do argno = 1 by 1 to n_args;
	     call cu_$arg_ptr (argno, ap, al, code);
	     if substr (arg, 1, 1) ^= "-" then do;	/* not an option */
		if ^got_pname then do;		/* this should be a pathname */
		     call expand_pathname_ (arg, dname, ename, code);
		     if code ^= 0 then do;
			call com_err_ (code, whoami, arg);
			return;
		     end;
		     got_pname = "1"b;
		end;
		else if wl_sw then do;
		     code = error_table_$wrong_no_of_args;
		     go to word_list_usage_2;
		end;
		else do;				/* this should be a match word */
insert_word:	     do wordx = 1 to n_words while (match_word < arg); /* find place to insert arg. */
		     end;

		     do j = n_words to wordx by -1;	/* make room for insertion. */
			match_ptr (j + 1) = match_ptr (j);
			match_len (j + 1) = match_len (j);
			if cow_sw then do;
			     corr_ptr (j + 1) = corr_ptr (j);
			     corr_len (j + 1) = corr_len (j);
			end;
		     end;
		     match_ptr (wordx) = ap;		/* save ptr to current word */
		     match_len (wordx) = al;		/* save length of current word */
		     n_words = n_words + 1;
		     if cow_sw then do;
			argno = argno +1;
			if argno > n_args then go to correct_words_usage;
			call cu_$arg_ptr (argno, ap, al, code);
			corr_ptr (wordx) = ap;
			corr_len (wordx) = al;
		     end;
		end;
	     end;
	     else if arg = "-word" then do;
		argno = argno + 1;
		if argno > n_args then
		     if cow_sw then go to correct_words_usage;
		     else go to find_word_usage;
		call cu_$arg_ptr (argno, ap, al, code);
		go to insert_word;
	     end;
	     else if wl_sw & (arg = "-no_sort" | arg = "-ns") then nosort = "1"b;
	     else if arg = "-bf" | arg = "-brief" then brief = "1"b;
	     else if arg = "-he" | arg = "-header" then header_sw = "1"b;
	     else if cow_sw & (arg = "-lg" | arg = "-long") then long = "1"b;
	     else do;
		call com_err_ (error_table_$badopt, whoami, "^a", arg);
		return;
	     end;
	end;

	if ^got_pname				/* pathname missing */
	| (^wl_sw & n_words = 0)			/* match word(s) missing */
	then if wl_sw				/* word_list entry */
	     then go to word_list_usage;		/* complain about word_list */
	     else if cow_sw
	     then go to correct_words_usage;		/* complain about correct_words */
	     else go to find_word_usage;		/* complain about find_word */

	if ^wl_sw then do;				/* check validity of word arguments */
	     invalid_sw = "0"b;			/* assume all word arguments are valid */
	     do wordx = 1 to n_words;
		call validate_word (match_word);
		if cow_sw then call validate_word (corr_word);
	     end;
	     if invalid_sw then return;
	end;

	count_lines = fwd_sw | (cow_sw & long);		/* count lines for find_word or correct_words with long option */

	on cleanup call cleaner;

	call hcs_$initiate_count (dname, ename, "", bc, 0, input_ptr, code); /* initiate input seg */
	if input_ptr = null then go to err_exit;
	input_len = divide (bc, 9, 21, 0);		/* get character count */
	if input_len = 0 then do;
	     code = error_table_$zero_length_seg;
	     go to err_exit;
	end;

	if wl_sw then do;				/* if word_list entry */
	     i = 34 - verify (reverse (ename), " ");
	     if i > 30 then do;			/* make sure we can add ".wl" suffix to entry name */
		call com_err_ (error_table_$entlong, whoami, "^a.wl", ename);
		go to finish;
	     end;
	     substr (ename, i, 3) = ".wl";

	     dname = get_wdir_ ();
	     call hcs_$make_seg (dname, ename, "", 01010b, output_ptr, code); /* create output seg in working dir */
	     if output_ptr = null then go to err_exit;

	     if nosort then temp_ptr = output_ptr;	/* if nosort, use output seg directly */
	     else do;				/* otherwise, create a temp output seg */
make_temp_seg:	call hcs_$make_seg ("", "wl_temp_", "", 01010b, temp_ptr, code);
		if temp_ptr = null then do;
		     ename = "wl_temp_";
		     dname = "(process directory)";
		     go to err_exit;
		end;
	     end;
	end;
	else if cow_sw then go to make_temp_seg;

	if header_sw
	then call ioa_ ("^/^-^a>^a^/", dname, ename);

	strip_ptr = input_ptr;			/* strip words in input string */
	line = 1;					/* init line counter */
	output_words = 0;				/* init word counter */
	temp_len = 0;				/* init length of temp seg */
	token_ix = 0;				/* init token index */
	last = 0;					/* init index of last input seg char moved to temp seg */

	do while (token_ix < input_len);		/* scan until input exhausted */
	     n = verify (substr (input_cs, token_ix+1), delims); /* skip delimiters */
	     if n = 0 then go to end_of_data;

	     if count_lines then do;			/* count newlines skipped */
		i = token_ix;			/* index of last token delimiter */
		j = n;				/* number of delimiters */
		if token_ix = 0 then do;		/* start of input, no previous token delimiter */
		     i = i +1;
		     j = j -1;
		end;
		do while (j > 0);
		     nli = index (substr (input_cs, i, j), nl);
		     if nli ^= 0 then do;		/* found one */
			line = line + 1;
			i = i + nli;
			j = j -nli;
		     end;
		     else j = 0;
		end;
	     end;

	     token_ix = token_ix + n;			/* advance index past delimiters */
	     token_len = search (substr (input_cs, token_ix+1), delims); /* find end-of-token delimiter */
	     if token_len = 0 then			/* no delimiter */
		token_len = input_len + 1 - token_ix;	/* use end of input as delimiter */

	     strip_ix = token_ix;
	     strip_len = token_len;
	     call strip_punc;			/* strip surrounding punctuation from token */
	     call check_ul;				/* check for underlining */

	     if ul_sw then do;			/* the word was underlined */
		ul_ix = word_ix;
		ul_len = word_len;
		strip_ptr = addr (ul_buf);		/* prepare to strip words in ul_buf */
		i = 0;
		do while (i < ul_len);		/* rescan token to pick out words */
		     n = verify (substr (ul_cs, i+1), " "); /* skip spaces */
		     if n = 0 then go to end_of_ul;
		     i = i + n;			/* advance index past spaces */
		     n = index (substr (ul_cs, i+1), " "); /* find next space */
		     if n = 0 then			/* no more spaces */
			n = ul_len +1 -i;		/* use end of token as delimiter */
		     strip_ix = i;
		     strip_len = n;
		     call strip_punc;
		     word_len = divide (word_len, 3, 24, 0); /* compute de-underlined word length */
		     do j = 1 to word_len -1;		/* squeeze de-underlined word together */
			substr (ul_buf, word_ix + j, 1) = substr (ul_buf, word_ix + (j*3), 1);
		     end;
		     if wl_sw then call output_word;
		     else call test_word;
		     i = i + n;
		end;
end_of_ul:	strip_ptr = input_ptr;
	     end;

	     else					/* no underlining to worry about */
	     if wl_sw then call output_word;
	     else call test_word;

	     token_ix = token_ix + token_len;		/* advance index past current token */
	end;

end_of_data:
	if cow_sw then
	     if last < input_len then
		if last > 0 then do;

/* For correct_words, if there are any chars left after the last
   correction, move them to the temp seg.  Then copy the whole
   temp seg into the original input seg (which becomes the output seg). */

		     n = input_len - last;
		     substr (temp_cs, temp_len+1, n) = substr (input_cs, last+1, n);
		     temp_len = temp_len + n;
		     output_ptr = input_ptr;
		     input_ptr = null;
		     substr (output_ptr -> temp_cs, 1, temp_len) = substr (temp_cs, 1, temp_len);
		end;

	if wl_sw then do;				/* if word_list entry */
	     if ^brief then
		call ioa_ ("total number of words = ^d", output_words); /* print word count */
	     if ^nosort then do;			/* if nosort option not requested */
		call sort_lines_ (temp_ptr, temp_len, output_words, output_ptr, "1"b, "1"b, code);
						/* sort words and copy to output seg */
		if code ^= 0 then do;
		     if code = error_table_$bigarg then call com_err_ (0, whoami, "Total number of words exceeds sorting limit.");
		     else call com_err_ (code, whoami, "Unable to sort word list.");
		     go to finish;
		end;
		if ^brief then
		     call ioa_ ("number of unique words = ^d", output_words); /* print unique word count */
	     end;
	end;

	if wl_sw | (cow_sw & last > 0) then do;
	     call hcs_$truncate_seg (output_ptr, divide (temp_len+3, 4, 21, 0), code); /* truncate output seg to new length */
	     if code ^= 0 then go to err_exit;
	     call hcs_$set_bc_seg (output_ptr, 9*temp_len, code); /* set new bitcount */
	     if code ^= 0 then go to err_exit;
	end;

	if ^wl_sw
	then if sum (num_matches (*)) = 0
	     then call ioa_ ("No ^[corrections^;matches^].", cow_sw); /* if no corrections or matches, say so */
	     else do wordx = 1 to n_words;		/* see if any other words were missed */
		if num_matches (wordx) = 0
		then call ioa_ ("No ^[corrections^;matches^] for ""^a"".", cow_sw, match_word);
		else if cow_sw
		then if ^(brief | long)
		     then call ioa_ ("^d correction^[s^] for ""^a"".", num_matches (wordx), (num_matches (wordx) ^= 1), match_word);
	     end;

finish:	call cleaner;
	return;

err_exit:	call com_err_ (code, whoami, "^a>^a", dname, ename); /* moan */
	go to finish;


/*  */


validate_word: proc (word);

dcl  word char (*);

/* checks validity of words supplied as arguments to commands
   a word must not contain delimiters or surrounding punctuation and must not be underlined
*/

	     if search (word, delims) ^= 0		/* word contains delimiters */
	     then do;
bad_word:		call com_err_ (0, whoami, """^a"" is not a word.", word);
		invalid_sw = "1"b;			/* the word is invalid */
		return;
	     end;
	     strip_ptr = addr (word);
	     strip_ix = 1;
	     strip_len = length (word);
	     call strip_punc;			/* strip surrounding punctuation from argument word */
	     if word_ix > 1 | word_len < strip_len	/* some punctuation was removed */
	     then go to bad_word;
	     call check_ul;				/* check word for underlining */
	     if ul_sw then go to bad_word;

	end validate_word;





strip_punc: proc;

/* removes surrounding punctuation from a string
   the input string is given by substr(strip_cs, strip_ix, strip_len)
   the output string is given by substr(strip_cs, word_ix, word_len)
*/

dcl  n fixed bin (24);

	     n = verify (substr (strip_cs, strip_ix, strip_len), "([{""") -1; /* check for leading punctuation */
	     if n = -1 then go to no_strip;		/* if all punctuation, do not strip */
	     word_ix = strip_ix + n;
	     word_len = strip_len - n;
	     n = verify (reverse (substr (strip_cs, word_ix, word_len)), ")]}""!,.:;?")-1; /* check for trailing punctuation */
	     if n = -1 then do;			/* if all punctuation, do not strip */
no_strip:		word_ix = strip_ix;
		word_len = strip_len;
		return;
	     end;
	     word_len = word_len - n;
	     if word_len >= 2 then do;		/* enough room for underlining */
		if strip_ix < word_ix then
		     if substr (strip_cs, word_ix, 2) = "_"
		     then do;			/* do not strip underlined leading punctuation */
			word_ix = word_ix -1;
			word_len = word_len + 1;
		     end;
		if word_ix + word_len < strip_ix + strip_len then
		     if substr (strip_cs, word_ix + word_len -2, 2) = "_"
		     then word_len = word_len +1;	/* do not strip underlined trailing punctuation */
	     end;

	end strip_punc;





check_ul:	proc;

/* checks word for continuous underlining
   de-underlined string is assembled in ul_buf
   underlining is replaced as follows:
   X<backspace><underline> -> XXX
   <underline><backspace>X -> XXX
   underline without adjacent backspace -> space
   the input word is given by substr(strip_cs, word_ix, word_len)
*/

dcl  i fixed bin;

	     ul_sw = "0"b;				/* assume word is not underlined */
	     if word_len + 2 <= length (ul_buf)		/* word fits in underline processing buffer */
	     & index (substr (strip_cs, word_ix, word_len), "") ^= 0
	     then do;				/* word contains backspaces, check for underlining */
		substr (ul_buf, 1, word_len) = substr (strip_cs, word_ix, word_len); /* copy stripped token */
		i = 0;
		do while (i < word_len);		/* scan token */
		     if i+3 > word_len then go to check_single_ul;
		     if substr (ul_buf, i+1, 2) = "_"
		     then do;
			substr (ul_buf, i+1, 1),
			     substr (ul_buf, i+2, 1) = substr (ul_buf, i+3, 1);
			i = i + 3;
		     end;
		     else if substr (ul_buf, i+2, 2) = "_"
		     then do;
			substr (ul_buf, i+2, 1),
			     substr (ul_buf, i+3, 1) = substr (ul_buf, i+1, 1);
			i = i +3;
		     end;
		     else
check_single_ul:	     if substr (ul_buf, i+1, 1) = "_"
		     then do;
			substr (ul_buf, i+1, 1) = " ";
			i = i + 1;
		     end;
		     else return;			/* not standard underlined string */
		end;
		ul_sw = "1"b;			/* yup, that was an underlined string */
	     end;

	end check_ul;





output_word: proc;

/* copies a word from the input seg to the temp seg
   max word size is 95 chars plus a trailing newline
   words exceeding 95 chars are truncated to 94 chars with a "?" appended
*/

	     if word_len > 95 then out_word_len = 94;	/* limit output words to 95 chars */
	     else out_word_len = word_len;
	     substr (temp_cs, temp_len+1, out_word_len) = substr (strip_cs, word_ix, out_word_len); /* copy word */
	     temp_len = temp_len + out_word_len;
	     if word_len > 95 then do;		/* oversize word */
		substr (temp_cs, temp_len+1, 1) = "?";	/* append "?" */
		temp_len = temp_len + 1;
	     end;
	     substr (temp_cs, temp_len+1, 1) = nl;	/* append newline */
	     temp_len = temp_len + 1;
	     output_words = output_words + 1;

	end output_word;





test_word: proc;

/* tests if current word matches any of the match words
   if a match if found, the action taken depends on whether find_word or correct_words was called
   for find_word, the line number of the current word is printed and
   if "-brief" was not specified, the word is printed with surrounding punctuation and delimiters
   for correct_words, the uncopied portion of the input string preceding the current word is copied to the temp seg
   if "-long" was specified, the line number of the current word is printed
*/

dcl  cc fixed bin (24);
dcl  i fixed bin;

/* Since the match_word array is in alphabetical (collating) order, we only have to
   search until we find the first word in the array that is greater than or equal to the
   current word. */

	     do wordx = 1 to n_words while (match_word < substr (strip_cs, word_ix, word_len));
	     end;

	     if wordx <= n_words
	     then if match_word = substr (strip_cs, word_ix, word_len)
		then do;
		     num_matches (wordx) = num_matches (wordx) + 1; /* we found a match, increment match count */
		     if cow_sw then do;		/* move chars before current word to temp seg and correct word */
			if ul_sw then do;		/* word was de-underlined */
			     word_ix = ul_ix + word_ix -1; /* get index of original word */
			     word_len = 3 * word_len; /* get length of original word */
			end;
			cc = word_ix -last -1;	/* compute number of unmoved chars before word_ix */
			substr (temp_cs, temp_len+1, cc) = substr (input_cs, last+1, cc); /* move 'em */
			last = last + cc + word_len;	/* recompute last char moved */
			temp_len = temp_len + cc;	/* number of chars in temp seg */
			if ^ul_sw then do;
			     substr (temp_cs, temp_len+1, length (corr_word)) = corr_word; /* drop in the correction */
			     temp_len = temp_len + length (corr_word);
			end;
			else do i = 1 to length (corr_word); /* underline the correction canonically */
			     if substr (corr_word, i, 1) < "_" then do;
				substr (temp_cs, temp_len +1, 1) = substr (corr_word, i, 1);
				temp_len = temp_len +1;
				substr (temp_cs, temp_len+1, 2) = "_";
				temp_len = temp_len + 2;
			     end;
			     else do;
				substr (temp_cs, temp_len +1, 2) = "_";
				temp_len = temp_len +2;
				substr (temp_cs, temp_len +1, 1) = substr (corr_word, i, 1);
				temp_len = temp_len +1;
			     end;
			end;
			if long then go to print_line_number;
		     end;
		     else if brief then
print_line_number:		if n_words = 1
			then call ioa_ ("^3d) line ^5d", num_matches (wordx), line);
			else call ioa_ ("^3d) line ^5d^-^a", num_matches (wordx), line, match_word);
		     else do;			/* print line number and token */
			if token_ix > 1 then
			     left_delim = delim_name (index (delims, substr (input_cs, token_ix-1, 1)));
			else left_delim = "";
			if token_ix + token_len <= input_len then
			     right_delim = delim_name (index (delims, substr (input_cs, token_ix+token_len, 1)));
			else right_delim = "";
			call ioa_ ("^3d) line ^5d^-^a^a^a", num_matches (wordx), line, left_delim,
			     substr (input_cs, token_ix, token_len), right_delim);
		     end;
		end;

	end test_word;





cleaner:	proc;					/* cleanup handler */

	     if nmp ^= null then do;
		free num_matches in (system_area);
		nmp = null;
	     end;
	     if mpp ^= null then do;
		free match_ptr in (system_area);
		mpp = null;
	     end;
	     if mlp ^= null then do;
		free match_len in (system_area);
		mlp = null;
	     end;
	     if cpp ^= null then do;
		free corr_ptr in (system_area);
		cpp = null;
	     end;
	     if clp ^= null then do;
		free corr_len in (system_area);
		clp = null;
	     end;
	     if ^nosort then			/* if temp_ptr points to temp seg */
		if temp_ptr ^= null then call hcs_$delentry_seg (temp_ptr, code); /* delete temp seg */
	     do input_ptr = input_ptr, output_ptr;
		if input_ptr ^= null then call hcs_$terminate_noname (input_ptr, code); /* terminate input  output segs */
	     end;
	end cleaner;

     end;





		    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
