


		    PNOTICE_dictionary.alm          11/14/89  1106.6r w 11/14/89  1106.5        3555


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

	aci	"C1DCTM0B0000"
	aci	"C2DCTM0B0000"
	aci	"C3DCTM0B0000"
	end
 



		    add_dict_words.pl1              12/17/85  1304.8rew 12/16/85  1652.2      294174


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


/****^  HISTORY COMMENTS:
  1) change(85-09-13,Spitzer), approve(85-09-13,MCR6618),
     audit(85-10-30,Blair), install(85-12-16,MR12.0-1001):
     Allow to read/write
     MSFs.
                                                   END HISTORY COMMENTS */

add_dict_words: adw: proc;

/* This program contains five commands used to modify and examine
   dictionaries.  A dictionary is represented as an indexed file.
   Each word in the dictionary is represented by a key in the file.
   A dictionary file is somewhat unusual in that it has no actual
   records.  Instead, the record descriptor word for each key is used
   to store certain attributes (e.g. hyphenation points) for the
   associated key.  The commands are:

   1. add_dict_words	adds words to a dictionary

   2. delete_dict_words	deletes words from a dictionary

   3. list_dict_words	lists words in a dictionary

   4. count_dict_words	reports the number of words in a dictionary

   5. find_dict_words	finds words in the dictionaries defined by
   .			the "dict" search list
*/

/* Coded by J. Stern, 1/13/77 */
/* Modified 9/77 by J. Stern to upgrade for installation */
/* Modified 10/25/77 by J. Stern to add find_dict_words command */
/* Modified 08/19/80 by P. Benjamin to fix bug when dict not first arg */
/* Modified 12/17/80 by P. Benjamin to fix bug where ddw creates dict when not found */
/* Modified 07/13/81 by P. Benjamin to fix bug where bad dict in search list
			      causes processing to halt */

/* Automatic */

dcl  ring_brackets (3) fixed bin (6);
dcl  bc fixed bin (24);
dcl  max_seg_size fixed bin (35);
dcl  component fixed bin;
dcl  type fixed bin (2);
dcl  msf bit (1) aligned;
dcl (add_cmd, delete_cmd, list_cmd, count_cmd, find_cmd) bit (1) aligned init ("0"b);
dcl  whoami char (20);
dcl  arg_syntax char (120);
dcl (nargs, words) fixed bin;
dcl (argno, pn_argno) fixed bin;
dcl  ap ptr;
dcl  al fixed bin;
dcl  code fixed bin (35);
dcl (brief_opt, force_opt, raw_opt, output_file_opt, input_file_opt, count_opt, dictionary_opt) bit (1) aligned;
dcl (pname, of_pname) char (168);
dcl  switch char (32);
dcl  atd char (256) varying;
dcl  atd_len fixed bin;
dcl  second_attach bit (1) aligned;
dcl  iocb_ptr ptr;
dcl  open_mode fixed bin;
dcl (of_dname, if_dname) char (168);
dcl (of_ename, if_ename) char (32);
dcl (of_ptr, if_ptr, fcb_ptr) ptr;
dcl (of_len, if_len) fixed bin (21);
dcl  word_count fixed bin;
dcl  dict_path char (168);
dcl  temp_ptr ptr;
dcl  bad_dict_ptr ptr;
dcl  complained_once bit (1);
		 		 
dcl 1 add_key_info,
    2 flags aligned like ak_header.flags,
    2 descrip aligned like descriptor_template,
    2 key_len fixed bin,
    2 key char (256);

dcl 1 delete_key_info like add_key_info;

dcl 1 get_key_info,
    2 flags aligned like gk_header.flags,
    2 descrip aligned like descriptor_template,
    2 key_len fixed bin,
    2 key char (256);

dcl 1 reassign_key_info,
    2 flags aligned like rk_header.flags,
    2 old_descrip aligned like descriptor_template,
    2 new_descrip aligned like descriptor_template,
    2 key_len fixed bin,
    2 key char (256);

dcl 1 sh_info,
    2 rel_type fixed bin,
    2 head_len fixed bin,
    2 key_head char (256);

dcl 1 info aligned like indx_info;

dcl 1 fdw_control aligned,
    2 exact_match bit (1) unal,
    2 mbz bit (35) unal;


/* Based */

dcl  arg char (al) based (ap);
dcl  of char (of_len) based (of_ptr);
dcl  if char (if_len) based (if_ptr);
dcl  if_vec (if_len) char (1) based (if_ptr);

dcl 1 descriptor_template aligned based,
    2 hpoints (32) bit (1) unal,
    2 notrim bit (1) unal,
    2 pad bit (3) unal;

dcl 1 bad_dict aligned based (bad_dict_ptr),
      2 n fixed bin,
      2 entry (0 refer (bad_dict.n)),
        3 ecode fixed bin (35),
        3 path char (168) unal;

/* Conditions */

dcl  cleanup condition;


/* Static */

dcl  stream_input fixed bin int static options (constant) init (1);
dcl  keyed_sequential_input fixed bin int static options (constant) init (8);
dcl  keyed_sequential_update fixed bin int static options (constant) init (10);

dcl  error_table_$dirseg fixed bin(35) ext static;
dcl  error_table_$long_record fixed bin(35) ext static;
dcl  error_table_$short_record fixed bin(35) ext static;
dcl  error_table_$zero_length_seg fixed bin (35) ext;
dcl  error_table_$noarg fixed bin (35) ext;
dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$key_duplication fixed bin (35) ext;
dcl  error_table_$no_record fixed bin (35) ext;
dcl  error_table_$no_key fixed bin (35) ext;
dcl  error_table_$end_of_info fixed bin (35) ext;
dcl  error_table_$noentry fixed bin (35) ext;
dcl  error_table_$wrong_no_of_args fixed bin (35) ext;
dcl  error_table_$id_not_found fixed bin (35) ext;
dcl  error_table_$fatal_error	fixed bin(35) ext static;
dcl  error_table_$recoverable_error fixed bin(35) ext static;
		 
dcl  iox_$user_output ptr ext;
dcl  sys_info$max_seg_size fixed bin(35) ext static;

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


/* Builtins */

dcl (addr, copy, divide, index, length, max, min, null, rtrim, substr, string, unspec) builtin;


/* Entries */

dcl  cu_$arg_count entry (fixed bin);
dcl  com_err_ entry options (variable);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin(35));
dcl  ioa_ options (variable);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35));
dcl  find_dict_word_ entry (char (*), bit (36) aligned, char (256), bit (36) aligned, char (168), ptr, fixed bin (35));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  pathname_ entry (char(*), char(*)) returns(char(168));
dcl  msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35));
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35));
dcl  make_msf_ entry (char(*), char(*), (3) fixed bin(6), fixed bin(35));
dcl  unmake_msf_ entry (char(*), char(*), bit(1), (3) fixed bin(6), fixed bin(35));
%page;

	add_cmd = "1"b;
	whoami = "add_dict_words";
	arg_syntax = "path words {-count} {-force} {-input_file path} {-raw} {-word word}";
	go to join;

delete_dict_words: ddw: entry;

	delete_cmd = "1"b;
	whoami = "delete_dict_words";
	arg_syntax = "path words {-brief} {-count} {-input_file path} {-word word}";
	go to join;

list_dict_words: ldw: entry;

	list_cmd = "1"b;
	whoami = "list_dict_words";
	arg_syntax = "path words {-brief} {-input_file path} {-output_file path} {-raw} {-word word}";
	go to join;

count_dict_words: cdw: entry;

	count_cmd = "1"b;
	whoami = "count_dict_words";
	arg_syntax = "path";
	go to join;

find_dict_words: fdw: entry;

	find_cmd = "1"b;
	whoami = "find_dict_words";
	arg_syntax = "words {-brief} {-dictionary} {-exact_match} {-input_file path} {-output_file path} {-raw} {-word word}";


/* find out how many arguments we have */

join:	call cu_$arg_count (nargs);
	if list_cmd | count_cmd | find_cmd
	then if nargs < 1
	     then do;
noarg:		code = error_table_$noarg;
usage:		call com_err_ (code, whoami, "^/Usage:  ^a ^a", whoami, arg_syntax);
		return;
	     end;
	     else;
	else if nargs < 2
	then go to noarg;

/* examine the arguments */

	brief_opt, force_opt, raw_opt, output_file_opt, input_file_opt, count_opt, dictionary_opt = "0"b;
	if find_cmd
	then do;
	     pn_argno = 0;
	     string (fdw_control) = ""b;
	end;
	else pn_argno = -1;
	words = 0;
	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, ap, al, code);
	     if index (arg, "-") ^= 1			/* not a control argument */
	     then if pn_argno = -1			/* don't have dictionary path yet */
		then do;				/* so this must be it */
		     call absolute_pathname_$add_suffix (arg, "dict", pname, code);
		     if code ^= 0
		     then do;
			call com_err_ (code, whoami, arg);
			return;
		     end;
		     pn_argno = argno;
		end;
		else if count_cmd
		then do;
		     code = error_table_$wrong_no_of_args;
		     go to usage;
		end;
		else words = words +1;		/* not dictionary path, must be a word */
	     else do;				/* control argument */
		if (delete_cmd | list_cmd | find_cmd) & (arg = "-bf" | arg = "-brief")
		then brief_opt = "1"b;
		else if add_cmd & (arg = "-fc" | arg = "-force")
		then force_opt = "1"b;
		else if (list_cmd | find_cmd) & (arg = "-of" | arg = "-output_file")
		then do;
		     argno = argno +1;
		     if argno > nargs
		     then go to noarg;
		     call cu_$arg_ptr (argno, ap, al, code);
		     of_pname = arg;
		     output_file_opt = "1"b;
		end;
		else if ^count_cmd & (arg = "-if" | arg = "-input_file")
		then do;
		     argno = argno +1;
		     if argno > nargs
		     then go to noarg;
		     input_file_opt = "1"b;
		end;
		else if (add_cmd | list_cmd | find_cmd) & arg = "-raw"
		then raw_opt = "1"b;
		else if (add_cmd | delete_cmd) & (arg = "-ct" | arg = "-count")
		then count_opt = "1"b;
		else if find_cmd & (arg = "-dict" | arg = "-dictionary")
		then dictionary_opt = "1"b;
		else if find_cmd & (arg = "-exm" | arg = "-exact_match")
		then fdw_control.exact_match = "1"b;
		else if ^count_cmd & arg = "-word"
		then do;
		     argno = argno + 1;
		     if argno > nargs
		     then go to noarg;
		     words = words + 1;
		end;
		else do;
		     call com_err_ (error_table_$badopt, whoami, "^a", arg);
		     return;
		end;
	     end;
	end;

	if pn_argno = -1
	then go to noarg;

	if (add_cmd | delete_cmd | find_cmd) & ^input_file_opt & words = 0
	then go to noarg;

	iocb_ptr, fcb_ptr, of_ptr, if_ptr, temp_ptr, bad_dict_ptr = null;
	max_seg_size = sys_info$max_seg_size * 4;

	on cleanup call cleaner;

	call get_temp_segment_ (whoami, bad_dict_ptr, code);
	if code ^= 0
	     then do;
	     call com_err_ (code, whoami);
	     goto clean_up;
	end;
	
	complained_once = "0"b;			/* certain errors should be given only */
						/* per command, not one per word */

	if find_cmd
	then go to check_of;

/* attach and open the dictionary */

	second_attach = "0"b;
	switch = unique_chars_ (""b) || "." || whoami;	/* use unique I/O switch name */
	atd = "vfile_ " || rtrim (pname);
	atd = atd || " -share -old";			/* build attach description, assume dictionary exists */

	if list_cmd
	then open_mode = keyed_sequential_input;
	else open_mode = keyed_sequential_update;

attach:	call iox_$attach_name (switch, iocb_ptr, (atd), null, code);
	if code ^= 0
	then do;
	     call com_err_ (code, whoami, "Cannot attach switch.  ^a", switch);
	     return;
	end;

	if count_cmd
	then go to get_count;

	if second_attach				/* give warning of new dictionary creation */
	then call ioa_ ("^a:  Creating ^a", whoami, pname);

	call iox_$open (iocb_ptr, open_mode, "0"b, code);
	if code ^= 0
	then if code = error_table_$noentry & open_mode = keyed_sequential_update & ^second_attach
	     then do;				/* no dictionary, warn user and then create one */

		if delete_cmd			/* but not for ddw! */
		     then do;
		     call com_err_ (code, whoami, "^a", pname);
		     goto clean_up;
		end;

		call close_file (iocb_ptr);

		atd_len = length (rtrim (atd));
		substr (atd, atd_len-3, 4) = "";	/* remove "-old" from attach description */
		second_attach = "1"b;
		go to attach;
	     end;
	     else do;
		call com_err_ (code, whoami, "Cannot open file.  ^a", pname);
		go to clean_up;
	     end;

/* make output segment if requested */

	if list_cmd | find_cmd
	then do;
check_of:	     if output_file_opt
	     then do;
		call expand_pathname_ (of_pname, of_dname, of_ename, code);
		if code ^= 0
		then do;
		     call com_err_ (code, whoami, "^a", of_pname);
		     go to clean_up;
		end;

		call hcs_$status_minf (of_dname, of_ename, 1, type, bc, code);
		if code = 0
		then if type = 2			/* entry exists */
		     then if bc = 0			/* DIR */
			then do;			/* really a DIR */
			     code = error_table_$dirseg;
			     goto bad_of;
			     end;
			else do;			/* DIR & bc>0 = MSF */
			     call unmake_msf_ (of_dname, of_ename, "0"b, ring_brackets, code);
			     if code ^= 0 then goto bad_of;
			     end;
		     else ;			/* must be a SSF */
		else if code ^= error_table_$noentry
		     then goto bad_of;		/* allowed to be non-existent */

		call hcs_$make_seg (of_dname, of_ename, "", 01010b, of_ptr, code);
		if of_ptr = null
		then do;
bad_of:		     call com_err_ (code, whoami, "^a", pathname_ (of_dname, of_ename));
		     go to clean_up;
		end;
	     end;
	     else do;				/* get temp segment to buffer output */
		call get_temp_segment_ (whoami, temp_ptr, code);
		if code ^= 0
		then do;
		     call com_err_ (code, whoami, "Cannot get temporary segment.");
		     go to clean_up;
		end;
		of_ptr = temp_ptr;
	     end;

	     component = 0;
	end;

/* initialize info for vfile_ control orders */

	if delete_cmd
	then do;
	     sh_info.rel_type = 0;
	     sh_info.head_len = 256;			/* max word size = 256 */
	     string (delete_key_info.flags) = ""b;
	end;
	else if add_cmd
	then do;
	     string (add_key_info.flags) = ""b;
	     add_key_info.input_key, add_key_info.input_desc = "1"b;
	     if force_opt
	     then do;
		string (reassign_key_info.flags) = ""b;
		reassign_key_info.input_new_desc = "1"b;
	     end;
	     go to gk_setup;
	end;
	else if list_cmd
	then if words = 0 & ^input_file_opt
	     then unspec (get_key_info.flags) = ""b;
	     else do;
gk_setup:		get_key_info.flags.input_key = "1"b;
		get_key_info.input_desc = "0"b;
		get_key_info.desc_code = 0;
		get_key_info.rel_type = 0;
		get_key_info.head_size = 256;
		get_key_info.reset_pos = "0"b;
		get_key_info.flags.pad = ""b;
		get_key_info.version = gk_info_version_0;
	     end;

/* get to work */

	of_len, word_count = 0;

	if list_cmd & words = 0 & ^input_file_opt
	then call list_all;
	else do argno = 1 to nargs;		/* look again for words and input files */
	     if argno = pn_argno
		then argno = argno + 1;
	     if argno > nargs
		then goto get_out;
	     call cu_$arg_ptr (argno, ap, al, code);
	     if index (arg, "-") = 1
	     then do;
		if arg = "-if" | arg = "-input_file"
		then do;
		     argno = argno +1;
		     call cu_$arg_ptr (argno, ap, al, code);
		     call read_input_file;
		end;
		else if arg = "-of" | arg = "-output_file"
		then argno = argno +1;
		else if arg = "-word"
		then do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, ap, al, code);
		     call process_word (arg);
		end;
	     end;
	     else call process_word (arg);
get_out:	     
	end;


/* print results for list and find */

	if of_len > 0
	then if output_file_opt
	     then do;
		call terminate_file_ (of_ptr, of_len * 9, TERM_FILE_TRUNC_BC_TERM, code);
		if code ^= 0
		then call com_err_ (code, whoami, "Setting bit count on ^a.", pathname_ (of_dname, of_ename));
		end;
	     else do;
		call iox_$put_chars (iox_$user_output, of_ptr, of_len, code);
		if code ^= 0
		then call com_err_ (code, whoami, "Attempting to write on user_output switch.");
		end;

/* report counts if requested */

	if count_opt
	then do;
	     call ioa_ ("number of words ^[added^;deleted^] = ^d", add_cmd, word_count);

get_count:     indx_info.info_version = vfs_version_1;
	     call iox_$control (iocb_ptr, "file_status", addr (indx_info), code);
	     if code ^= 0
	     then call com_err_ (code, whoami, "Cannot get dictionary word count.");
	     else call ioa_ ("number of dictionary words = ^d", indx_info.num_keys);
	end;

/* clean up and leave */

clean_up:	call cleaner;
	return;

cleaner:	proc;					/* cleanup procedure */

	if iocb_ptr ^= null
	then call close_file (iocb_ptr);

	if of_ptr ^= null
	then if of_ptr = temp_ptr
	     then call release_temp_segment_ (whoami, temp_ptr, (0));
	     else call terminate_file_ (of_ptr, 0, TERM_FILE_TERM, (0));

	if if_ptr ^= null
	then if msf
	     then call close_file (if_ptr);
	     else call terminate_file_ (if_ptr, 0, TERM_FILE_TERM, (0));

	if bad_dict_ptr ^= null
	then call release_temp_segment_ (whoami, bad_dict_ptr, (0));

	if fcb_ptr ^= null
	then call msf_manager_$close (fcb_ptr);

	return;
	end cleaner;

/* This procedure reads words from an input file whose pathname
   is given by the value of arg.  Words are assumed to be separated
   by newlines.  Each word read is submitted to process_word.
*/

read_input_file: proc;

dcl (i, max_word_len, NL_index, word_len) fixed bin (21);
dcl  word char (word_len) based (word_ptr);
dcl  word_ptr ptr;
dcl  if_buffer char (257);
	       
	     msf = "0"b;
	     if_ptr = null;

	     call expand_pathname_ (arg, if_dname, if_ename, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, whoami, "Input file ignored. ^a", arg);
		return;
	     end;

	     call hcs_$status_minf (if_dname, if_ename, 1, type, bc, code);
	     if code ^= 0 then do;
bad_if:		call com_err_ (code, whoami, "Input file ignored. ^a", pathname_ (if_dname, if_ename));
		goto EOF;
		end;

	     if type = 2
	     then if bc = 0
		then do;
		     code = error_table_$dirseg;
		     goto bad_if;
		     end;
		else msf = "1"b;
	     else msf = "0"b;

	     if msf then do;
		atd = "vfile_ " || rtrim (if_dname);
		atd = atd || ">";
		atd = atd || rtrim (if_ename);
		atd = atd || " -old";

		call iox_$attach_name (unique_chars_ ("0"b) || whoami, if_ptr, (atd), null, code);
		if code ^= 0 then goto bad_if;
		call iox_$open (if_ptr, stream_input, "0"b, code);
		if code ^= 0 then goto bad_if;

		word_ptr = addr (if_buffer);
		max_word_len = length (if_buffer);

		call iox_$get_line (if_ptr, word_ptr, max_word_len, word_len, code);
		end;
	     else do;
		call initiate_file_ (if_dname, if_ename, R_ACCESS, if_ptr, bc, code);
		if if_ptr = null
		then go to bad_if;

		if_len = divide (bc, 9, 21, 0);
		if if_len = 0
		then do;
		     code = error_table_$zero_length_seg;
		     go to bad_if;
		end;

		i = 1;
		end;

	     do while ("1"b);
		if msf
		then if code ^= 0
		     then if code = error_table_$end_of_info
		          then goto EOF;
			else if code = error_table_$long_record | code = error_table_$short_record
			     then ;		/* allowable errors */
			else goto bad_if;
		     else do;
			NL_index = index (word, NL);
			if NL_index > 0
			then word_len = NL_index - 1;
			if word_len = -1
			then goto read_next;
			end;
		else if i > if_len
		     then goto EOF;
		     else do;
			word_len = index (substr (if, i), NL) -1;
			if word_len = 0
			then go to read_next;
			if word_len = -1
			then word_len = if_len - i + 1;
			word_ptr = addr (if_vec (i));
			end;

		call process_word (word);

read_next:
		if msf
		then call iox_$get_line (if_ptr, word_ptr, max_word_len, word_len, code);
		else i = i + word_len +1;
	     end;

EOF:
	if if_ptr ^= null
	then if msf
	     then call close_file (if_ptr);
	     else do;
		call terminate_file_ (if_ptr, 0, TERM_FILE_TERM, code);
		if_ptr = null;
		end;

	return;
	end read_input_file;

close_file:
     proc (iocbp);

dcl  iocbp ptr parameter;

	if iocbp ^= null then do;
	     call iox_$close (iocbp, (0));
	     call iox_$detach_iocb (iocbp, (0));
	     call iox_$destroy_iocb (iocbp, (0));
	     iocbp = null;
	     end;

	return;
	end close_file;
%page;
/* This procedure selects the proper subroutine to process the current word. */

process_word: proc (cur_word);

dcl  cur_word char (*);


	     if add_cmd
	     then call add;
	     else if delete_cmd
	     then call delete;
	     else if list_cmd
	     then call list;
	     else call find;

/* This procedure adds the current word to the dictionary.  It first
   scans the word for hyphenation and/or notrim.  If the word already
   exists in the dictionary, it is not added (reassigned) unless the
   force option was specified.
*/

add:	     proc;

dcl (i, j) fixed bin;
dcl  keystr char (256) varying;
dcl  next_char char (1);

/* examine word for hyphenation and notrim, isolate the key */

		string (add_key_info.descrip) = ""b;

		if raw_opt
		then do;
		     if length (cur_word) > 256
		     then do;
big_word:			call com_err_ (0, whoami, "Word size exceeds 256.  Word ignored.  ^a", cur_word);
			return;
		     end;
		     keystr = cur_word;
		     go to add_key;
		end;

		keystr = "";
		j = 1;
		if substr (cur_word, 1, 1) = "^"	/* check for notrim */
		then do;
		     if length (cur_word) > 1
		     then next_char = substr (cur_word, 2, 1);
		     else next_char = " ";

		     if next_char ^= "="		/* must be a notrim sign */
		     then add_key_info.descrip.notrim = "1"b;

		     if next_char = "=" | next_char = "^" /* must be a literal circumflex */
		     then do;
			keystr = "^";
			j = 3;
		     end;
		     else j = 2;
		end;

		do j = j by 1 while (j <= length (cur_word));
		     i = index (substr (cur_word, j), "-") -1;
		     if i = -1
		     then i = length (cur_word) - j + 1;

		     if i > 0			/* add chars to key */
		     then do;
			if i + length (keystr) > 256
			then go to big_word;
			keystr = keystr || substr (cur_word, j, i);
			j = j + i;		/* j points to next hyphen or circumflex */
		     end;

		     if j <= length (cur_word)	/* something left */
		     then do;
			if j < length (cur_word)
			then next_char = substr (cur_word, j+1, 1);
			else next_char = " ";

			if next_char ^= "="		/* must be a hyphenation point */
			then do;
			     if length (keystr) = 0
			     then do;
				call com_err_ (0, whoami, "Hyphenation point precedes word.  Word ignored.  ^a", cur_word);
				return;
			     end;
			     if substr (keystr, length (keystr), 1) = "-"
			     then do;
				call com_err_ (0, whoami, "Hyphenation point immediately follows hyphen.  Word ignored.  ^a", cur_word);
				return;
			     end;
			     if length (keystr) > 32
			     then do;
				call com_err_ (0, whoami, "Hyphenation point occurs beyond 33rd character.  Word ignored.  ^a", cur_word);
				return;
			     end;
			     add_key_info.descrip.hpoints (length (keystr)) = "1"b; /* indicate hyphenation point */
			end;

			if next_char = "=" | next_char = "-" /* must be a literal hyphen */
			then do;
			     if length (keystr) = 256
			     then go to big_word;
			     keystr = keystr || "-";	/* indicate literal hyphen */
			     j = j + 1;		/* to skip over two character sequence */
			end;
		     end;
		end;

		if length (keystr) <= 32
		then if add_key_info.descrip.hpoints (length (keystr))
		     then do;
			call com_err_ (0, whoami, "Hyphenation point follows word.  Word ignored.  ^a", cur_word);
			return;
		     end;

/* add the word to the dictionary */

add_key:		add_key_info.key = keystr;
		add_key_info.key_len = length (keystr);

		call iox_$control (iocb_ptr, "add_key", addr (add_key_info), code);
		if code = 0
		then do;
		     word_count = word_count + 1;
		     return;
		end;

		if code ^= error_table_$key_duplication
		then do;
		     call com_err_ (code, whoami, "Cannot add ""^a"".", keystr);
		     return;
		end;

/* same word already in dictionary */
/* see if it has the same descriptor */

		get_key_info.key = add_key_info.key;
		get_key_info.key_len = 256;
		call iox_$control (iocb_ptr, "get_key", addr (get_key_info), code);
		if code ^= 0
		then do;
		     call com_err_ (code, whoami, "Cannot determine if word already in dictionary.  Word ignored.  ^a", keystr);
		     return;
		end;

		if string (get_key_info.descrip) = string (add_key_info.descrip) /* same descrip)tor */
		then return;			/* nothing to do */

		if force_opt | get_key_info.descrip.pad ^= ""b
		then do;				/* give word a new descriptor */
		     reassign_key_info.new_descrip = add_key_info.descrip;
		     call iox_$control (iocb_ptr, "reassign_key", addr (reassign_key_info), code);
		     if code ^= 0
		     then call com_err_ (code, whoami, "Cannot reassign ""^a"".", keystr);
		end;
		else call com_err_ (0, whoami, "Word already in dictionary with different ^[hyphenation^;notrim^].  Word ignored.  ^a",
		     (string (get_key_info.descrip.hpoints) ^= string (add_key_info.descrip.hpoints)), keystr);

	     end add;

/* A procedure to delete a word from the dictionary. */

delete:	     proc;

		if length (cur_word) > 256
		then go to word_not_found;

		sh_info.key_head = cur_word;
		call iox_$control (iocb_ptr, "seek_head", addr (sh_info), code);
		if code = 0
		then call iox_$control (iocb_ptr, "delete_key", addr (delete_key_info), code);

		if code ^= 0
		then do;
		     if code = error_table_$no_record | code = error_table_$no_key
		     then
word_not_found:		if brief_opt
			then;
			else call com_err_ (0, whoami, "Word not in dictionary.  ^a", cur_word);
		     else call com_err_ (code, whoami, "Cannot delete ""^a"".", cur_word);
		     return;
		end;

		word_count = word_count + 1;

	     end delete;

/* A procedure to list a word from the dictionary. */

list:	     proc;

		if length (cur_word) > 256
		then go to word_not_found;

		get_key_info.key = cur_word;
		get_key_info.key_len = 256;
		call iox_$control (iocb_ptr, "get_key", addr (get_key_info), code);
		if code ^= 0
		then do;
		     if code = error_table_$no_record | code = error_table_$no_key
		     then
word_not_found:		if brief_opt
			then;
			else call com_err_ (0, whoami, "Word not in dictionary.  ^a", cur_word);
		     else call com_err_ (code, whoami, "Cannot list ""^a"".", cur_word);
		     return;
		end;

		call output_word (get_key_info.key, get_key_info.key_len, string (get_key_info.descrip));


	     end list;

/* A procedure to find a word in the sequence of dictionaries
   defined by the "dict" search list.
*/

find:	     proc;

dcl  word_found char (256);
dcl  desc_found bit (36) aligned;
dcl  baddy fixed bin;
	     

		bad_dict.n = 0;

		call find_dict_word_ ((cur_word), string (fdw_control), word_found, desc_found, dict_path, bad_dict_ptr, code);

		if ^complained_once			/* for each command invocation */
		     then do baddy = 1 to bad_dict.n;	/* report each bad dictionary */
		     call com_err_ (bad_dict.entry.ecode (baddy), whoami, "^a", bad_dict.entry.path (baddy));
		end;

		if code ^= 0 
		     then if code = error_table_$recoverable_error 
		     then do;			/* print recoverable error message */
			if ^complained_once		/* only once per command invocation */
			     then do;		/* and don't abort */
			     call com_err_ (code, whoami, "^/");
			     complained_once = "1"b;
			end;
		     end;
		else do;
		     if code = error_table_$id_not_found /* this guy gets printed each time */
		     then if brief_opt		/* unless it's suppressed */
			then;
		          else call com_err_ (0, whoami, "Word not found.  ^a", cur_word);
		     else call com_err_ (code, whoami, "Cannot find ""^a"". ^[(Referencing dictionary ^a)^]",
			cur_word, ((dict_path ^= "") & (code ^= error_table_$fatal_error)), dict_path);
		     complained_once = "1"b;
		     return;
		end;

		call output_word (word_found, length (rtrim (word_found)), desc_found);

		
	     end find;


	end process_word;

/* A procedure to list all words in the dictionary in order. */

list_all:	proc;

dcl  i fixed bin;

	     i, code = 0;
	     do while (code = 0);
		call iox_$control (iocb_ptr, "get_key", addr (get_key_info), code);
		if code = 0
		then do;
		     call output_word (get_key_info.key, get_key_info.key_len, string (get_key_info.descrip));
		     i = i +1;
		     call iox_$position (iocb_ptr, 0, 1, code);
		end;
	     end;

	     if code ^= error_table_$end_of_info
	     then call com_err_ (code, whoami, "Cannot list remaining words.");
	     else if i = 0
	     then if ^brief_opt
		then call com_err_ (0, whoami, "No words in dictionary.");

	end list_all;

/* This procedure outputs a word.  If the raw option was not
   specified, the word is edited to display its hyphenation
   and notrim attributes.  If an output segment was specified,
   the word is copied to that segment with a newline appended.
   Otherwise, the word is printed on the user's terminal.
*/

output_word: proc (word, word_len, word_desc);

dcl  word char (256);
dcl  word_len fixed bin;
dcl  word_desc bit (36) aligned;

dcl 1 desc aligned like descriptor_template based (addr (word_desc));

dcl (i, i2, j) fixed bin;
dcl  out_buf char (300) varying;

	     if raw_opt
	     then out_buf = substr (word, 1, word_len);

	     else do;
		j = 1;
		if desc.notrim
		then out_buf = "^";
		else if substr (word, 1, 1) = "^"
		then do;
		     out_buf = "^=";
		     j = 2;
		end;
		else out_buf = "";

		do while (j <= word_len);

		     i = index (substr (word, j, word_len+1-j), "-") -1; /* find next hyphen */
		     if i = -1
		     then i = word_len + 1 - j;

		     if j <= 32
		     then do;
			i2 = index (substr (string (desc.hpoints), j, 33-j), "1"b); /* find next hyphenation point */
			if i2 = 0
			then i2 = 257;
		     end;
		     else i2 = 257;

		     i = min (i, i2);		/* get index of closest hyphen or hyphenation point */
		     if i > 0			/* we've skipped a few chars */
		     then do;			/* add them to output */
			out_buf = out_buf || substr (word, j, i);
			j = j + i;
			if i2 <= i		/* there is a hyphenation point */
			then out_buf = out_buf || "-"; /* show it */
		     end;

		     if j <= word_len		/* haven't reached the end yet */
		     then if substr (word, j, 1) = "-"	/* there's a real hyphen */
			then do;			/* put it in the output */
			     if i2 > i		/* there is no hyphenation point */
			     then out_buf = out_buf || "-=";
			     else out_buf = out_buf || "-";
			     j = j + 1;
			end;
		end;
	     end;

	     call output (out_buf);

	     if dictionary_opt
	     then do;
		call output (copy (" ", max (1, 19 - length (out_buf))));
		call output (rtrim (dict_path));
	     end;

	     call output ((NL));
	     return;

output:
     proc (str) recursive;

dcl  str char (*) varying parameter;
dcl  (len, chars_that_fit) fixed bin (21);

	len = length (str);

	if of_len + len + 1 > max_seg_size
	then if output_file_opt
	     then do;
		chars_that_fit = max_seg_size - of_len;
		substr (of, of_len+1, chars_that_fit) = str;

		if component = 0
		then do;

		     call terminate_file_ (of_ptr, max_seg_size * 9, TERM_FILE_BC | TERM_FILE_TERM, code);
		     if code ^= 0 then goto bad_of;

		     call make_msf_ (of_dname, of_ename, ring_brackets, code);
		     if code ^= 0 then goto bad_of;

		     call msf_manager_$open (of_dname, of_ename, fcb_ptr, code);
		     if code ^= 0 then goto bad_of;

		     call msf_manager_$get_ptr (fcb_ptr, 1, "1"b, of_ptr, bc, code);
		     if code ^= 0 then goto bad_of;

		     component = 1;
		     end;
		else do;
		     call terminate_file_ (of_ptr, max_seg_size * 9, TERM_FILE_BC | TERM_FILE_TERM, code);
		     if code ^= 0 then goto bad_of;

		     call msf_manager_$get_ptr (fcb_ptr, component+1, "1"b, of_ptr, bc, code);
		     if code ^= 0 then goto bad_of;

		     component = component + 1;
		     end;

		of_len = 0;			/* empty output file */

		if len > chars_that_fit
		then call output (substr (str, chars_that_fit + 1));
		return;
		end;
	     else do;
		call iox_$put_chars (iox_$user_output, of_ptr, of_len, code);
		if code ^= 0 then do;
		     call com_err_ (code, whoami, "attempting to write on user_output switch.");
		     goto clean_up;
		     end;

		of_len = 0;
		end;

	substr (of, of_len+1, len) = str;
	of_len = of_len + len;

	return;
	end output;

	end output_word;

%page;
/* include files */

%include vfs_info;
%include ak_info;
%include terminate_file;
%include access_mode_values;

     end add_dict_words;
  



		    alphabetize_strings_.pl1        11/18/82  1707.6rew 11/18/82  1629.0       40230


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


alphabetize_strings_: proc (pm_data_p, pm_count);

/* A procedure to sort a collection of strings into alphabetical order. */

/* Coded 10/19/77 by J. Stern */


/* Parameters */

dcl  pm_data_p ptr;					/* ptr to an array of string descriptors */
dcl  pm_count fixed bin (21);				/* number of strings to alphabetize */


/* Automatic */

dcl  code fixed bin (35);
dcl  temp_ptrs (3) ptr;
dcl (data_p, new_data_p) ptr;
dcl  buffer_p ptr;
dcl  max_seglen fixed bin (21);
dcl  buffer_len fixed bin (21);
dcl  str_p ptr;
dcl  str_len fixed bin (21);
dcl  i fixed bin (21);
dcl  saved_blen fixed bin (21);


/* Based */

dcl 1 sort_data (pm_count) aligned based (data_p) like sort_entry;

dcl 1 new_sort_data (pm_count) aligned based (new_data_p) like sort_entry;

dcl 1 sort_entry aligned based,
    2 string_p ptr unal,
    2 string_len fixed bin (21);

dcl  buffer char (buffer_len) based (buffer_p);
dcl  buf_vector (buffer_len) char (1) based (buffer_p);
dcl  cstring char (str_len) based (str_p);


/* Static */

dcl  sys_info$max_seg_size fixed bin (21) ext;
dcl  error_table_$action_not_performed fixed bin (35) ext;

dcl  capital_letters char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  small_letters char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");


/* Conditions */

dcl  cleanup condition;


/* Builtins */

dcl (substr, addr, search, translate, null, verify) builtin;


/* Entries */

dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  sub_err_ entry options (variable);
dcl  sort_strings_$indirect entry (ptr, fixed bin (21), ptr);
dcl  ascii_to_abcdef_ entry (char (*), char (*));

/* get some temporary segments */

	temp_ptrs (*) = null;
	on cleanup call cleaner;

retry:	call get_temp_segments_ ("alphabetize_strings_", temp_ptrs, code);
	if code ^= 0
	then do;
	     call sub_err_ (code, "alphabetize_strings_", "h", null, (0), "Cannot get temporary segments.");
	     go to retry;
	end;

/* build a new array of string descriptors */
/* transform strings containing control chars or capital letters */

	new_data_p = temp_ptrs (1);
	buffer_p = temp_ptrs (2);
	data_p = pm_data_p;
	max_seglen = 4 * sys_info$max_seg_size;
	buffer_len = 0;

	do i = 1 to pm_count;
	     str_p = sort_data (i).string_p;
	     str_len = sort_data (i).string_len;
	     if verify (cstring, small_letters) = 0
	     then do;				/* plain vanilla string, use in place */
		new_sort_data (i) = sort_data (i);
		go to next_string;
	     end;

	     if buffer_len + 2*str_len + 1 > max_seglen	/* buffer is full */
	     then do;				/* switch to next temp seg */
		if buffer_p = temp_ptrs (3)		/* already used spare temp seg */
		then call sub_err_ (error_table_$action_not_performed, "alphabetize_strings_", "s", null, (0),
		     "Temporary storage limit exceeded.");

		call ascii_to_abcdef_ (buffer, buffer); /* rearrange char codes so letters precede all else */
		buffer_p = temp_ptrs (3);
		buffer_len = 0;
	     end;

	     saved_blen = buffer_len;
	     if search (cstring, capital_letters) ^= 0
	     then do;
		substr (buffer, buffer_len + 1, str_len + 1) = translate (cstring, small_letters, capital_letters);
		buffer_len = buffer_len + str_len + 1;	/* extra +1 to insert SPACE */
	     end;

	     substr (buffer, buffer_len+1, str_len) = cstring;
	     buffer_len = buffer_len + str_len;

	     new_sort_data (i).string_p = addr (buf_vector (saved_blen+1));
	     new_sort_data (i).string_len = buffer_len - saved_blen;
next_string:
	end;

	call ascii_to_abcdef_ (buffer, buffer);		/* rearrange char codes so letters precede all else */

	call sort_strings_$indirect (new_data_p, pm_count, data_p);

	call cleaner;

	return;

cleaner:	proc;

	     if temp_ptrs (1) ^= null
	     then call release_temp_segments_ ("alphabetize_strings_", temp_ptrs, code);

	end cleaner;


     end alphabetize_strings_;
  



		    ascii_to_abcdef_.alm            11/18/82  1707.6rew 11/18/82  1626.3       24894


"  ***********************************************************
"  *                                                         *
"  *                                                         *
"  * Copyright, (C) Honeywell Information Systems Inc., 1981 *
"  *                                                         *
"  *                                                         *
"  ***********************************************************

"ALM subroutine to convert from 9 bit ASCII to 9 bit ABCDEF
"ABCDEF is identical to ASCII except that the 400 bit is on for all non-alphabetic chars
"input bytes must be valid ASCII characters whose octal values
"fall in the range 000 <_ octal_value <_ 177
"
"ARG 1: pointer to source string - data to be converted
"ARG 2: pointer to target string - converted data
"
"PL/I Usage:
"
"dcl  ascii_to_abcdef_ ext entry (char (*), char (*));
"    call ascii_to_abcdef_ (input_string, output_string);
"
"
"Note: the ASCII to ABCDEF mapping used is defined in the
"      text of this procedure.  It is available to a user
"      program through the following declaration.
"
"dcl  ascii_to_abcdef_$aa_table char (128) external static;
"
"The table consists of 128 ABCDEF characters which
"correspond to the 128 ASCII characters.  The first character
"corresponds to 000, the 2nd to 001, ....., the 128th
"to 177.
"
"Converted from ascii_to_ebcdic_ by J. Stern 11/2/77
                    name      ascii_to_abcdef_
		segdef	ascii_to_abcdef_
		segdef	aa_table
ascii_to_abcdef_:	epp1	ap|2,*		address of source string to pr1
		epp3	ap|4,*		address of target string to pr3
		ldx3	0,du		set x3 not to skip parent pointer if none
		lxl2	ap|0		load argument list code value
		canx2	=o000004,du	check for code 4 - no parent pointer
		tnz	*+2		transfer if no parent pointer
		ldx3	2,du		parent pointer - set x3 to skip it
		lda	ap|6,x3*		load source string descriptor
		ldq	ap|8,x3*		load target string descriptor
		ana	mask		drop all but string size bits
		anq	mask		ditto
		even
		mvt	(pr,rl),(pr,rl),fill(040)	translate ascii to abcdef
		desc9a	1|0,al		source string
		desc9a	3|0,ql		target string
		arg	aa_table
		short_return		"exit

mask:		oct	000077777777
		even
aa_table:		oct	400401402403,404405406407
		oct	410411412413,414415416417
		oct	420421422423,424425426427
		oct	430431432433,434435436437
		oct	000441442443,444445446447
		oct	450451452453,454455456457
		oct	460461462463,464465466467
		oct	470471472473,474475476477
		oct	500101102103,104105106107
		oct	110111112113,114115116117
		oct	120121122123,124125126127
		oct	130131132533,534535536537
		oct	540141142143,144145146147
		oct	150151152153,154155156157
		oct	160161162163,164165166167
		oct	170171172573,574575576577
		bss	,96			codes > 177 translate to 000

		end
  



		    create_wordlist.pl1             01/23/89  1231.4rew 01/23/89  1229.7      383256


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1989                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(85-09-13,Spitzer), approve(85-09-13,MCR6618),
     audit(85-10-30,Blair), install(85-12-16,MR12.0-1001):
     Allow to read/write
     MSFs.
  2) change(88-10-05,Lee), approve(88-11-14,MCR8018), audit(88-11-28,Flegel),
     install(89-01-23,MR12.3-1010):
     phx20562 (Commands 478) - fixed bug in locate_words when -lines
     control arg is specified.
                                                   END HISTORY COMMENTS */

create_wordlist: cwl: proc;

/* converted 7/12/77 by J. Stern from word_list to create_wordlist 
   modified 05/28/80 by P. Benjamin to fix missing -li shortname for -lines
		 and fix bug where -li has no arg and should default to 0
   modified 05/29/80 by P. Benjamin to fix -lg bug where all lines not printed.
*/


/* Automatic */

dcl  temp_dir char (168);
dcl  (uid_in, uid_out) bit (36) aligned;		/* File UIDs */
dcl  current_record fixed bin (24);
dcl  max_line_len fixed bin (21);			/* size of read input buffer */
dcl  changed_lines bit (1) aligned;			/* =1b, changed input line */
dcl  output_record_number fixed bin (35);		/* record number in temp file */
dcl  (inputp, outputp, sortp) ptr init (null);		/* IOCB pointers */
dcl  type fixed bin (2);				/* 1=segment, 2=directory */
dcl  msf bit (1) aligned;
dcl (nmp, mpp, mlp, rlp, rpp, system_area_ptr) ptr init (null);
dcl  ap ptr;
dcl  al fixed bin;
dcl (ldpp, ldcp) ptr init (null);
dcl  old_ptr ptr;
dcl  old_count fixed bin;
dcl  plip ptr init (null);
dcl  prevx fixed bin;
dcl  lines fixed bin (24) init (-1);
dcl (argno, n_args, n_words, wordx) fixed bin;
dcl  no_sort_opt bit (1) aligned init ("0"b);
dcl (brief_opt, long_opt) bit (1) aligned init ("0"b);
dcl  header_opt bit (1) aligned init ("0"b);
dcl  no_exclude_opt bit (1) aligned init ("0"b);
dcl  count_opt bit (1) aligned init ("0"b);
dcl  no_control_opt bit (1) aligned init ("0"b);
dcl (cwl_cmd, lw_cmd, rw_cmd) bit (1) aligned init ("0"b);
dcl  got_pname bit (1) aligned init ("0"b);
dcl  invalid_sw bit (1) aligned;
dcl  ul_sw bit (1) aligned;
dcl  whoami char (16);
dcl  (ename, input_ename, sort_name) char (32);
dcl  (dname, input_dname, sort_dir) char (168);
dcl  arg_syntax char (120);
dcl  code fixed bin (35);
dcl  bc fixed bin (24);
dcl  temp_ptr_array (3) ptr init ((3) null);
dcl (input_ptr, temp_ptr, output_ptr, sort_data_ptr) ptr init (null);
dcl (input_len, output_len, temp_len) fixed bin (21);
dcl  line_ptr ptr;
dcl  strip_ptr ptr;
dcl (to_line, from_line) fixed bin (24) init (0);
dcl (delim_ix, delim_len, line_ix, line_len, ul_spaces) fixed bin (21);
dcl (token_ix, token_len, strip_ix, strip_len, word_ix, word_len, ul_ix, ul_len) fixed bin (24);
dcl (rev_line_ix, rev_line_len) fixed bin (24);
dcl (i, j, n, line_diff, last, line, output_words) fixed bin (24);
dcl  ul_ptr ptr;
dcl  max_sort_entries fixed bin (24);


/* Based */

dcl  system_area area (65536) based (system_area_ptr);
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  rev_word char (rev_len (wordx)) based (rev_ptr (wordx));
dcl  rev_len (n_words) based (rlp) fixed bin;
dcl  rev_ptr (n_words) based (rpp) ptr;
dcl  num_matches (n_words) based (nmp) fixed bin;
dcl  line_data_ptr (n_words) ptr based (ldpp);
dcl  line_data_count (n_words) fixed bin based (ldcp);
dcl 1 line_data (line_data_count (wordx)) aligned based (line_data_ptr (wordx)),
    2 line_num fixed bin,
    2 line_index fixed bin (24);
dcl  line_data_kludge (2 * line_data_count (wordx)) fixed bin based (line_data_ptr (wordx));
dcl  line_data_mover (old_count) fixed bin (71) based (old_ptr);
dcl  prev_line_ix (0 : lines-1) fixed bin (24) based (plip);
dcl  input_cs char (input_len) based (input_ptr);
dcl  input_vec (input_len) char (1) unal based (input_ptr);
dcl  input_line char (line_len) based (line_ptr);
dcl  output_cs char (output_len) based (output_ptr);
dcl  temp_cs char (temp_len) based (temp_ptr);
dcl  temp_vec (temp_len) char (1) unal based (temp_ptr);
dcl  strip_cs char (1048576) based (strip_ptr);
dcl  strip_vec (1048576) char (1) based (strip_ptr);
dcl  ul_cs char (ul_len) based (ul_ptr);
dcl  ul_vec (ul_len) char (1) based (ul_ptr);
dcl 1 sort_data (max_sort_entries) aligned based (sort_data_ptr),
    2 wordp ptr unal,
    2 wordl fixed bin (24);


/* Static */

dcl  line_data_incr fixed bin int static init (50);
dcl  delims char (5) aligned int static init (" 	
");						/* SPACE, HT, VT, FF, NL */
dcl  NL char (1) aligned int static init ("
");
dcl  letters char (52) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz");

dcl (error_table_$noarg,
     error_table_$dirseg,
     error_table_$key_duplication,
     error_table_$no_key,
     error_table_$no_record,
     error_table_$short_record,
     error_table_$end_of_info,
     error_table_$noentry,
     error_table_$wrong_no_of_args,
     error_table_$badopt,
     error_table_$inconsistent,
     error_table_$zero_length_seg,
     error_table_$entlong) fixed bin (35) ext;

dcl  sys_info$max_seg_size fixed bin (24) ext static;


/* Conditions */

dcl  cleanup condition;


/* Builtins */

dcl (addr, divide, index, hbound, length, max, min, mod, null, reverse, rtrim, search, substr, unspec, verify) builtin;


/* Entries */

dcl  absolute_pathname_ entry (char(*), char(*), fixed bin(35));
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  delete_$path entry (char(*), char(*), bit(36) aligned, char(*), fixed bin(35));
dcl  initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  terminate_file_ entry (ptr, fixed bin(24), bit(*), 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_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35));
dcl  hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (24));
dcl  alphabetize_strings_ entry (ptr, fixed bin (24));
dcl  (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35));
dcl  unique_chars_ entry (bit(*)) returns(char(15));
dcl  get_pdir_ entry() returns(char(168));
dcl  pathname_ entry (char(*), char(*)) returns(char(168));
dcl  iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35));
dcl  iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35));
dcl  iox_$close entry (ptr, fixed bin(35));
dcl  iox_$detach_iocb entry (ptr, fixed bin(35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin(35));	  
dcl  iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));		  
dcl  iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35));
dcl  iox_$position entry (ptr, fixed bin, fixed bin(21), fixed bin(35));
dcl  iox_$control entry (ptr, char(*), ptr, fixed bin(35));
%page;
	cwl_cmd = "1"b;				/* remember we came in via the create_wordlist entry */
	whoami = "create_wordlist";
	arg_syntax = "path {-brief} {-from N} {-to N} {-header} {-no_sort} {-no_exclude} {-no_control_lines}";
	goto join;

locate_words: lw: entry;

	lw_cmd = "1"b;				/* remember we came in via the locate_words entry */
	whoami = "locate_words";
	arg_syntax = "path words {-from N} {-to N} {-header} {-lines N | -long | -count} {-word word}";
	goto join;

revise_words: rw: entry;

	rw_cmd = "1"b;				/* remember we came in via the revise_words entry */
	whoami = "revise_words";
	arg_syntax = "path word1 rev1 ... wordN revN {-from N} {-to N} {-header} {-lines N | -long | -brief} {-word word rev}";
join:	call cu_$arg_count (n_args);			/* get number of arguments */
	if cwl_cmd & n_args < 1
	then do;
noarg:	     code = error_table_$noarg;
usage:	     call com_err_ (code, whoami, "^/Usage:  ^a ^a", whoami, arg_syntax);
	     return;
	end;
	if lw_cmd & n_args < 2
	then goto noarg;
	if rw_cmd & n_args < 3
	then goto noarg;

	if ^cwl_cmd
	then do;
	     if lw_cmd
	     then n_words = n_args;			/* upper bound on number of words */
	     else n_words = divide (n_args, 2, 17, 0);
	     on cleanup call cleaner;
	     call get_system_free_area_ (system_area_ptr);
	     allocate match_len in (system_area);
	     allocate match_ptr in (system_area);
	     if rw_cmd
	     then do;
		allocate rev_len in (system_area);
		allocate rev_ptr in (system_area);
	     end;
	end;

	temp_dir = get_pdir_ ();
	n_words = 0;
	do argno = 1 by 1 to n_args;
	     call cu_$arg_ptr (argno, ap, al, code);
	     if index (arg, "-") ^= 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 cwl_cmd then do;
		     code = error_table_$wrong_no_of_args;
		     goto usage;
		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 rw_cmd then do;
			     rev_ptr (j + 1) = rev_ptr (j);
			     rev_len (j + 1) = rev_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 rw_cmd then do;
			call next_arg;
			rev_ptr (wordx) = ap;
			rev_len (wordx) = al;
		     end;
		end;
	     end;
	     else if arg = "-word" then do;
		call next_arg;
		goto insert_word;
	     end;
	     else if cwl_cmd & (arg = "-no_sort" | arg = "-ns") then no_sort_opt = "1"b;
	     else if ^lw_cmd & (arg = "-bf" | arg = "-brief") then brief_opt = "1"b;
	     else if arg = "-he" | arg = "-header" then header_opt = "1"b;
	     else if ^cwl_cmd & (arg = "-lg" | arg = "-long") then long_opt = "1"b;
	     else if cwl_cmd & (arg = "-ne" | arg = "-no_exclude") then no_exclude_opt = "1"b;
	     else if lw_cmd & (arg = "-ct" | arg = "-count") then count_opt = "1"b;
	     else if ^lw_cmd & (arg = "-temp_dir" | arg = "-td") then do;
		     call next_arg;
		     call absolute_pathname_ (arg, temp_dir, code);
		     if code ^= 0 then do;
			call com_err_ (code, whoami, "^a", arg);
			return;
			end;
		     end;
	     else if arg = "-ncl" | arg = "-no_control_lines"
	     then no_control_opt = "1"b;
	     else if arg = "-fm" | arg = "-from"
	     then do;
		call next_arg_num (from_line);
		if code ^= 0 | from_line < 1
		then do;
bad_line:		     call com_err_ (0, whoami, "Invalid line number.  ^a", arg);
		     return;
		end;
	     end;
	     else if arg = "-to"
	     then do;
		call next_arg_num (to_line);
		if code ^= 0 | to_line < 1
		then goto bad_line;
	     end;
	     else if ^cwl_cmd & (arg = "-lines" | arg = "-li")
	     then do;
		if argno + 1 > n_args then lines = 0;
		else do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, ap, al, code);
		     lines = cv_dec_check_ (arg, code);
		     if code ^= 0 then do;
			lines = 0;
			code = 0;
			argno = argno - 1;
		     end;
		end;
		if lines < 0
		then do;
		     call com_err_ (0, whoami, "Invalid line count.  ^a", arg);
		     return;
		end;
	     end;
	     else do;
		call com_err_ (error_table_$badopt, whoami, "^a", arg);
		return;
	     end;
	end;

	if ^got_pname				/* pathname missing */
	| (^cwl_cmd & n_words = 0)			/* match word(s) missing */
	then goto noarg;

	if (long_opt | lines ^= -1) & (count_opt | brief_opt)
	then do;
	     call com_err_ (error_table_$inconsistent, whoami, "^[-count^;-brief^] and ^[-long^;-lines^] are mutually exclusive.", count_opt, long_opt);
	     return;
	end;
	if lines > -1
	then long_opt = "1"b;
	else lines = 0;

	if ^cwl_cmd 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);
	     end;
	     if invalid_sw then return;

	     allocate num_matches in (system_area);
	     num_matches (*) = 0;
	     if ^count_opt
	     then do;
		allocate line_data_ptr in (system_area);
		allocate line_data_count in (system_area);
		line_data_count (*) = 0;
	     end;
	     if lines > 0
	     then do;
		allocate prev_line_ix in (system_area);
		prev_line_ix (*) = 1;
	     end;
	end;
	else on cleanup call cleaner;

	input_ename = ename;			/* save for later */
	input_dname = dname;

	call hcs_$status_minf (dname, ename, 1, type, bc, code);
	if code ^= 0 then call err_exit;

	if type = 2
	then if bc = 0				/* directory */
	     then do;
		code = error_table_$dirseg;		/* can't do anything with it */
		call err_exit;
		end;
	     else msf = "1"b;			/* directory with bit count = MSF */
	else msf = "0"b;

/* If the input is an MSF, then we have to use vfile_ rather thanpointer I/O
   to read it. There is also a possibility that if we are doing a revise_words
   on a non-MSF, the changes could involve growing the input segment to an
   MSF. That is handled later. */

	if msf then call open_file (dname, ename, inputp, Stream_input);
	else do;					/* initiate input seg */
	     call initiate_file_ (dname, ename, R_ACCESS, input_ptr, bc, code);
	     if input_ptr = null then call err_exit;
	     input_len = divide (bc, 9, 21, 0);		/* get character count */
	     if input_len = 0 then do;
		code = error_table_$zero_length_seg;
		call err_exit;
		end;
	     end;

	if cwl_cmd then do;				/* if create_wordlist entry */
	     call hcs_$get_uid_file (input_dname, input_ename, uid_in, code);
	     if code ^= 0 then call err_exit;

	     i = length (rtrim (ename));
	     if i > 29 then do;			/* make sure we can add ".wl" suffix to entry name */
		call com_err_ (error_table_$entlong, whoami, "^a.wl", ename);
		goto finish;
	     end;
	     substr (ename, i+1, 3) = ".wl";

	     dname = get_wdir_ ();

	     call hcs_$get_uid_file (dname, ename, uid_out, code);
	     if code ^= 0
	     then if code ^= error_table_$noentry
		then call err_exit;

	     if uid_in = uid_out then do;
		call com_err_ (0, whoami, "Input and output files are the same. ^a and ^a.",
		     pathname_ (input_dname, input_ename), pathname_ (dname, ename));
		goto finish;
		end;

	     if msf then do;
		call open_file (dname, ename, outputp, Stream_output);
		if ^no_sort_opt then do;
		     call open_file ("", "", sortp, Keyed_sequential_update);
		     sort_dir = dname;
		     sort_name = ename;
		     end;
		end;
	     else do;
		call hcs_$make_seg (dname, ename, "", 01010b, output_ptr, code); /* create output seg in working dir */
		if output_ptr = null then call err_exit;
		end;
	end;
	else if rw_cmd & msf then do;			/* revise_words needs to change the source file */
		call open_file ("", "", outputp, Stream_output);
		sort_dir = dname;			/* save path for deletion */
		sort_name = ename;
		end;

	call get_temp_segments_ (whoami, temp_ptr_array, code);
	if code ^= 0
	then do;
	     call com_err_ (code, whoami, "Cannot get temporary segments.");
	     goto finish;
	end;

	ul_ptr = temp_ptr_array (1);			/* place to assemble de-underlined words */
	if msf
	then input_ptr, line_ptr = temp_ptr_array (2);	/* place to read vfile_ input */
	else do;
	     sort_data_ptr = temp_ptr_array (2);	/* used for sorting */
	     max_sort_entries = divide (sys_info$max_seg_size, 2, 24, 0);
	     end;
	if rw_cmd then temp_ptr = temp_ptr_array (3);

	if header_opt
	then call ioa_ ("^/^-^a^/", pathname_ (input_dname, input_ename));

%page;
	prevx = lines -1;
	line_ix = 1;
	rev_line_ix = 1;
	line_diff = 0;
	output_words = 0;				/* init word counter */
	output_len = 0;
	temp_len = 0;				/* init length of temp seg */
	last = 0;					/* init index of last input seg char moved to temp seg */

	changed_lines = "0"b;			/* didnt change anything yet for revise_words */
	output_record_number = 0;

	if msf then do;
	     max_line_len = sys_info$max_seg_size * 4;
	     call iox_$get_line (inputp, line_ptr, max_line_len, input_len, code);
	     end;

	do line = 1 by 1;				/* scan input one line at a time */
	     if msf
	     then if code ^= 0
		then if code = error_table_$end_of_info
		     then goto end_of_data;
		     else if code = error_table_$short_record
			then goto msf_read;		/* no trailing NL */
			else call err_exit;
		else do;
msf_read:		     line_ix = 1;			/* fake indices so that later code works */
		     rev_line_ix = 1;		/*   for both cases */
		     output_len = 0;
		     temp_len = 0;
		     last = 0;
		     end;
	     else if line_ix > input_len
		then goto end_of_data;

	     line_len = index (substr (input_cs, line_ix), NL) -1;
	     if line_len = -1			/* input does not end with NL */
	     then line_len = input_len - line_ix + 1;	/* do it anyway */

	     if line < from_line
	     then goto next_line;
	     if to_line ^= 0 & line > to_line
	     then goto end_of_data;

	     if line_len = 0
	     then goto next_line;

	     line_ptr = addr (input_vec (line_ix));

	     if no_control_opt
	     then if substr (input_line, 1, 1) = "."
		then goto next_line;

	     strip_ptr = line_ptr;
	     delim_ix = 1;				/* prepare to look at first char of line */

	     do while (delim_ix <= line_len);		/* scan until line exhausted */
		delim_len = verify (substr (input_line, delim_ix), delims) -1; /* skip delimiters */
		if delim_len = -1
		then delim_len = line_len -delim_ix +1;

		token_ix = delim_ix + delim_len;	/* advance index past delimiters */
		if token_ix > line_len
		then goto next_line;
		else if token_ix = line_len
		then token_len = 1;
		else do;
		     token_len = search (substr (input_line, token_ix+1), delims); /* find end-of-token delimiter */
		     if token_len = 0 then		/* no delimiter */
			token_len = line_len + 1 - token_ix; /* use end of line as delimiter */
		end;

		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_spaces = 0;
		     strip_ptr = ul_ptr;		/* prepare to strip words in ul_cs */
		     i = 1;
		     do while (i <= ul_len);		/* rescan token to pick out words */
			n = verify (substr (ul_cs, i), " "); /* skip spaces */
			if n = 0 then goto end_of_ul;
			i = i + n -1;		/* advance index past spaces */
			ul_spaces = ul_spaces + n -1; /* remember number of spaces seen */
			n = index (substr (ul_cs, i), " ") -1; /* find next space */
			if n = -1 then		/* no more spaces */
			     n = ul_len +1 -i;	/* use end of token as delimiter */
			strip_ix = i;
			strip_len = n;
			call strip_punc;
			if cwl_cmd then call output_word;
			else call test_word;
			i = i + n;
		     end;
end_of_ul:	     if cwl_cmd
		     then ul_ptr = addr (ul_vec (ul_len + 1)); /* move buffer ahead for next de-underlined word */
		     strip_ptr = line_ptr;
		end;

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

next_token:	delim_ix = token_ix + token_len;	/* advance index past current token */
	     end;
next_line:
	     if lines > 0				/* must remember previous line indices */
	     then do;				/* use prev_line_ix array as circular buffer */
		prevx = mod (prevx + 1, lines);	/* advance circular buffer index */
		if msf & rw_cmd
		then do;
		     prev_line_ix (prevx) = output_record_number;
		     output_record_number = output_record_number + 1;
		     end;
		else do;				/* fixed for phx20562, use rev_line_ix */
						/* only if revise_word command */
		     if ^rw_cmd then prev_line_ix (prevx) = line_ix;
		     else prev_line_ix (prevx) = rev_line_ix;
		     end;
	     end;

	     if msf
	     then do;
		if rw_cmd then do;
		     if temp_len ^= 0 then do;	/* write out line to temp work file */
			call iox_$put_chars (outputp, temp_ptr, temp_len, code);
			if code ^= 0 then call err_exit;
			if last < input_len		/* copy end of input line */
			then call iox_$put_chars (outputp, addr (input_vec (last+1)), input_len-last, code);
			end;
		     else call iox_$put_chars (outputp, line_ptr, input_len, code);
		     if code ^= 0 then call err_exit;
		     end;

		call iox_$get_line (inputp, line_ptr, max_line_len, input_len, code);
		end;
	     else do;
		line_ix = line_ix + line_len + 1;

		if rw_cmd & long_opt
		then do;
		     rev_line_len = line_len + line_diff;    /* compute length of revised line */
		     rev_line_ix = rev_line_ix + rev_line_len +1; /* compute index of next revised line */
		     line_diff = 0;
		     end;
		end;
	end;
%page;
end_of_data:

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

	if rw_cmd then do;
	     if msf then do;
		if changed_lines
		then do;
		     code = 0;
		     do while (code = 0);		/* copy rest of input file */
			call iox_$get_line (inputp, line_ptr, max_line_len, input_len, code);
			if code = 0 | code = error_table_$short_record
			then call iox_$put_chars (outputp, line_ptr, input_len, code);
			end;
		     if code ^= error_table_$end_of_info then call err_exit;

		     call iox_$close (inputp, code);	/* close input file */
		     call close_file (outputp);
		     outputp = null;

		     call copy_temp_file (dname, ename, get_wdir_ (), input_ename);

		     call iox_$open (inputp, 1, "0"b, code); /* open input file for reading */
		     if code ^= 0 then call err_exit;
		     end;
		else call close_file (outputp);	/* don't need temp work file anymore */
		end;
	     else if last > 0 then do;
		     n = input_len - last;
		     if n > 0 then do;
			substr (temp_cs, temp_len+1, n) = substr (input_cs, last+1, n);
			temp_len = temp_len + n;
			end;
		     output_ptr = input_ptr;
		     substr (output_ptr -> temp_cs, 1, temp_len) = substr (temp_cs, 1, temp_len);
		     input_len, output_len = temp_len;
		     end;
	end;

	if cwl_cmd then do;				/* if create_wordlist entry */
	     if ^brief_opt then
		call ioa_ ("total number of words = ^d", output_words); /* print word count */
	     if ^no_sort_opt then do;			/* if nosort option not requested */
		if msf then call copy_keyed_file;
		else do;
		     call alphabetize_strings_ (sort_data_ptr, output_words); /* alphabetize the words */
		     call copy_sorted_words;		/* copy sorted words to output seg */
		     end;
		if ^brief_opt then
		     call ioa_ ("number of unique words = ^d", output_words); /* print unique word count */
	     end;
	end;

	else do;
	     if msf then do;
		current_record = 1;
		call iox_$position (inputp, -1, 0, code);    /* BOF */
		end;

	     do wordx = 1 to n_words;			/* print results for locate_words or revise_words */
		if count_opt
		then call ioa_ ("^d match^[es^] for ^a", num_matches (wordx), (num_matches (wordx) ^= 1), match_word);
		else if rw_cmd & ^long_opt
		then do;
		     if num_matches (wordx) = 0
		     then call ioa_ ("No revisions for ^a", match_word);
		     else if ^brief_opt
		     then call ioa_ ("^d revision^[s^] for ^a", num_matches (wordx), (num_matches (wordx) ^= 1), match_word);
		end;
		else if lw_cmd & ^long_opt
		then do;
		     if num_matches (wordx) = 0
		     then call ioa_ ("^20a NONE", match_word);
		     else do;
			line_data_count (wordx) = num_matches (wordx);
			do i = 1 by 20 to 2*num_matches (wordx);
			     call ioa_ ("^[^20a^;^20x^s^]^vs^10(^d^x^s^)", i = 1, match_word, i-1, line_data_kludge);
			end;
		     end;
		end;
		else call print_long;		/* print lines of text */
		end;
	end;


	if (cwl_cmd | (rw_cmd & last > 0)) & ^msf then do;
	     substr (output_cs, output_len+1, 4 - mod (output_len, 4)) = "   "; /* set to NUL */
	     call terminate_file_ (output_ptr, 9*output_len, TERM_FILE_TRUNC_BC, code); /* truncate output seg */
	     if code ^= 0 then call err_exit;
	end;

finish:	call cleaner;
exit:	return;

err_exit:						/* moan and return */
     proc;

	call com_err_ (code, whoami, "^a", pathname_ (input_dname, input_ename));
	goto finish;
	end err_exit;
%page;
next_arg:	proc;					/* fetches next command arg */

	     argno = argno + 1;
	     if argno > n_args
	     then goto noarg;

	     call cu_$arg_ptr (argno, ap, al, code);

	end next_arg;

next_arg_num: proc (num);				/* fetches next arg, converts to fixed bin */

dcl  num fixed bin (24);


	     call next_arg;
	     num = cv_dec_check_ (arg, code);

	end next_arg_num;
%page;
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 goto bad_word;
	     call check_ul;				/* check word for underlining */
	     if ul_sw then goto bad_word;

	end validate_word;
%page;
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 including PAD (177) */
	     if n = -1 then goto 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;
%page;
check_ul:	proc;

/* checks word for continuous underlining
   de-underlined string is assembled in ul_cs
   underline without adjacent backspace -> space
   the input word is given by substr(strip_cs, word_ix, word_len)
*/

dcl (i, j) fixed bin;
dcl  end_word_ix fixed bin;

	     ul_sw = "0"b;				/* assume word is not underlined */
	     if index (substr (strip_cs, word_ix, word_len), "") ^= 0
	     then do;				/* word contains backspaces, check for underlining */
		i = word_ix;
		end_word_ix = word_ix + word_len - 1;
		do j = 1 by 1 while (i <= end_word_ix); /* scan token */
		     if i+2 > end_word_ix then goto check_single_ul;
		     if substr (strip_cs, i, 2) = "_"
		     then do;
			substr (ul_cs, j, 1) = substr (strip_cs, i+2, 1);
			i = i + 3;
		     end;
		     else if substr (strip_cs, i+1, 2) = "_"
		     then do;
			substr (ul_cs, j, 1) = substr (strip_cs, i, 1);
			i = i +3;
		     end;
		     else
check_single_ul:	     if substr (strip_cs, i, 1) = "_"
		     then do;
			substr (ul_cs, j, 1) = " ";
			i = i + 1;
		     end;
		     else return;			/* not standard underlined string */
		end;
		ul_sw = "1"b;			/* yup, that was an underlined string */
		ul_len = j - 1;			/* remember length of de-underlined string */
	     end;

	end check_ul;
%page;
output_word: proc;

/* Move the word specified to an output file. If MSF input, then if sorting the
   word goes to a keyed vfile_, else put in stream output file. If ^MSF,
   then if sorting, word ptr and length goes to sort_data array, else put in
   output seg with NL appended. Since we're eliminating white space from the
   input file and words are delimited by at least 1 white space character,
   if the input is not an MSF, the output cannot be. Words containing no
   letters are excluded from the wordlist unless -no_exclude specified.
*/

dcl  1 aki,
       2 flags aligned,
         3 input_key bit (1) unaligned init ("1"b),
         3 input_desc bit (1) unaligned init ("1"b),
         3 mbz bit (34) unaligned init ("0"b),
       2 descrip fixed bin (35) init (0),
       2 key_len fixed bin,
       2 key char (256);

	     if ^no_exclude_opt
	     then if search (substr (strip_cs, word_ix, word_len), letters) = 0
		then return;

	     output_words = output_words + 1;
	     if msf
	     then if no_sort_opt
		then do;
		     call iox_$put_chars (outputp, addr (strip_vec (word_ix)), (word_len), code);
		     if code ^= 0 then call err_exit;
		     call iox_$put_chars (outputp, addr (NL), length (NL), code);
		     if code ^= 0 then call err_exit;
		     end;
		else do;
		     aki.key_len = min (256, word_len);
		     aki.key = substr (strip_cs, word_ix, word_len);
		     call iox_$control (sortp, "add_key", addr (aki), code);
		     if code ^= 0
		     then if code = error_table_$key_duplication
			then ;			/* allowable */
			else call err_exit;
		end;
	     else if no_sort_opt
		then do;
		     substr (output_cs, output_len + 1, word_len) = substr (strip_cs, word_ix, word_len);
		     output_len = output_len + word_len;
		     substr (output_cs, output_len + 1, 1) = NL;
		     output_len = output_len + 1;
		     end;
		else do;
		     if output_words > hbound (sort_data, 1)
		     then do;
			call com_err_ (0, whoami, "Number of words exceeds sorting limit of ^d.", hbound (sort_data, 1));
			goto finish;
		     end;

		     sort_data (output_words).wordp = addr (strip_vec (word_ix));
		     sort_data (output_words).wordl = word_len;
		     end;

	return;
	end output_word;
%page;
test_word: proc;

/* tests if current word matches any of the match words
   if a match is found, the action taken depends on whether locate_words or revise_words was called
   for locate_words, the line number and line index of the current word is saved
   for revise_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 and line index of the revised word is saved
*/

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

/* Since the match_word array is sorted, 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 count_opt
		     then return;
		     if rw_cmd then do;		/* move chars before current word to temp seg and revise word */
			if ul_sw then do;		/* word was de-underlined */
			     word_ix = ul_ix + ul_spaces + 3* (word_ix-1-ul_spaces); /* get index of original word */
			     word_len = 3 * word_len; /* get length of original word */
			end;
			word_ix = word_ix + line_ix -1;
			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 */
			changed_lines = "1"b;
			if ^ul_sw then do;
			     substr (temp_cs, temp_len+1, length (rev_word)) = rev_word; /* drop in the revision */
			     temp_len = temp_len + length (rev_word);
			end;
			else do i = 1 to length (rev_word); /* underline the revision canonically */
			     if substr (rev_word, i, 1) < "_" then do;
				substr (temp_cs, temp_len +1, 1) = substr (rev_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 (rev_word, i, 1);
				temp_len = temp_len +1;
			     end;
			end;
			if long_opt
			then do;			/* compute difference between original and revised line lengths */
			     line_diff = line_diff + length (rev_word) - word_len;
			     goto save_line_number;
			end;
		     end;
		     else do;
save_line_number:
			if mod (num_matches (wordx), line_data_incr) = 1
			then do;			/* allocate more space for line data */
			     old_count = line_data_count (wordx);
			     if old_count > 0
			     then old_ptr = line_data_ptr (wordx);
			     line_data_count (wordx) = old_count + line_data_incr;
			     allocate line_data in (system_area);
			     if old_count > 0
			     then do;
				line_data_ptr (wordx) -> line_data_mover = line_data_mover;
				free line_data_mover in (system_area);
			     end;
			end;
			line_num (num_matches (wordx)) = line; /* remember line number */
			if long_opt
			then if msf		/* don't need line_index for MSFs */
			     then line_index (num_matches (wordx)) = 0;
			     else do;		/* remember line index */
				if lines = 0
				then if lw_cmd
				     then i = line_ix;
				     else i = rev_line_ix;
				else i = prev_line_ix (mod (prevx + 1, lines)); /* use oldest line in circular buffer */
				line_index (num_matches (wordx)) = i;
				end;
		     end;
		end;

	end test_word;
%page;
print_long: proc;					/* prints output for -long option */

dcl (i, j, k) fixed bin (21);
dcl  last_line_printed fixed bin (21);
dcl  j_contains_match bit(1);
dcl  NL_index fixed bin (21);
  
	     if n_words ^= 1
	     then if lw_cmd
		then call ioa_ ("^2/^a^/", match_word);
		else call ioa_ ("^2/^a^/", rev_word);

	     if num_matches (wordx) = 0
	     then do;
		call ioa_ ("^-NONE");
		return;
	     end;

	     last_line_printed = 0;
	     do i = 1 to num_matches (wordx);		/* print line containing each match */
		if i > 1
		then if line_num (i) = line_num (i-1)
		     then goto next_line_num;	/* don't print same line twice */
		line = line_num (i);
		line_ix = line_index (i);
		do j = max (line - lines, 1) to line + lines;	/* print surrounding lines */
		     if ^msf
		     then if line_ix > input_len
			then goto next_line_num;

		     if i < num_matches (wordx)
		     then if (j = line_num (i+1)) & (j ^= line)
			then goto next_line_num;	/* don't print line for next match yet */

		     if msf then do;
			if j ^= current_record
			then do;			/* find record with relative positioning */
			     call iox_$position (inputp, 0, j - current_record, code);
			     if code ^= 0 & code ^= error_table_$short_record then call err_exit;
			     end;
			call iox_$get_line (inputp, line_ptr, max_line_len, line_len, code);
			if code ^= 0
			then if code = error_table_$end_of_info
			     then goto next_line_num;
			     else call err_exit;

			current_record = j + 1;	/* reading advanced by 1 record */
		          NL_index = index (input_line, NL); /* look for NL */
			if NL_index ^= 0
			then line_len = NL_index - 1; /* we have one, bump back 1 char so ioa_ doesn't print 2 NLs */
			end;
		     else do;
			line_ptr = addr (input_vec (line_ix));
			line_len = index (substr (input_cs, line_ix), NL) -1;
			if line_len = -1
			then line_len = input_len - line_ix + 1;
			end;
		     if j > last_line_printed
		     then do;
			do k = i to num_matches (wordx);
			     if line_num (k) = j 
			     then do;
				j_contains_match = "1"b;
				k = num_matches (wordx);
			     end;
			     else j_contains_match = "0"b;
			end;
			call ioa_ ("^6d ^[*^; ^]  ^a", j, ((lines > 0) & ((j = line) | (j_contains_match = "1"b))), input_line);
			last_line_printed = j;
		     end;
		     line_ix = line_ix + line_len + 1;
		end;
next_line_num:
	     end;

	end print_long;
%page;
copy_keyed_file:
     proc;

dcl  1 gki,
       2 flags aligned like gk_header.flags,
       2 descrip fixed bin (35) aligned,
       2 key_len fixed bin,
       2 key char (256);

	unspec (gki) = "0"b;

	dname = sort_dir;
	ename = sort_name;
	call iox_$position (sortp, -1, 0, code);	/* to BOF */
	if code ^= 0 then call err_exit;

	code, output_words = 0;
	do while (code = 0);
	     call iox_$control (sortp, "get_key", addr (gki), code);
	     if code = 0 then do;
		output_words = output_words + 1;
		call iox_$put_chars (outputp, addr (gki.key), (gki.key_len), code);
		if code ^= 0 then call err_exit;
		call iox_$put_chars (outputp, addr (NL), length (NL), code);
		if code ^= 0 then call err_exit;

		call iox_$position (sortp, 0, 1, code);
		if code = 0 then call iox_$control (sortp, "get_key", addr (gki), code);
		end;
	     end;
	if code = error_table_$end_of_info | code = error_table_$no_key | code = error_table_$no_record
	then ;					/* allowable errors */
	else call err_exit;

	return;
	end copy_keyed_file;
%page;
copy_sorted_words: proc;

/* copies sorted words from temp seg to output seg
   eliminates duplications
*/

dcl  i fixed bin (24);
dcl  unique_words fixed bin (24);
dcl (wordp, last_wordp) ptr;
dcl (wordl, last_wordl) fixed bin (24);
dcl  sort_string char (wordl) based (wordp);
dcl  last_sort_string char (last_wordl) based (last_wordp);


	     unique_words = 0;
	     last_wordl = 0;

	     do i = 1 to output_words;
		wordp = sort_data (i).wordp;
		wordl = sort_data (i).wordl;

		if wordl = last_wordl
		then if sort_string = last_sort_string
		     then goto next_word;
		unique_words = unique_words + 1;

		last_wordl = wordl;
		last_wordp = wordp;

		substr (output_cs, output_len + 1, wordl) = sort_string;
		output_len = output_len + wordl;
		substr (output_cs, output_len + 1, 1) = NL;
		output_len = output_len + 1;

next_word:
	     end;

	     output_words = unique_words;

	end copy_sorted_words;
%page;
cleaner:	proc;					/* cleanup handler */

	     if plip ^= null then do;
		free prev_line_ix in (system_area);
		plip = null;
	     end;

	     if ldpp ^= null then do;
		do wordx = 1 to n_words;
		     if line_data_count (wordx) > 0
		     then free line_data in (system_area);
		end;
		free line_data_ptr in (system_area);
		free line_data_count in (system_area);
		ldpp, ldcp = null;
	     end;
	     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 rpp ^= null then do;
		free rev_ptr in (system_area);
		rpp = null;
	     end;
	     if rlp ^= null then do;
		free rev_len in (system_area);
		rlp = null;
	     end;

	     if temp_ptr_array (1) ^= null
	     then call release_temp_segments_ (whoami, temp_ptr_array, code);

	     if msf then do;
		call close_file (inputp);
		call close_file (outputp);
		if ^no_sort_opt & cwl_cmd then do;
		     call close_file (sortp);
		     call delete_$path (sort_dir, sort_name, "101111"b, whoami, code);
		     if code ^= 0 then call com_err_ (code, whoami, "Deleting ^a.", pathname_ (sort_dir, sort_name));
		     end;
		end;
	     else do;				/* terminate input  output segs */
		if input_ptr = output_ptr
		then input_ptr = null;
		do input_ptr = input_ptr, output_ptr;
		     if input_ptr ^= null then call terminate_file_ (input_ptr, 0, TERM_FILE_TERM, (0));
		     end;
		end;

	return;
	end cleaner;
%page;
copy_temp_file:
     proc (input_dir, input_name, output_dir, output_name);

/* Copy the contents of the input file to the output file. This is only used
   in MSF mode. */

dcl  (input_dir, output_dir) char (*) parameter;
dcl  (input_name, output_name) char (*) parameter;
dcl  buffer char (1024);

dcl 1 co like copy_options;

dcl  copy_ entry (ptr);

	co.version = COPY_OPTIONS_VERSION_1;
	co.caller_name = whoami;
	co.source_dir = input_dir;
	co.source_name = input_name;
	co.target_dir = output_dir;
	co.target_name = output_name;
	unspec (co.flags) = "0"b;
	co.flags.delete = "1"b;			/* delete source when done */
	co.flags.force = "1"b;			/* try to force access if needed */

	unspec (co.copy_items) = "0"b;
	co.copy_items.update = "1"b;

	call copy_ (addr(co));			/* copy work file to input file */
	if co.target_err_switch
	then call err_exit;				/* errors reported by sub_err_ */

	return;
	end copy_temp_file;
%page;
open_file:
     proc (dir, ent, iocbp, mode);

dcl  (dir, ent) char (*) parameter;
dcl  iocbp ptr parameter;
dcl  mode fixed bin parameter;
dcl  atd char (256) varying;
dcl  switchname char (32) varying;

	dname = dir;
	if dname = "" then dname = temp_dir;
	ename = ent;
	if ename = "" then ename = unique_chars_ ("0"b) || "." || whoami;

	atd = "vfile_ " || rtrim (dname);
	atd = atd || ">";
	atd = atd || rtrim (ename);

	switchname = unique_chars_ (""b) || ".";
	switchname = switchname || whoami;

	call iox_$attach_name ((switchname), iocbp, (atd), null, code);
	if code ^= 0 then call err_exit;

	call iox_$open (iocbp, mode, "0"b, code);
	if code ^= 0 then call err_exit;

	return;
	end open_file;

close_file:
     proc (iocbp);

dcl  iocbp ptr parameter;

	if iocbp ^= null then do;
	     call iox_$close (iocbp, (0));
	     call iox_$detach_iocb (iocbp, (0));
	     call iox_$destroy_iocb (iocbp, (0));
	     end;

	return;
	end close_file;
%page;
%include copy_options;
%include copy_flags;
%include ak_info;
%include access_mode_values;
%include terminate_file;
%include iox_modes;

     end create_wordlist;



		    find_dict_word_.pl1             02/16/88  1448.4r w 02/16/88  1411.9      108522


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


find_dict_word_: proc (pm_word, pm_control, pm_word_found, pm_descrip, pm_dict_path, pm_err_p, pm_code);

/* This procedure finds a specified word in the sequence of
   dictionaries defined by the "dict" search list.
*/

/* Coded 10/17/77 by J. Stern */
/* Modified 07/07/81 by PWB to allow option of whether or not a bad dict in 
		        search list will cause processing to halt, and 
		        provide a mechanism to report those errors.
*/

/* Parameters */

dcl  pm_word char (*);
dcl  pm_control bit (36) aligned;
dcl  pm_word_found char (256);
dcl  pm_descrip bit (36) aligned;
dcl  pm_dict_path char (168);
dcl  pm_err_p ptr;					/* input -> null = abort if invalid dict found */
dcl  pm_code fixed bin (35);


/* Automatic */

dcl  aborting bit (1);
dcl  ndict fixed bin;
dcl  dictx fixed bin;
dcl  prev_level fixed bin;
dcl  forget_sw bit (1) aligned;
dcl  dict_iocbps_p ptr;
dcl  good_dicts_p ptr;
dcl  switch char (32);
dcl  atd char (256);
dcl  word char (256) varying;
dcl  info_ptr ptr;

dcl 1 fdw_control aligned,
    2 exact_match bit (1) unal,
    2 mbz bit (35) unal;

dcl 1 get_key_info aligned,
    2 flags like gk_header.flags,
    2 descrip bit (36) aligned,
    2 key_len fixed bin,
    2 key char (256);


/* Based */

dcl  current_sl_index fixed bin (71) based (sl_info.change_index_p);
dcl  system_area area based (system_area_p);
dcl  dict_iocbps (ndict) ptr based (dict_iocbps_p);
dcl  good_dicts (ndict) bit (1) unal based (good_dicts_p);
	       
dcl 1 bad_dicts aligned based (pm_err_p),
      2 n fixed bin,
      2 entry (0 refer (bad_dicts.n)),
        3 ecode fixed bin (35),
        3 path char (168) unal;

/* Static */

dcl  system_area_p ptr int static init (null);
dcl  level fixed bin int static init (0);
dcl  have_dictionaries bit (1) aligned int static init ("0"b);
dcl  static_sl_info_p ptr int static;
dcl  static_dict_iocbps_p ptr int static;
dcl  static_good_dicts_p ptr int static init (null);
	       
dcl  keyed_sequential_input fixed bin int static options (constant) init (8);
dcl  capital_letters char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  small_letters char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");

dcl  error_table_$no_record fixed bin (35) ext static;
dcl  error_table_$no_key fixed bin (35) ext static;
dcl  error_table_$id_not_found fixed bin (35) ext static;
dcl  error_table_$no_search_list fixed bin (35) ext static;
dcl  error_table_$fatal_error	fixed bin(35) ext static;
dcl  error_table_$recoverable_error fixed bin(35) ext static;

dcl  search_list_defaults_$dict ext static;


/* Conditions */

dcl  cleanup condition;


/* Builtins */

dcl (null, rtrim, unspec, verify, search, translate, length, bit, bin, addr, substr, string) builtin;


/* Entries */

dcl  get_system_free_area_ entry (ptr);
dcl  search_paths_$get entry (char (*), bit (36), char (*),
     ptr, ptr, fixed bin, ptr, fixed bin (35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  iox_$attach_name entry (char (*), ptr, char (*), entry, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  sub_err_ entry options (variable);

/* include files */


%include sl_info;

%include ak_info;

/* initialize */

	pm_code = 0;
	pm_dict_path = "";
	aborting = (pm_err_p = null());
	if ^aborting
	     then bad_dicts.n = 0;
	
	if system_area_p = null
	then call get_system_free_area_ (system_area_p);

	forget_sw = "0"b;
	prev_level = level;
	on cleanup call cleaner;
	level = level + 1;

/* open dictionaries from search list if not already open */

	if ^have_dictionaries
	then do;
	     if prev_level > 0
	     then go to cant_do;

	     sl_info_p, dict_iocbps_p = null;
	     forget_sw = "1"b;
	     call get_dictionaries;
	     forget_sw = "0"b;
	end;
	else do;
	     sl_info_p = static_sl_info_p;
	     ndict = sl_info.num_paths;
	     dict_iocbps_p = static_dict_iocbps_p;
	     good_dicts_p = static_good_dicts_p;
	     do dictx = 1 to ndict;
		if ^(good_dicts (dictx))		/* if dict was flagged as bad */
		     then do;			/* in last invocation */
		     forget_sw = "1"b;
		     call retry_bad_dict;		/* then see if it works now */
		     forget_sw = "0"b;
		end;
	     end;
	end;

/* reopen dictionaries if search list has changed */

	if current_sl_index ^= sl_info.change_index
	then do;
	     if prev_level > 0
	     then go to cant_do;

	     if ^aborting
		then bad_dicts.n = 0;
	     forget_sw = "1"b;
	     call forget_dictionaries;
	     call get_dictionaries;
	     forget_sw = "0"b;
	end;

/* scan the dictionaries in order for the specified word */

	if length (rtrim (pm_word)) > 256		/* max word size = 256 */
	then go to not_found;
	word = substr (pm_word, 1, length (rtrim (pm_word)));
	unspec (fdw_control) = pm_control;

	get_key_info.flags.input_key = "1"b;
	get_key_info.input_desc = "0"b;
	get_key_info.desc_code = 0;
	get_key_info.rel_type = 0;
	get_key_info.head_size = 256;
	get_key_info.reset_pos = "0"b;
	get_key_info.pad = ""b;
	get_key_info.version = gk_info_version_0;

	do dictx = 1 to ndict;
	     pm_dict_path = sl_info.pathname (dictx);
	     if word_found ()
	     then go to finish;
	end;

	pm_dict_path = "";

not_found: pm_code = error_table_$id_not_found;

finish:	if pm_code = 0 & ^aborting
	     then if bad_dicts.n ^= 0
	     then pm_code = error_table_$recoverable_error;
	call cleaner;
	return;

cant_do:	call sub_err_ (0, "find_dict_word_", "s", null, (0),
	     "Cannot proceed without harm to prior activation. Please restart or release level ^d.", prev_level);
	go to cant_do;				/* should never get here, but just in case */

cleaner:	proc;					/* cleanup procedure */

	     level = prev_level;
	     if forget_sw
	     then call forget_dictionaries;

	end cleaner;

/* This procedure opens the dictionaries defined in the "dict" search list. */

get_dictionaries: proc;

dcl  i fixed bin;


	     call search_paths_$get ("dict", "111111"b, "", null, system_area_p,
		sl_info_version_1, sl_info_p, pm_code);
	     if pm_code ^= 0
	     then go to finish;

	     ndict = sl_info.num_paths;
	     allocate dict_iocbps in (system_area);
	     allocate good_dicts in (system_area);
	     dict_iocbps (*) = null;
	     good_dicts (*) = "0"b;
	     
	     do i = 1 to ndict;
		pm_dict_path = sl_info.pathname (i);
		switch = unique_chars_ (""b);		/* use unique I/O switch name */
		atd = "vfile_ " || rtrim (sl_info.pathname (i)) || " -share"; /* build attach description */
		call iox_$attach_name (switch, dict_iocbps (i), atd, find_dict_word_, pm_code);
		if pm_code ^= 0
		     then if aborting		/* abort if that's what he wants */
		     then goto finish;
		else call log_bad_dict (i);		/* or just record the bad one */
		else do;
		     call iox_$open (dict_iocbps (i), keyed_sequential_input, "0"b, pm_code);
		     if pm_code ^= 0
			then if aborting		/* same here */
			then goto finish;
		     else do;
			call log_bad_dict (i);	/* and here */
			call iox_$detach_iocb (dict_iocbps (i), pm_code);
		     end;
		     else good_dicts (i) = "1"b;	/* everybody's happy */
		end;
	     end;

	     if (string (good_dicts) = "0"b)		/* he told us not to abort */
		then do;				/* but ALL the dictionaries */
		pm_code = error_table_$fatal_error;	/* are bad */
		goto finish;			/* so abort anyway */
	     end;
	     	     
	     pm_dict_path = "";

	     static_sl_info_p = sl_info_p;
	     static_dict_iocbps_p = dict_iocbps_p;
	     static_good_dicts_p = good_dicts_p;
	     have_dictionaries = "1"b;

	end get_dictionaries;

/* This procedure closes any previously opened dictionaries */

forget_dictionaries: proc;

dcl  i fixed bin;
dcl  code fixed bin (35);


	     have_dictionaries = "0"b;

	     if dict_iocbps_p ^= null
	     then do;
		do i = 1 to ndict;
		     if dict_iocbps (i) ^= null 
		     then do;
			call iox_$close (dict_iocbps (i), code);
			call iox_$detach_iocb (dict_iocbps (i), code);
			dict_iocbps (i) = null;
		     end;
		end;
		free dict_iocbps in (system_area);
		dict_iocbps_p = null;
		free good_dicts in (system_area);
		good_dicts_p = null;
	     end;

	     if sl_info_p ^= null
	     then do;
		free sl_info in (system_area);
		sl_info_p = null;
	     end;

	end forget_dictionaries;

/* This procedure attempts to open a dictionary that was previously flagged as
   bad (probably non-existent).
*/

retry_bad_dict:
	proc;
	
		pm_dict_path = sl_info.pathname (dictx);
		switch = unique_chars_ (""b);		/* use unique I/O switch name */
		atd = "vfile_ " || rtrim (sl_info.pathname (dictx)) || " -share"; /* build attach description */
		call iox_$attach_name (switch, dict_iocbps (dictx), atd, find_dict_word_, pm_code);
		if pm_code = 0
		     then do;
		     call iox_$open (dict_iocbps (dictx), keyed_sequential_input, "0"b, pm_code);
		     if pm_code = 0
			then good_dicts (dictx) = "1"b;
		     else do;
			if aborting 
			     then goto finish;
			call log_bad_dict (dictx);
			call iox_$detach_iocb (dict_iocbps (dictx), pm_code);
		     end;
		end;
		else if aborting
		     then goto finish;
		else call log_bad_dict (dictx);
							
		pm_dict_path = "";

	     end retry_bad_dict;

/* This procedure puts the error code and associated pathname for a bad
   dictionary in the structure bad_dicts so that the calling procedure
   can report the errors. */

log_bad_dict:  proc (which);

dcl which fixed bin parameter;

	     bad_dicts.n = bad_dicts.n + 1;
	     bad_dicts.entry.ecode (bad_dicts.n) = pm_code;
	     bad_dicts.entry.path (bad_dicts.n) = sl_info.pathname (which);
	     pm_code = 0;

	end log_bad_dict;

/* This procedure finds the specified word in the current dictionary.
   If the word does not exist and the exact_match option was not specified,
   the word is checked for standard capitalization.  If standard capitalization
   is found, then the dictionary is consulted again for decapitalized
   forms of the same word.
*/

word_found: proc returns (bit (1) aligned);

	     if ^(good_dicts (dictx))			/* ignore bad dictionary */
		then return ("0"b);

	     get_key_info.key = word;
	     if known_word ()
	     then return ("1"b);

	     if fdw_control.exact_match
	     then return ("0"b);

	     if verify (word, capital_letters) = 0
	     then do;
		if length (word) > 1
		then do;
		     substr (get_key_info.key, 2) = translate (substr (word, 2), small_letters, capital_letters);
		     if known_word ()
		     then return ("1"b);
		end;
check_no_cap:
		get_key_info.key = translate (word, small_letters, capital_letters);
		if known_word ()
		then return ("1"b);
	     end;
	     else if length (word) > 1
	     then if search (substr (word, 1, 1), capital_letters) = 1
		& verify (substr (word, 2), small_letters) = 0
		then go to check_no_cap;

	     return ("0"b);

	end word_found;

/* This procedure determines whether or not a specified word is "known",
   i.e., whether or not the word is defined in the current dictionary.
*/

known_word: proc returns (bit (1) aligned);


	     get_key_info.key_len = 256;
	     call iox_$control (dict_iocbps (dictx), "get_key", addr (get_key_info), pm_code);
	     if pm_code ^= 0
	     then if pm_code = error_table_$no_record | pm_code = error_table_$no_key
		then return ("0"b);
		else go to finish;

	     pm_word_found = get_key_info.key;
	     pm_descrip = get_key_info.descrip;

	     return ("1"b);

	end known_word;


     end find_dict_word_;
  



		    hyphenate_word_.pl1             11/18/82  1707.6rew 11/18/82  1629.2       39924


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


hyphenate_word_: proc (pm_word, pm_space, pm_hpoint, pm_code);

/* This procedure finds the rightmost hyphenation point within
   a specified word that fits within a specified number of spaces.
*/

/* Coded 10/19/77 by J. Stern */
/* Modified 3/5/80 by E. Wallman to incorporate changes in J. Stern's */
/* private version that never got into the >unb product. */
/* Modified 7/10/81 by P. Benjamin to reflect change in find_dict_word_ 
			     calling sequence. */

/* Parameters */

dcl  pm_word char (*);		/* the word to be hyphenated (Input) */
dcl  pm_space fixed bin;		/* the space available up to and including the hyphen (Input) */
dcl  pm_hpoint fixed bin;		/* the hyphenation point (Output) */
dcl  pm_code fixed bin (35);		/* an error code (Output) */


/* Automatic */

dcl  nargs fixed bin;
dcl  space fixed bin;
dcl  i fixed bin;
dcl  code fixed bin (35);
dcl  word_found char (256);
dcl  dict_path char (168);
dcl  word char (256);
dcl  word_len fixed bin;
dcl (leader, trailer) fixed bin;

dcl 1 descriptor aligned,
    2 hpoints bit (32) unal,
    2 pad bit (4) unal;

/* Based */

dcl  based_descrip bit (36) aligned based (addr (descriptor));


/* Static */

dcl  error_table_$id_not_found fixed bin (35) ext;


/* Builtins */

dcl (length, substr, addr, index, reverse, min, dim, verify, null) builtin;


/* Entries */

dcl  find_dict_word_ entry (char (*), bit (36) aligned, char (256),
     bit (36) aligned, char (168), ptr, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);

    call cu_$arg_count (nargs);	/* see how many args */
    if nargs = 4			/* fourth arg is optional */
    then pm_code = 0;
    pm_hpoint = 0;

    leader, trailer = 0;		/* do punctuation stripping */
    leader = verify (pm_word, "([{""") -1;
    if leader = -1
    then return;
    trailer = verify (reverse (pm_word), " )]}""!,.;:?") -1;
    if trailer = -1
    then return;

    word_len = length (pm_word) - leader - trailer;
    if word_len > 256
    then return;
    word = substr (pm_word, leader+1, word_len);

    space = pm_space - leader;
    if space < 2 | space > length (pm_word)
    then return;
    space = min (space, word_len);

/*		first_try = "1"b; */
retry: call find_dict_word_ (word, ""b, word_found, based_descrip, dict_path, null, code);
    if code ^= 0			/* | based_descrip = ""b */
    then do;

/* The code following involves parts-of-speech processing that was rejected
   for the >unb product. It is preserved here for posterity. */

/* dcl  first_try bit (1) aligned;
   /*dcl  new_suffix (6) char (1) varying int static options (constant) init ("y", "o", "", "y", "", "");
   /*dcl (si, sl) fixed bin;
   /*dcl  suffix (6) char (3) varying int static options (constant) init ("ies", "oes", "s", "ied", "ed", "ing");
   /*dcl  suffix_syllable (6) bit (1) int static options (constant) init ((5) (1) "0"b, "1"b);
   /*		     if first_try
   /*		     then do si = 1 to dim (suffix, 1);		/* see if we recognize a suffix */
/*			sl = length (suffix (si));
   /*			if substr (word, word_len-sl+1, sl) = suffix (si)
   /*			then do;
   /*			     first_try = "0"b;
   /*			     substr (word, word_len-sl+1, sl) = new_suffix (si);
   /*			     word_len = word_len -sl + length (new_suffix (si));
   /*			     go to retry;
   /*			end;
   /*		     end; */

       if nargs = 4
       then if code ^= error_table_$id_not_found
	then pm_code = code;
       return;
    end;

/*		if ^first_try
   /*		then if suffix_syllable (si)
   /*		     then if word_len <= 32
   /*			then substr (descriptor.hpoints, word_len, 1) = "1"b; */

    space = min (33, space);
    i = index (reverse (substr (descriptor.hpoints, 1, space-1)), "1"b);
    if i ^= 0
    then do;
       i = space - i;
       if i < word_len
       then if substr (word, i+1, 1) = "-"
	then if nargs = 4
	   then i = i + 1;
	   else return;		/* runoff can't handle this */
       pm_hpoint = i + leader;
    end;

 end hyphenate_word_;



		    print_wordlist.pl1              12/17/85  1304.8rew 12/16/85  1652.5      175824


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


/****^  HISTORY COMMENTS:
  1) change(85-09-13,Spitzer), approve(85-09-13,MCR6618),
     audit(85-10-30,Blair), install(85-12-16,MR12.0-1001):
     Allow to read/write
     MSFs.
                                                   END HISTORY COMMENTS */

print_wordlist: pwl: proc;

/* Coded 11/14/77 by J. Stern */
/* Modified 10/06/83 by Charlie Spitzer. make -of use equal names. phx14967
		 make empty wordlist not print error. phx13055
*/

/* Automatic */

dcl  component fixed bin;
dcl  ring_brackets (3) fixed bin (6);
dcl  max_seg_size fixed bin (24);
dcl  msf bit (1) aligned;
dcl  type fixed bin (2);
dcl (seg_output, got_pname, first_time) bit (1) aligned init ("0"b);
dcl  atd char (256) varying;
dcl  argno fixed bin;
dcl  ap ptr;
dcl (input_ptr, output_ptr) ptr init (null);
dcl  nargs fixed bin;
dcl  al fixed bin;
dcl  (fcb_ptr, temp_ptr) ptr;
dcl  isaved fixed bin;
dcl (cols, rows) fixed bin (21);
dcl  max_cols fixed bin;
dcl  last_col_rows fixed bin;
dcl  code fixed bin (35);
dcl (dname, of_dname) char (168);
dcl (ename, of_ename) char (32);
dcl  bc fixed bin (24);
dcl (c, r, i) fixed bin (21);
dcl (input_len, output_len) fixed bin (21);
dcl  word_ptr ptr;
dcl (word_len, real_len) fixed bin (21);
dcl (nwords, words_per_page) fixed bin (21);
dcl (end_of_col, ntabs, nspaces, line_position) fixed bin (21);
dcl  col_width fixed bin (21);
dcl (page_len, vert_margin, input_idx) fixed bin (21);
dcl (system_area_ptr, words_ptr) ptr;
dcl (first_word_row, word_index) fixed bin;
		 

/* Based */

dcl  arg char (al) based (ap);
dcl  input_cs char (input_len) based (input_ptr);
dcl  output_cs char (output_len) based (temp_ptr);
dcl  word char (word_len) based (word_ptr);
dcl  words (words_per_page) char (col_width * 3) based (words_ptr);	/* holds words (possibly underlined) from file */
dcl  system_area area based (system_area_ptr);


/* Conditions */

dcl  cleanup condition;


/* Static */

dcl  BS char (1) int static options (constant) init ("");
dcl  NL char (1) int static options (constant) init ("
");
dcl  HT char (1) int static options (constant) init ("	");
dcl  NP char (1) int static options (constant) init ("");
dcl  whoami char (32) int static options (constant) init ("print_wordlist");

dcl (error_table_$badopt,
     error_table_$dirseg,
     error_table_$wrong_no_of_args,
     error_table_$noarg,
     error_table_$long_record,
     error_table_$short_record,
     error_table_$end_of_info) ext fixed bin (35);
dcl  iox_$user_output ext ptr;
dcl  sys_info$max_seg_size fixed bin(35) ext static;

/* Builtins */

dcl (addr, copy, divide, hbound, index, length, max, mod, null, rtrim, search, substr) builtin;


/* Entries */

dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ ext entry options (variable);
dcl  get_system_free_area_ entry() returns(ptr);
dcl  get_equal_name_ entry (char(*), char(*), char(32), fixed bin(35));
dcl  expand_pathname_$add_suffix ext entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35));
dcl  iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35));
dcl  iox_$close entry (ptr, fixed bin(35));
dcl  iox_$detach_iocb entry (ptr, fixed bin(35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin(35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  unique_chars_ entry (bit(*)) returns(char(15));
dcl  cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  get_temp_segment_ entry (char(*), ptr, fixed bin(35));
dcl  release_temp_segment_ entry (char(*), ptr, fixed bin(35));
dcl  hcs_$make_seg entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35));
dcl  hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl  initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));
dcl  pathname_ entry (char(*), char(*)) returns(char(168));
dcl  make_msf_ entry (char(*), char(*), (3) fixed bin(6), fixed bin(35));
dcl  unmake_msf_ entry (char(*), char(*), bit(1), (3) fixed bin(6), fixed bin(35));
dcl  msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35));
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35));


/* examine arguments */

	call cu_$arg_count (nargs);
	if nargs = 0 then do;
noarg:	     code = error_table_$noarg;
usage:	     call com_err_ (code, whoami,
		"^/Usage: print_wordlist path {-columns N} {-page_length N} {-vertical_margin N} {-output_file path}");
	     return;
	end;

	cols, page_len, vert_margin = -1;
	col_width = 20;
	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, ap, al, code);

	     if index (arg, "-") ^= 1 then do;		/* not an option, must be pathname */
		if got_pname then do;		/* already have pathname => error */
		     code = error_table_$wrong_no_of_args;
		     go to usage;
		end;
		call expand_pathname_$add_suffix (arg, "wl", dname, ename, code);
		if code ^= 0 then do;
bad_path:		     call com_err_ (code, whoami, arg);
		     return;
		end;
		got_pname = "1"b;
	     end;
	     else if arg = "-cols" | arg = "-columns"
	     then do;
		call next_arg_num (cols);
		if code ^= 0 | cols < 1 then do;
		     call com_err_ (0, whoami, "Invalid column count.  ^a", arg);
		     return;
		end;
	     end;
	     else if arg = "-cw" | arg = "-column_width"
	     then do;
		call next_arg_num (col_width);
		if code ^= 0 | col_width < 2
		then do;
		     call com_err_ (0, whoami, "Invalid column width.  ^a", arg);
		     return;
		end;
	     end;
	     else if arg = "-pl" | arg = "-page_length"
	     then do;
		call next_arg_num (page_len);
		if code ^= 0 | page_len < 1
		then do;
		     call com_err_ (0, whoami, "Invalid page length.  ^a", arg);
		     return;
		end;
	     end;
	     else if arg = "-vm" | arg = "-vertical_margin"
	     then do;
		call next_arg_num (vert_margin);
		if code ^= 0 | vert_margin < 0
		then do;
		     call com_err_ (0, whoami, "Invalid vertical margin.  ^a", arg);
		     return;
		end;
	     end;
	     else if arg = "-of" | arg = "-output_file"
	     then do;
		call next_arg;
		call expand_pathname_ (arg, of_dname, of_ename, code);
		if code ^= 0 then go to bad_path;
		if search (rtrim (of_ename), "%=") ^= 0 then do;
		     call get_equal_name_ (ename, (of_ename), of_ename, code);
		     if code ^= 0 then go to bad_path;
		     end;
		seg_output = "1"b;
	     end;
	     else do;
		call com_err_ (error_table_$badopt, whoami, arg);
		return;
	     end;
	end;
	if ^got_pname				/* no pathname given */
	then go to noarg;

	if page_len = -1
	then if seg_output
	     then page_len = 60;
	     else page_len = 66;
	if vert_margin = -1
	then if seg_output
	     then vert_margin = 0;
	     else vert_margin = 3;

	rows = page_len - 2 * vert_margin;
	if rows < 1
	then do;
	     call com_err_ (0, whoami, "Page length of ^d too small for vertical margin of ^d.", page_len, vert_margin);
	     return;
	end;

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

/* open input segment */

	fcb_ptr, temp_ptr, input_ptr, output_ptr, words_ptr = null;
	system_area_ptr = get_system_free_area_ ();
	component = 0;

	on cleanup call cleaner;

	call hcs_$status_minf (dname, ename, 1, type, bc, code);
	if code ^= 0 then call input_seg_error;
	if type = 2
	then if bc = 0
	     then do;
		code = error_table_$dirseg;
		call input_seg_error;
		end;
	     else msf = "1"b;
	else msf = "0"b;

	if msf then do;
	     atd = "vfile_ " || rtrim (dname);
	     atd = atd || ">";
	     atd = atd || ename;
	     call iox_$attach_name (unique_chars_ (""b)||".pwl", input_ptr, (atd), null, code);
	     if code ^= 0 then call input_seg_error;
	     call iox_$open (input_ptr, 1, "0"b, code);	/* open for input */
	     if code ^= 0 then call input_seg_error;

	     if seg_output then do;			/* make output seg */
		atd = "vfile_ " || rtrim (of_dname);
		atd = atd || ">";
		atd = atd || of_ename;

		call iox_$attach_name (unique_chars_ (""b)||".pwl", output_ptr, (atd), null, code);
		if code ^= 0 then call output_seg_error;
		call iox_$open (output_ptr, 2, "0"b, code);  /* open for output */
		if code ^= 0 then call output_seg_error;
		end;
	     else output_ptr = null;
	     end;
	else do;
	     call initiate_file_ (dname, ename, R_ACCESS, input_ptr, bc, code);
	     if input_ptr = null then call input_seg_error;

	     input_len = divide (bc+8, 9, 24, 0);	/* get character count */
	     input_idx = 1;				/* character index */

	     if seg_output then do;
		call hcs_$make_seg (of_dname, of_ename, "", RW_ACCESS_BIN, output_ptr, code);
		if output_ptr = null
		then if code ^= error_table_$dirseg
		     then call output_seg_error;
		     else do;
			call hcs_$status_minf (of_dname, of_ename, 1, type, bc, code);
			if code ^= 0 then call output_seg_error;
			if type = 2
			then if bc = 0
			     then do;
				code = error_table_$dirseg;
				call output_seg_error;
				end;

/* make a SSF from the MSF, but don't save any contents. */

			call unmake_msf_ (of_dname, of_ename, "0"b, ring_brackets, code);
			if code ^= 0 then call output_seg_error;

			call initiate_file_ (of_dname, of_ename, RW_ACCESS, output_ptr, bc, code);
			if code ^= 0 then call output_seg_error;
			end;

		if output_ptr = input_ptr then do;
		     call com_err_ (0, whoami, "Input and output files are the same. ^a and ^a",
			pathname_ (dname, ename), pathname_ (of_dname, of_ename));
		     goto error;
		     end;
		temp_ptr = output_ptr;		/* build output segment directly in segment, not temp seg. */
		end;
	     end;

	if temp_ptr = null then do;
	     call get_temp_segment_ (whoami, temp_ptr, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, whoami, "Cannot get temporary segment.");
		go to error;
		end;
	     end;

	if output_ptr = null
	then output_ptr = iox_$user_output;		/* writing to terminal */
	output_len = 0;


/* now build the output segment one page at a time */

	first_time = "1"b;
	words_per_page = rows * cols;
	allocate words in (system_area) set (words_ptr);

	max_seg_size = sys_info$max_seg_size * 4;

	do while ("1"b);
	     call fill_word_array (nwords);
	     if nwords = 0
	     then if first_time
		then do;
		     call com_err_ (0, whoami, "Wordlist empty. ^a", pathname_ (dname, ename));
		     goto error;
		     end;
		else goto EOF;			/* end of file */
	     else first_time = "0"b;

	     if nwords < cols
	     then do;
		cols = nwords;
		rows = 1;
		end;

	     word_index, first_word_row = 1;
	     call output (copy (NL, vert_margin), vert_margin);

	     if rows * cols > nwords
	     then rows = divide (nwords + cols -1, cols, 17, 0); /* minimize length of last page */
	     last_col_rows = rows - (rows * cols - nwords);

	     do r = 1 to rows;
		if r > 1
		then call output (NL, 1);
		if r = last_col_rows + 1
		then cols = cols - 1;

		do c = 1 to cols;
		     if first_word_row > rows then goto EOP;
		     word_ptr = addr (words (word_index));
		     word_len = length (rtrim (words (word_index)));
		     word_index = word_index + rows;
		     if word_index > nwords
		     then word_index, first_word_row = first_word_row + 1;

		     i = index (word, BS);		/* check for backspace */
		     if i ^= 0
		     then do;
			isaved = col_width - 2;
			real_len = i - 2;
			do i = i + 1 to word_len while (real_len <= col_width-1);
			     if substr (word, i, 1) = BS
			     then real_len = real_len - 1;
			     else do;
				real_len = real_len + 1;
				if real_len = col_width - 2
				then isaved = i;
			     end;
			end;
			if real_len > col_width - 1
			then word_len = isaved;
		     end;
		     else do;			/* no backspaces */
			real_len = word_len;
			if word_len > col_width - 1
			then word_len = col_width - 2;
		     end;

		     call output (word, word_len);
		     if real_len > col_width - 1
		     then do;
			real_len = col_width - 1;
			call output ("*", 1);
		     end;

		     if c < cols
		     then do;
			end_of_col = c * col_width;
			line_position = end_of_col - col_width + real_len;
			ntabs = divide (end_of_col, 10, 17, 0) - divide (line_position, 10, 17, 0);
			if ntabs > 0
			then do;
			     call output (copy (HT, ntabs), ntabs);
			     line_position = line_position - mod (line_position, 10) + 10 * ntabs;
			end;

			nspaces = end_of_col - line_position;
			if nspaces > 0
			then call output (copy ("", nspaces), nspaces);
		     end;
		end;				/* do cols */
next_row:						/* end of line */
	     end;					/* do rows */

EOP:
	     if seg_output
	     then if vert_margin = 0
		then call output (NP, length (NP));
	          else call output (copy (NL, vert_margin - length (NP))||NP, vert_margin);
	     else do;
		call output (copy (NL, vert_margin+1), vert_margin+1);
		call iox_$put_chars (output_ptr, temp_ptr, output_len, code);
		if code ^= 0
		then call com_err_ (code, whoami, "Attempting to write on user_output switch.");
		output_len = 0;			/* start at beginning of segment again */
		end;

	end;					/* do forever */

EOF:						/* come here on end of input file */
	if output_len > 0
	then if msf
	     then do;
		call iox_$put_chars (output_ptr, temp_ptr, output_len, code);
		if code ^= 0 then call com_err_ (code, whoami, "Attempting to write on user_output switch.");
		end;
	     else do;
		call terminate_file_ (output_ptr, output_len * 9, TERM_FILE_TRUNC_BC_TERM, code);
		if code ^= 0 then call com_err_ (code, whoami, "^a", pathname_ (dname, ename));
		end;

error:
	call cleaner;
	return;

input_seg_error:
     proc;

input_seg:
          call com_err_ (code, whoami, "^a", pathname_ (dname, ename));
	go to error;

output_seg_error:
     entry;

	dname = of_dname;
	ename = of_ename;
	go to input_seg;

	end input_seg_error;

cleaner:	proc;					/* cleanup handler */

	     if output_ptr = iox_$user_output | output_ptr = temp_ptr
	     then output_ptr = null;

	     if temp_ptr ^= null
	     then if ^msf & seg_output
		then ;
		else call release_temp_segment_ (whoami, temp_ptr, (0));

	     do input_ptr = input_ptr, output_ptr;
		if input_ptr ^= null
		then if msf then do;
			call iox_$close (input_ptr, (0));
			call iox_$detach_iocb (input_ptr, (0));
			call iox_$destroy_iocb (input_ptr, (0));
			end;
		     else call terminate_file_ (input_ptr, 0, TERM_FILE_TERM, (0));
		end;

	if fcb_ptr ^= null
	then call msf_manager_$close (fcb_ptr);

	if words_ptr ^= null then free words in (system_area);
	return;

	end cleaner;


next_arg:	proc;					/* gets next argument */


	     argno = argno + 1;
	     if argno > nargs
	     then go to noarg;
	     call cu_$arg_ptr (argno, ap, al, code);

	end next_arg;


next_arg_num: proc (num);				/* gets next argument, converts to fixed bin */

dcl  num fixed bin (21);


	     call next_arg;
	     num = cv_dec_check_ (arg, code);

	end next_arg_num;

fill_word_array:
     proc (cnt);

dcl  cnt fixed bin (21);
dcl  nread fixed bin (21);

	cnt = 1;
	do while (cnt ^> hbound (words, 1));
	     if msf then do;
		call iox_$get_line (input_ptr, addr (words (cnt)), length (words (cnt)), nread, code);
		if code ^= 0
		then if code = error_table_$end_of_info
		     then do;
END_OF_INPUT:		cnt = cnt - 1;
			return;
			end;
		     else if code = error_table_$long_record | code = error_table_$short_record
			then ;			/* ok to get this one */
		     else call input_seg_error;
		else if nread = 1
		     then goto read_next_word;	/* blank line */
		else substr (words (cnt), nread) = "";	/* take out NL + leftover junk */
		end;
	     else do;
		if input_idx > input_len then goto END_OF_INPUT;
		word_len = index (substr (input_cs, input_idx), NL) -1;
		if word_len = 0
		then do;
		     input_idx = input_idx + 1;
		     goto read_next_word;		/* blank line */
		     end;
		if word_len = -1
		then word_len = input_len - input_idx + 1;   /* final newline missing */
		words (cnt) = substr (input_cs, input_idx, word_len);
		input_idx = input_idx + word_len + 1;	/* bump character index over this word */
		end;

	     cnt = cnt + 1;
read_next_word:
	     end;

	cnt = cnt - 1;
	return;

	end fill_word_array;
%page;
output:
     proc (str, len) recursive;

dcl  str char (*) parameter;				/* string to output */
dcl  len fixed bin (21) parameter;			/* how long it is */
dcl  chars_that_fit fixed bin (21);

	if seg_output
	then if msf
	     then do;
		call iox_$put_chars (output_ptr, addr (str), len, code);
		if code ^= 0 then call output_seg_error;
		return;
		end;
	     else if output_len + len + 1 > max_seg_size
		then do;				/* output segment grows to an MSF */

/* Fill end of segment with whatever fits from the input string */

		     chars_that_fit = max_seg_size - output_len;
		     substr (output_cs, output_len + 1, chars_that_fit) = str;

		     if component = 0 then do;

/* Terminate the output file, make it into an MSF, then open using
   msf_manager_. Continue to use pointer I/O on each component which has to
   be more efficient than using vfile_. */

			call terminate_file_ (output_ptr, max_seg_size * 9, TERM_FILE_BC | TERM_FILE_TERM, code);
			if code ^= 0 then call output_seg_error;

			call make_msf_ (of_dname, of_ename, ring_brackets, code);
			if code ^= 0 then call output_seg_error;

			call msf_manager_$open (of_dname, of_ename, fcb_ptr, code);
			if code ^= 0 then call output_seg_error;

			call msf_manager_$get_ptr (fcb_ptr, 1, "1"b, output_ptr, bc, code);
			if code ^= 0 then call output_seg_error;
			component = 1;

			temp_ptr = output_ptr;
			end;
		     else do;

			call terminate_file_ (output_ptr, max_seg_size * 9, TERM_FILE_BC | TERM_FILE_TERM, code);
			if code ^= 0 then call output_seg_error;

			call msf_manager_$get_ptr (fcb_ptr, component+1, "1"b, output_ptr, bc, code);
			if code ^= 0 then call output_seg_error;

			component = component + 1;
			temp_ptr = output_ptr;
			end;

		     output_len = 0;		/* empty output file */

/* Put rest of input string at the head of the output buffer. Since the string
   passed might not be len chars long, pad with spaces if the difference is
   negative. */

		     if len > chars_that_fit
		     then call output (substr (str, chars_that_fit + 1), len - chars_that_fit);
		     return;
		     end;

	substr (output_cs, output_len + 1, len) = str;
	output_len = output_len + len;

	return;
	end output;
%page;
%include access_mode_values;
%include terminate_file;

     end print_wordlist;



		    sort_strings_.pl1               11/18/82  1707.6rew 11/18/82  1629.3       35487


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


sort_strings_: proc (pm_Ap, pm_count);

/*
   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

   Modified 10/19/77 by J. Stern to add $indirect entry
*/

/* Parameters */

dcl  pm_Ap ptr;					/* ptr to array of string descriptors */
dcl  pm_count fixed bin (24);				/* number of strings to sort */
dcl  pm_Ip ptr;					/* ptr to array of "indirect" data */


/* Automatic */

dcl  ind_sw bit (1) aligned;
dcl (Ap, Ip) ptr;
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 1 A_temp aligned like A_entry;

dcl  I_temp fixed bin (71);


/* Based */

dcl  cstring char (262144) based;

dcl 1 A_entry aligned based,
    2 p ptr unal,
    2 l fixed bin;

dcl 1 A (pm_count) aligned based (Ap) like A_entry;

dcl  I (pm_count) fixed bin (71) based (Ip);


/* Builtins */

dcl (divide, substr) builtin;

	ind_sw = "0"b;
	go to join;


indirect:	entry (pm_Ap, pm_count, pm_Ip);

	ind_sw = "1"b;
	Ip = pm_Ip;

join:	Ap = pm_Ap;
	depth = 0;
	first = 1;
	last = pm_count;
	go to L4;


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

	if substr (A (first).p -> cstring, 1, A (first).l) > substr (A (median).p -> cstring, 1, A (median).l)
	then call swap (first, median);

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

	     if substr (A (first).p -> cstring, 1, A (first).l) > substr (A (median).p -> cstring, 1, A (median).l)
	     then call swap (first, median);

	end;

	A_temp = A (median);

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

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

	if low <= high then do;
	     call swap (high, low);
	     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;
	     A_temp = A (first);
	     if ind_sw then I_temp = I (first);
	     do low = first -1 by -1
		     while (substr (A (low).p -> cstring, 1, A (low).l) > substr (A_temp.p -> cstring, 1, A_temp.l));
		A (low +1) = A (low);
		if ind_sw then I (low +1) = I (low);
	     end;
	     A (low +1) = A_temp;
	     if ind_sw then I (low +1) = I_temp;
	end;


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


swap:	proc (i, j);

dcl (i, j) fixed bin (24);
dcl 1 A_swap aligned like A_entry;
dcl  I_swap fixed bin (71);


	     A_swap = A (i);
	     A (i) = A (j);
	     A (j) = A_swap;

	     if ind_sw
	     then do;
		I_swap = I (i);
		I (i) = I (j);
		I (j) = I_swap;
	     end;

	end swap;


     end sort_strings_;
 



		    trim_wordlist.pl1               02/16/88  1448.4rew 02/16/88  1406.4      181071


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


/****^  HISTORY COMMENTS:
  1) change(85-09-13,Spitzer), approve(85-09-13,MCR6618),
     audit(85-10-30,Blair), install(85-12-16,MR12.0-1001):
     Allow to read/write
     MSFs.
  2) change(88-01-01,Gilcrease), approve(88-02-05,MCR7834),
     audit(88-02-05,Blair), install(88-02-16,MR12.2-1023):
               Fix trim error when first letter cap, and contains '.
                                                   END HISTORY COMMENTS */

trim_wordlist: twl: proc;

/* The trim_wordlist command removes from a specified wordlist all
   words found in a specified sequence of dictionaries.  The dictionaries
   are consulted in order.  If the "notrim" attribute is enabled
   for a word found in a dictionary,  the word is not deleted and
   subsequent dictionaries in the sequence, if any, are not consulted
   for that word.
*/

/* Coded 9/28/77 by J. Stern */
/* Modified 7/7/81 by P. Benjamin to fix bug where bad dict in search list stops processing */

/* Automatic */

dcl  msf bit (1) aligned;
dcl (nargs, argno) fixed bin;
dcl  ap ptr;
dcl  al fixed bin;
dcl  code fixed bin (35);
dcl  system_area_ptr ptr;
dcl  ndict fixed bin;
dcl  temp_ndict fixed bin;
dcl (brief, exact_match, have_wl_path) bit (1) aligned;
dcl  (temp_dir, dname) char (168);
dcl  (temp_name, ename) char (32);
dcl  temp_ptr ptr;
dcl  type fixed bin (2);
dcl  bc fixed bin (24);
dcl  wl_ptr ptr;
dcl (wl_len, wl_ix) fixed bin (21);
dcl  switch char (32);
dcl  atd char (256) varying;
dcl  dictx fixed bin;
dcl (nwords, saved_nwords, original_nwords) fixed bin (21);
dcl  eof bit (1) aligned;
dcl  wordx fixed bin (21);
dcl  word_ptr ptr;
dcl  word_len fixed bin (21);
dcl  notrim bit (1) aligned;
dcl  new_wl_len fixed bin (21);
dcl  dip ptr;

dcl 1 get_key_info,
    2 flags like gk_header.flags,
    2 descriptor,
      3 hpoints bit (32) unal,
      3 notrim bit (1) unal,
      3 pad bit (3) unal,
    2 key_len fixed bin,
    2 key char (256);


/* Based */

dcl  arg char (al) based (ap);
dcl  system_area area based (system_area_ptr);
dcl  dict_iocbps (ndict) ptr based (dip);
dcl  wl_cs char (wl_len) based (wl_ptr);
dcl  wl_vec (wl_len) char (1) unal based (wl_ptr);
dcl  word char (word_len) based (word_ptr);

dcl  1 trim_data (nwords) aligned based (temp_ptr),
     2 wordp ptr unal,
     2 notrim bit (1) unal,
     2 pad bit (10) unal,
     2 wordl fixed bin (24) unal;

/* Static */

dcl  error_table_$dirseg fixed bin(35) ext static;
dcl  error_table_$short_record fixed bin(35) ext static;
dcl  error_table_$end_of_info fixed bin(35) ext static;
dcl  error_table_$fatal_error fixed bin (35) ext;
dcl  error_table_$noarg fixed bin (35) ext;
dcl  error_table_$zero_length_seg fixed bin (35) ext;
dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$no_record fixed bin (35) ext;
dcl  error_table_$no_key fixed bin (35) ext;

dcl  whoami char (13) int static options (constant) init ("trim_wordlist");
dcl  capital_letters char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  small_letters char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
dcl  NL char (1) int static options (constant) init ("
");


/* Conditions */

dcl  cleanup condition;


/* Builtins */

dcl (substr, divide, null, rtrim, index, addr, verify, translate, search, mod, length, unspec) builtin;


/* Entries */

dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  get_system_free_area_ entry (ptr);
dcl  get_pdir_ entry() returns(char(168));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  absolute_pathname_ entry (char(*), char(*), fixed bin(35));
dcl  absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35));
dcl  initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  (get_temp_segment_, release_temp_segment_) entry (char (*), ptr, fixed bin (35));
dcl  hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  pathname_ entry (char(*), char(*)) returns(char(168));
dcl  iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin(35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  delete_$path entry (char(*), char(*), bit(36) aligned, char(*), fixed bin(35));
dcl  ioa_ entry options (variable);
dcl  terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));
dcl  search_paths_$get entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35));
dcl  copy_ entry (ptr);

	wl_ptr, temp_ptr, dip, sl_info_p = null;	/* initialize ptrs */

/* find out how many args we have */

	call cu_$arg_count (nargs);
	if nargs < 1
	then do;
noarg:	     call com_err_ (error_table_$noarg, whoami, "^/Usage:  trim_wordlist wl_path {dict_paths} {-brief} {-exact_match}");
	     go to finish;
	end;

	on cleanup call cleaner;

/* allocate space for dictionary pathnames */

	sl_info_num_paths = nargs - 1;			/* upper limit on number of dict paths */
	call get_system_free_area_ (system_area_ptr);
	allocate sl_info in (system_area);

/* examine arguments */

	ndict = 0;
	brief, exact_match, have_wl_path = "0"b;
	temp_dir = get_pdir_ ();

	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, ap, al, code);
	     if index (arg, "-") ^= 1			/* not a control arg */
	     then if ^have_wl_path			/* don't have wordlist pathname yet */
		then do;
		     call expand_pathname_$add_suffix (arg, "wl", dname, ename, code);
		     if code ^= 0
		     then do;
			call com_err_ (code, whoami, arg);
			go to finish;
		     end;
		     have_wl_path = "1"b;		/* remember we have the wordlist pathname */
		end;
		else do;				/* must be a dictionary pathname */
		     ndict = ndict + 1;
		     call absolute_pathname_$add_suffix (arg, "dict", sl_info.pathname (ndict), code);
		     if code ^= 0
		     then do;
			call com_err_ (code, whoami, arg);
			go to finish;
		     end;
		end;

	     else if arg = "-td" | arg = "-temp_dir"
		then do;
		     call cu_$arg_ptr (argno+1, ap, al, code);
		     if code ^= 0 then do;
			call com_err_ (code, whoami, "After -temp_dir");
			return;
			end;
		     call absolute_pathname_ (arg, temp_dir, code);
		     if code ^= 0 then do;
			call com_err_ (code, whoami, "^a", arg);
			return;
			end;
		     argno = argno + 1;
		     end;

	     else if arg = "-bf" | arg = "-brief"
	     then brief = "1"b;

	     else if arg = "-exm" | arg = "-exact_match"
	     then exact_match = "1"b;

	     else do;
		call com_err_ (error_table_$badopt, whoami, arg);
		go to finish;
	     end;
	end;

	if ^have_wl_path
	then go to noarg;

/* if no dictionaries specified, get search list */

	if ndict = 0
	then do;
	     free sl_info in (system_area);
	     sl_info_p = null;

	     call search_paths_$get ("dict", "111111"b, "", null, system_area_ptr, sl_info_version_1, sl_info_p, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, whoami, "Cannot get ""dict"" search list.");
		go to finish;
	     end;

	     ndict = sl_info.num_paths;
	end;

	call hcs_$status_minf (dname, ename, 1, type, bc, code);
	if code ^= 0 then goto bad_seg;

	if type = 2
	then if bc = 0
	     then do;
		code = error_table_$dirseg;
		goto bad_seg;
		end;
	     else msf = "1"b;
	else msf = "0"b;

	if msf
	then do;
/* open original word list */
	     switch = unique_chars_ ("0"b) || "." || whoami;
	     atd = "vfile_ " || rtrim (dname);
	     atd = atd || ">";
	     atd = atd || ename;

	     call iox_$attach_name (switch, wl_ptr, (atd), null, code);
	     if code ^= 0 then goto bad_seg;
	     
	     call iox_$open (wl_ptr, Stream_input, "0"b, code);
	     if code ^= 0 then goto bad_seg;

/* open temp file in [pd] to hold trimmed list */

	     temp_name, switch = unique_chars_ ("0"b) || "." || whoami;
	     atd = "vfile_ " || rtrim (temp_dir);
	     atd = atd || ">";
	     atd = atd || temp_name;

	     call iox_$attach_name (switch, temp_ptr, (atd), null, code);
	     if code ^= 0 then do;
		call com_err_ (code, whoami, "Attempting to attach temp file in [pd].");
		goto finish;
		end;

	     call iox_$open (temp_ptr, Stream_output, "0"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, whoami, "Attempting to open a temp file in [pd].");
		goto finish;
		end;
	     end;
	else do;					/* get ptr to and length of the wordlist */
	     call initiate_file_ (dname, ename, RW_ACCESS, wl_ptr, bc, code);
	     if wl_ptr = null
	     then do;
bad_seg:		call com_err_ (code, whoami, "^a", pathname_ (dname, ename));
		go to finish;
		end;

	     wl_len = divide (bc, 9, 24, 0);		/* convert bit count to char count */
	     if wl_len = 0
	     then do;
		code = error_table_$zero_length_seg;
		go to bad_seg;
		end;
	     end;

/* if more than 1 dictionary, create temporary workspace */

	if ndict > 1 & ^msf
	then do;
	     call get_temp_segment_ (whoami, temp_ptr, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, whoami, "Cannot get temp segment.");
		go to finish;
	     end;
	end;

/* open all of the dictionaries */

	allocate dict_iocbps in (system_area);
	dict_iocbps (*) = null;

	temp_ndict = 1;
	do dictx = 1 to ndict;
	     switch = unique_chars_ (""b) || "." || whoami;    /* use unique name for I/O switch */
	     atd = "vfile_ " || rtrim (sl_info.pathname (dictx));
	     atd = atd || " -share"; /* build attach description */
	     call iox_$attach_name (switch, dict_iocbps (temp_ndict), (atd), null, code);
	     if code ^= 0
		then call com_err_ (code, whoami, "Cannot attach switch.  ^a", switch);

	     else do;
		call iox_$open (dict_iocbps (temp_ndict), Keyed_sequential_input, "0"b, code);
		if code ^= 0
		     then do;
		     call com_err_ (code, whoami, "Cannot open file.  ^a", sl_info.pathname (dictx));
		     call iox_$detach_iocb (dict_iocbps (temp_ndict), code);
		end;
		else temp_ndict = temp_ndict + 1;
	     end;
	end;
	if temp_ndict = 1				/* No usable dicts */
	     then do;
	     call com_err_ (error_table_$fatal_error, whoami);
	     goto finish;
	end;
	ndict = temp_ndict - 1;			/* Now ndict is the number of usable dicts */
	
	get_key_info.flags.input_key = "1"b;
	get_key_info.input_desc = "0"b;
	get_key_info.desc_code = 0;
	get_key_info.rel_type = 0;
	get_key_info.head_size = 256;
	get_key_info.reset_pos = "0"b;
	get_key_info.flags.pad = ""b;
	get_key_info.version = gk_info_version_0;

/* now do the real work */

	if msf then call process_msf;
	else call process_non_msf;

/* report results if brief option not specified */

	if ^brief
	then call ioa_ ("number of words trimmed = ^d^/number of words remaining = ^d", original_nwords-nwords, nwords);

/* clean up and go home */

	if ^msf then do;
	    if new_wl_len + 1 <= wl_len then	         /* set to NUL */
  	       substr (wl_cs, new_wl_len + 1, 4 - mod (new_wl_len, 4)) = "   ";
	     call terminate_file_ (wl_ptr, 9 * new_wl_len, TERM_FILE_TRUNC_BC_TERM, code);
	     if code ^= 0
	     then call com_err_ (code, whoami, "^a", pathname_ (dname, ename));
	     end;

finish:	call cleaner;
	return;

cleaner:	proc;					/* cleanup procedure */

	     if dip ^= null
	     then do dictx = 1 to ndict;
		if dict_iocbps (dictx) ^= null
		then call close_file (dict_iocbps (dictx));
	     end;

	     if msf
	     then do;
		if wl_ptr ^= null then call close_file (wl_ptr);
		if temp_ptr ^= null then call close_file (temp_ptr);
		call delete_$path (temp_dir, temp_name, "101111"b, whoami, (0));
		wl_ptr, temp_ptr = null;
		end;
	     else do;
		if temp_ptr ^= null
		then call release_temp_segment_ (whoami, temp_ptr, (0));
		if wl_ptr ^= null
		then call terminate_file_ (wl_ptr, 0, TERM_FILE_TERM, (0));
		end;

	     if dip ^= null
	     then free dict_iocbps in (system_area);

	     if sl_info_p ^= null
	     then free sl_info in (system_area);

	end cleaner;

close_file:
     proc (iocbp);

dcl  iocbp ptr parameter;

	call iox_$close (iocbp, (0));
	call iox_$detach_iocb (iocbp, (0));
	call iox_$destroy_iocb (iocbp, (0));
	iocbp = null;

	return;
	end close_file;
%page;
process_non_msf:
     proc;

/* consult the dictionaries one at a time (in order) */
/* for each dictionary, look up all wordlist words */
/* for each word, either trim or retain as appropriate */
/* for the first dictionary, parse the wordlist as we go */
/* for the last dictionary, build the new trimmed wordlist as we go */

	wl_ix = 1;
	new_wl_len = 0;
	saved_nwords = wl_len;			/* upper limit on number of words in wordlist */

	do dictx = 1 to ndict;
	     eof = "0"b;
	     nwords = 0;

	     do wordx = 1 to saved_nwords while (^eof);

		if dictx = 1			/* first dictionary */
		then do;				/* find next word in wordlist */
		     word_len = index (substr (wl_cs, wl_ix), NL) -1;
		     if word_len = 0		/* a blank line, not legal but we'll tolerate it */
		     then go to advance_index;
		     if word_len = -1		/* wordlist does not end in NL, be kind */
		     then word_len = wl_len -wl_ix + 1; /* last word is rest of segment */
		     word_ptr = addr (wl_vec (wl_ix));
		     if word_len > 256		/* cannot be in dictionary */
		     then notrim = "1"b;		/* so don't bother looking */
		     else notrim = "0"b;
advance_index:	     wl_ix = wl_ix + word_len + 1;
		     if wl_ix > wl_len
		     then eof = "1"b;		/* end of wordlist reached */
		     if word_len = 0
		     then do;
			wordx = wordx - 1;		/* don't count this word */
			go to next_word;
		     end;
		end;

		else do;				/* get saved word description */
		     word_ptr = trim_data (wordx).wordp;
		     word_len = trim_data (wordx).wordl;
		     notrim = trim_data (wordx).notrim;
		end;

		if ^trim_word ()			/* retain this word */
		then do;
		     nwords = nwords + 1;
		     if dictx < ndict		/* not last dictionary */
		     then do;			/* save word description */
			trim_data (nwords).wordp = word_ptr;
			trim_data (nwords).wordl = word_len;
			trim_data (nwords).notrim = notrim;
		     end;
		     else do;			/* last dictionary, put word in new wordlist */
			substr (wl_cs, new_wl_len + 1, word_len) = word;
			new_wl_len = new_wl_len + word_len;
			substr (wl_cs, new_wl_len + 1, 1) = NL;
			new_wl_len = new_wl_len + 1;
		     end;
		end;
next_word:
	     end;

	     if dictx = 1
	     then original_nwords = wordx - 1;
	     saved_nwords = nwords;
	end;

          return;
	end process_non_msf;
%page;
process_msf:
     proc;

/* For each word, consult the dictionaries. If it is not to be trimmed, write
   the word out to the output temp file in [pd]. When done and if there has
   been at least one word changed, copy_ the temp file over the original. */

dcl  buffer char (256);
dcl  word_max_len fixed bin (21);
dcl  1 co like copy_options;

          word_ptr = addr (buffer);
	word_max_len = length (buffer);
	notrim = "0"b;
	nwords, original_nwords = 0;

	call iox_$get_line (wl_ptr, word_ptr, word_max_len, word_len, code);
	do while (code ^= error_table_$end_of_info);
	     if code ^= 0
	     then if code ^= error_table_$short_record
		then goto bad_seg;
	          else ;
	     else word_len = word_len - 1;

	     if word_len = 0 then goto skip_word;
	     original_nwords = original_nwords + 1;

	     do dictx = 1 to ndict;
		if trim_word ()
		then goto skip_word;
		end;

	     call iox_$put_chars (temp_ptr, word_ptr, word_len, code);
	     if code = 0 then do;
		call iox_$put_chars (temp_ptr, addr (NL), length (NL), code);
		nwords = nwords + 1;
		end;
	     if code ^= 0 then call com_err_ (code, whoami, "Writing word ""^a"" to temp file.", word);
	     
skip_word:
	     call iox_$get_line (wl_ptr, word_ptr, word_max_len, word_len, code);
	     end;

	if original_nwords = 0 then do;
	     code = error_table_$zero_length_seg;
	     goto bad_seg;
	     end;

	call close_file (temp_ptr);
	call close_file (wl_ptr);

	if nwords ^= original_nwords then do;		/* some got trimmed */
	     co.version = COPY_OPTIONS_VERSION_1;
	     co.caller_name = whoami;
	     co.source_dir = temp_dir;
	     co.source_name = temp_name;
	     co.target_dir = dname;
	     co.target_name = ename;
	     unspec (co.flags) = "0"b;
	     co.flags.delete = "1"b;			/* delete source when done */
	     co.flags.force = "1"b;			/* try to force access if needed */

	     unspec (co.copy_items) = "0"b;
	     co.copy_items.update = "1"b;

	     call copy_ (addr(co));			/* copy work file to input file */
	     if co.target_err_switch
	     then goto finish;			/* errors reported by sub_err_ */
	     end;

	return;
	end process_msf;

/* This procedure determines whether or not the current word should be trimmed.
   It first looks for the current word in the current dictionary.  If found,
   the word is trimmed unless it has the notrim attribute.  If the word is
   not found and the exact_match option was not specified, the word is checked
   for standard capitalization.  If the current word has only its first letter
   capitalized, it can be trimmed by the equivalent de-capitalized word if
   found in the dictionary.  If the current word has all letters capitalized,
   it can be trimmed by either a "first-cap" or "no-cap" equivalent
   word if found in the dictionary.
*/

trim_word: proc returns (bit (1) aligned);


	     if notrim
	     then return ("0"b);

	     get_key_info.key = word;
	     if known_word ()
	     then return ("1"b);

	     if exact_match
	     then return ("0"b);

	     if verify (word, capital_letters) = 0
	     then do;
		if word_len > 1
		then do;
		     substr (get_key_info.key, 2) = translate (substr (word, 2), small_letters, capital_letters);
		     if known_word ()
		     then return ("1"b);
		end;
check_no_cap:
		get_key_info.key = translate (word, small_letters, capital_letters);
		if known_word ()
		then return ("1"b);
	     end;
	     else if word_len > 1
	     then if search (substr (word, 1, 1), capital_letters) = 1
		& verify (substr (word, 2), small_letters) = 0
		then go to check_no_cap;
	     else if index (word, "'") ^= 0 then go to check_no_cap;

skip_word:     return ("0"b);

/* This procedure determines whether or not a specified word is "known",
   i.e., whether or not the word is defined in the current dictionary.
   Each dictionary is an indexed file.  A dictionary contains a word
   if the word is a key for the file.  A record descriptor is associated
   with each key.  The notrim flag (as well as other data) is kept in the
   record descriptor.
*/

known_word:    proc returns (bit (1) aligned);


		get_key_info.key_len = 256;
		call iox_$control (dict_iocbps (dictx), "get_key", addr (get_key_info), code);
		if code ^= 0
		then if code = error_table_$no_record | code = error_table_$no_key
		     then return ("0"b);
		     else do;
			call com_err_ (code, whoami, "Referencing dictionary ^a.  Word not trimmed.  ^a",
			     sl_info.pathname (dictx), word);
			go to dont_trim;
		     end;

		if get_key_info.notrim
		then do;
dont_trim:	     notrim = "1"b;
		     go to skip_word;
		end;

		return ("1"b);

	     end known_word;


	end trim_word;
%page;
/* include files */

%include ak_info;
%include sl_info;
%include copy_options;
%include copy_flags;
%include access_mode_values;
%include terminate_file;
%include iox_modes;

     end trim_wordlist;


		    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