


		    PNOTICE_speedtype.alm           02/15/82  1058.9r w 02/15/82  1058.8        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., 1981"
          acc       "Copyright (c) 1972 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"W1SYPM091000"
	aci	"W2SYPM091000"
	aci	"W3SYPM091000"
	end
 



		    add_symbols.pl1                 01/06/81  1251.1rew 01/06/81  1246.2      100530


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

add_symbols: asb: procedure;

/*	This procedure implements the add_symbols command.
   *	Created on 10/15/75 by Bill Silver as add_notescript.
   *	Changed on 06/07/77 by Bill Silver to add_symbols.
   *      Changed on 10/28/80 by Paul Benjamin for special suffixing.
   *
   *	The add_symbols command will add a new symbol to the
   *	current Speedtype symbol dictionary.  Its calling sequence is:
   *
   *	add_symbols, asb symbol expansion {-control_args}
   *
   *	where:
   *
   *	     -fc, -force	Specifying this argument will force the replacement
   *			of the expansion of an already defined symbol.
   *			If the symbol is already defined and this argument is
   *			not specified then the user will be asked if he wants to
   *			replace this symbol.
   *
   *	     -plural AA	SUFFIX options.
   *	     -ed AA
   *	     -ing AA
   *	     -er AA
   *	     -ly AA
   *
   *	     -suffix "on" or "off"
*/

/*		AUTOMATIC DATA		*/

dcl  suffix_lens (5) fixed bin;			/* Length of each suffix expansion. */
dcl  suffix_exps (5) char (56+4);			/* +4 => room for suffix). */

/* Note above that 5 is really hbound(exp.actionx,1) and 56 is really length(exp.expansion). */


dcl  answer char (4) varying;				/* Answer to command query. */
dcl  arg_len fixed bin;				/* Length of a command argument. */
dcl  arg_ptr ptr;					/* Pointer to a command argument. */
dcl  argx fixed bin;				/* Index of current command argument. */
dcl  dir_name char (168);				/* Directory containing symbol dict. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  ent_name char (32);				/* Symbol dictionary */
dcl  exp_len fixed bin;				/* Length of expansion argument. */
dcl  expansion char (56);				/* Expansion for the new symbol. */

/* Note above that 56 is really length(exp.expansion). */

dcl  force_flag bit (1);				/* ON => force the replacement of defined symbol. */
dcl  i fixed bin;
dcl  symbol char (7);				/* The new symbol. */
dcl  sbx fixed bin;					/* Index of symbol entry. */
dcl  temp_code fixed bin (35);			/* Used when already have non-zero ecode. */
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  option char (8);				/* Control argument option. */
dcl  optx fixed bin;				/* Option index. */

dcl 1 query_info aligned,				/* Info structure for command_query_. */
    2 version fixed bin,
    (2 yes_no bit (1),
    2 suppress_name bit (1)) unaligned,
    2 status_code fixed bin,
    2 other_code fixed bin;


/*		BASED DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Command argument. */


/*		INTERNAL STATIC DATA	*/

dcl  options (6) char (8)				/* Control argument options. */
     internal static init ("-plural", "-ed", "-ing", "-er", "-ly", "-suffix");

dcl  new_line char (1)				/* Used to set up symbol entry. */
     internal static init ("
");


/*		EXTERNAL ENTRIES CALLED	*/

dcl (addr, hbound, length, min) builtin;

dcl  error_table_$bad_arg fixed bin (35) external;
dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$no_w_permission fixed bin(35) ext static;
dcl  error_table_$odd_no_of_args fixed bin (35) external;
dcl  error_table_$wrong_no_of_args fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  command_query_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  speedtype_index_ entry (char (*), ptr, fixed bin, fixed bin (35));
dcl  speedtype_info_$expand_table entry (ptr, fixed bin(35));
dcl  speedtype_info_$name entry (char (*), char (*), fixed bin (35));
dcl  speedtype_info_$pointer entry (ptr, fixed bin (35));
dcl  speedtype_info_$set_bc entry (ptr, fixed bin (35));
dcl  speedtype_suffix_ entry (ptr, ptr, ptr, fixed bin, ptr, fixed bin);
						/* 	*/
%include speedtype_symbols;
/* 	*/
/*	Begin add_symbols command.
*/
	call speedtype_info_$pointer (ssd_ptr, ecode);
	if ecode ^= 0				/* Did we get a pointer to the Speedtype symbol dictionary? */
	then do;
	     if ecode = error_table_$no_w_permission
		then do;
		call speedtype_info_$name (dir_name, ent_name, temp_code);
		call com_err_ (ecode, "Speedtype", "Attempting to convert ^a>^a to new version.", dir_name, ent_name);
	     end;
	     return;
	end;

	force_flag = "0"b;				/* Initialize flags. */
	do i = 1 to hbound (suffix_lens, 1);		/* Initially default suffixes specified. */
	     suffix_lens (i) = 0;
	end;

	call GET_ARGS;				/* Get commmand arguments. */
	if ecode ^= 0 then return;			/* Any errors? */

	if sbx = 0				/* Is symbol already defined? */
	then call GET_NEW_SBX;			/* No, it is a new symbol. */
	else call GET_OLD_SBX;			/* This symbol is already defined. */

	if sbx = 0				/* Are we ready to add this symbol? */
	then return;				/* No, no valid symbol entry index. */

	sb_ptr = addr (ssd.sb_tab (sbx));		/* Get pointer to specified symbol entry. */
	exp_ptr = addr (ssd.exp_tab (sbx));		/* And corresponding expansion entry. */
	spc_ptr = addr (ssd.spec_tab (sbx));              /* AND corresponding special entry. */

	exp.expansion = expansion;			/* First fill in expansion entry. */
	exp.pad = 0;
	exp.len = exp_len;

	sb.symbol = symbol;				/* Next, fill in the symbol entry. */
	sb.new_line = new_line;

	if sbx > ssd.num_symbols			/* Is this a new symbol? */
	then ssd.num_symbols = sbx;			/* Yes, add it to the list. */

	do i = 1 to hbound (suffix_lens, 1);		/* Set all suffixes for this symbol. */
	     call speedtype_suffix_ (sb_ptr, exp_ptr, spc_ptr, i, addr (suffix_exps (i)), suffix_lens (i));
	     if (exp.actionx (i) = 0) &		/* Note if desired expansion not actually set. */
	     (suffix_lens (i) >0)
	     then call com_err_ (0, "Speedtype", "^a suffix ^a invalid, ^a turned off",
		options (i), suffix_exps (i), options (i));
	end;

	call speedtype_info_$set_bc (ssd_ptr, ecode);

	return;
						/* 	*/
GET_NEW_SBX: procedure;

/*	This procedure will find a free symbol entry for the new symbol.
   *	It will always take the first free entry.
*/
	     sbx = ssd.num_symbols + 1;		/* Adding another symbol to list. */

	     if sbx > ssd.table_size            	/* Is this one too many symbols? */
	     then call speedtype_info_$expand_table (ssd_ptr, ecode);
	     
	end GET_NEW_SBX;


GET_OLD_SBX: procedure;

/*	This symbol is already defined.  Unless the caller has specified
   *	that we force the replacement we will ask him what he wants to do.
*/
	     if force_flag				/* Should we force the replacement? */
	     then return;				/* Yes. */

	     query_info.version = 1;			/* No, ask user what he wants to do. */
	     query_info.yes_no = "1"b;
	     query_info.suppress_name = "0"b;
	     query_info.status_code,
		query_info.other_code = 0;

	     call command_query_ (addr (query_info), answer, "Speedtype",
		"^a already defined. ^/Do you want to replace it?", symbol);

	     if answer = "no"			/* Does user want to replace this symbol? */
	     then sbx = 0;				/* No, make index invalid. */

	end GET_OLD_SBX;
						/* 	*/
GET_ARGS:	procedure;

/*	This procedure is called to process all of the command arguments.
*/
	     call cu_$arg_count (num_args);

	     if num_args < 2
	     then do;				/* Too few arguments. */
		ecode = error_table_$wrong_no_of_args;
		call com_err_ (ecode, "Speedtype", "Usage is:  asb symbol expansion {-control_args}");
		return;
	     end;

	     do argx = 1 to num_args;			/* Process each argument. */
		call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
		if ecode ^= 0
		then do;
		     call com_err_ (ecode, "Speedtype", "Error getting argument ^d", argx);
		     return;
		end;
		call PROCESS_ARG;			/* Process this argument. */
		if ecode ^= 0 then return;		/* Stop if any error. */
	     end;

	end GET_ARGS;
						/* 	*/
PROCESS_ARG: procedure;

/*	This procedure is called to process one or two command arguments.
*/
	     goto ARGUMENT (min (argx, 3));		/* Process according to position. */

ARGUMENT (1):					/* Symbol */
	     symbol = argument;			/* Save symbol, see if it is already defined. */
	     call speedtype_index_ (argument, ssd_ptr, sbx, ecode);
	     if ecode ^= 0 then return;

ARGUMENT (2):					/* Expansion */
	     if arg_len > length (exp.expansion)	/* Validate expansion length. */
	     then do;				/* It is too long. */
		ecode = error_table_$bad_arg;
		call com_err_ (ecode, "Speedtype", "Expansion ^a is too long", argument);
		return;
	     end;
	     expansion = argument;			/* Save expansion. */
	     exp_len = arg_len;			/* Save actual expansion length. */
	     return;

ARGUMENT (3):					/* Control argument(s) */
	     if (argument = "-fc") |			/* Check for force control argument. */
	     (argument = "-force")
	     then do;				/* It is the force control argument. */
		force_flag = "1"b;			/* User wants to force replacement. */
		return;
	     end;

	     option = argument;			/* Option argument pair, save option. */

	     argx = argx + 1;			/* Get index of value argument. */
	     if argx > num_args			/* Is there another argument? */
	     then do;				/* No, error. */
		ecode = error_table_$odd_no_of_args;
		call com_err_ (ecode, "Speedtype", "^a requires a value argument", option);
		return;
	     end;

/* Get value argument. */
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error getting argument ^d", argx);
		return;
	     end;

	     do optx = 1 to hbound (options, 1);	/* Look for option. */
		if option = options (optx)		/* Is this the option? */
		then goto OPTION (optx);		/* Yes, we found it. */
	     end;

	     ecode = error_table_$badopt;
	     call com_err_ (ecode, "Speedtype", "Control argument ^a unknown", option);
	     return;

OPTION (1): OPTION (2): OPTION (3):			/* SUFFIX option. */
OPTION (4): OPTION (5):
	     if argument = "on"			/* ON => default suffix action. */
	     then do;
		suffix_lens (optx) = 0;
		return;
	     end;
	     if argument = "off"			/* OFF => disable this suffix. */
	     then do;
		suffix_lens (optx) = -1;
		return;
	     end;
	     suffix_lens (optx) = arg_len;		/* Set up special action for this suffix. */
	     suffix_exps (optx) = argument;
	     return;

OPTION (6):					/* -suffix "on" | "off" */
	     if argument = "on"			/* ON => default action for all suffixes. */
	     then do;
		do i = 1 to hbound (suffix_lens, 1);
		     suffix_lens (i) = 0;
		end;
		return;
	     end;
	     if argument = "off"			/* OFF => disable all suffixes. */
	     then do;
		do i = 1 to hbound (suffix_lens, 1);
		     suffix_lens (i) = -1;
		end;
		return;
	     end;
	     ecode = error_table_$bad_arg;
	     call com_err_ (ecode, "Speedtype", "-suffix argument must be ""on"" or ""off""");
	     return;

	end PROCESS_ARG;

     end add_symbols;
  



		    change_symbols.pl1              02/04/82  1522.6rew 02/04/82  1254.0       73296


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

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

change_symbols: csb: procedure;

/*	This procedure implements the change_symbols command.
   *	Created on 05/20/76 by Bill Silver as change_notescript.
   *	Changed on 06/07/77 by Bill Silver to change_symbols.
   *      Changed on 10/28/80 by Paul Benjamin for special suffixing.
   *    
   *	The change_symbols command will change the suffixing or expansion
   *	of a symbol in the current Speedtype symbol dictionary.
   *	Its calling sequence is:
   *
   *	change_symbols, csb symbol -control_args
   *
   *	where:
   *
   *	     -plural AA	Defines this suffix.
   *	     -ed AA
   *	     -ing AA
   *	     -er AA
   *	     -ly AA
   *
   *	     -suffix "on" | "off"
   *
   *	     -exp  AA	Defines a new expansion for this symbol.
*/

/*		AUTOMATIC DATA		*/

dcl  arg_len fixed bin;				/* Length of a command argument. */
dcl  arg_ptr ptr;					/* Pointer to a command argument. */
dcl  argx fixed bin;				/* Index of current command argument. */
dcl  dir_name char (168);				/* Directory containing symbol dictionary. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  ent_name char (32);				/* Entry name of symbol dictionary. */
dcl  i fixed bin;
dcl  sbx fixed bin;					/* Index of symbol entry. */
dcl  temp_code fixed bin (35);			/* Used when already have non-zero ecode. */
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  option char (8);				/* Option argument. */
dcl  optx fixed bin;				/* Option argument index. */
dcl  suffix_len fixed bin;				/* Length of suffix expansion string. */


/*		BASED DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Command argument. */


/*		INTERNAL STATIC DATA	*/

dcl  options (7) char (8)				/* Control arg options. */
     internal static init ("-plural", "-ed", "-ing", "-er", "-ly",
     "-suffix", "-exp");


/*		EXTERNAL ENTRIES CALLED	*/

dcl (addr, hbound, length) builtin;

dcl  error_table_$bad_arg fixed bin (35) external;
dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$no_w_permission fixed bin(35) ext static;
dcl  error_table_$odd_no_of_args fixed bin (35) external;
dcl  error_table_$wrong_no_of_args fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  speedtype_index_ entry (char (*), ptr, fixed bin, fixed bin (35));
dcl  speedtype_info_$name entry (char (*), char (*), fixed bin (35));
dcl  speedtype_info_$pointer entry (ptr, fixed bin (35));
dcl  speedtype_suffix_  entry (ptr, ptr, ptr, fixed bin, ptr, fixed bin);
						/* 	*/
%include speedtype_symbols;
/* 	*/
/*	Begin change_symbols command.
*/

	call cu_$arg_count (num_args);		/* Get number of arguments. */
	if num_args < 3
	then do;
	     call com_err_ (error_table_$wrong_no_of_args, "Speedtype",
		"Usage is:  csb symbol -control_args");
	     return;
	end;

/* Get symbol argument. */
	call cu_$arg_ptr (1, arg_ptr, arg_len, ecode);
	if ecode ^= 0
	then do;
	     call com_err_ (ecode, "Speedtype", "Error getting symbol argument");
	     return;
	end;

	call speedtype_info_$pointer (ssd_ptr, ecode);
	if ecode ^= 0				/* Did we get a pointer to the symbol dictionary? */
	then do;
	     if ecode = error_table_$no_w_permission
		then do;
		call speedtype_info_$name (dir_name, ent_name, temp_code);
		call com_err_ (ecode, "Speedtype", "Attempting to convert ^a>^a to new version.", dir_name, ent_name);
	     end;
	     return;
	end;

	call speedtype_index_ (argument, ssd_ptr, sbx, ecode);
	if ecode ^= 0 then return;			/* Return if error getting symbol index. */
	if sbx = 0				/* Is symbol defined? */
	then do;					/* No, error. */
	     call com_err_ (0, "Speedtype", """^a"" not defined", argument);
	     return;
	end;

	sb_ptr = addr (ssd.sb_tab (sbx));		/* Get pointer to symbol entry. */
	exp_ptr = addr (ssd.exp_tab (sbx));		/* And expansion entry. */
	spc_ptr = addr (ssd.spec_tab (sbx));              /* AND special entry. */
	do argx = 2 to num_args while (ecode = 0);	/* Process the control arguments. */
	     call PROCESS_OPTION;			/* Process one option pair. */
	end;

	return;
						/* 	*/
PROCESS_OPTION: procedure;

/*	This procedure is called to process one option pair.
   *	Each pair consists of a control argument and a value argument.
*/
/* Get option argument. */
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error getting argument ^d", argx);
		return;
	     end;

	     option = argument;			/* Save option argument. */

	     argx = argx + 1;			/* Get index of value argument. */
	     if argx > num_args			/* Is there another argument? */
	     then do;				/* No, missing value argument. */
		ecode = error_table_$odd_no_of_args;
		call com_err_ (ecode, "Speedtype", "^a requires a value argument", option);
		return;
	     end;

/* Get value argument. */
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error getting argument ^d", argx);
		return;
	     end;

	     do optx = 1 to hbound (options, 1);	/* Look for option argument. */
		if option = options (optx)		/* Did we find it? */
		then goto OPTION (optx);		/* Yes, go process this option. */
	     end;

	     ecode = error_table_$badopt;		/* Option not found. */
	     call com_err_ (ecode, "Speedtype", "Argument ^a unknown", option);
	     return;

OPTION (1): OPTION (2): OPTION (3):			/* SUFFIX change option. */
OPTION (4): OPTION (5):
	     suffix_len = arg_len;			/* Get length of suffix expansion string. */
	     if argument = "on"			/* ON => use default action. */
	     then suffix_len = 0;
	     if argument = "off"			/* OFF => disable suffix. */
	     then suffix_len = -1;
	     call speedtype_suffix_ (sb_ptr, exp_ptr, spc_ptr, optx, arg_ptr, suffix_len);
	     if (exp.actionx (optx) = 0) &		/* Test if desired suffix not actually set. */
	     (suffix_len >0)
	     then call com_err_ (0, "Speedtype", "^a suffix ""^a"" invalid, ^a turned off",
		options (optx), argument, options (optx));
	     return;

OPTION (6):					/* "-suffix "yes","on" | "no","off"" */
	     suffix_len = 1;			/* Error if it remains = 1. */
	     if argument = "on"			/* ON => set all defaults. */
	     then suffix_len = 0;
	     if argument = "off"			/* OFF => disable all suffixes. */
	     then suffix_len = -1;
	     if suffix_len = 1			/* Was it "on" or "off"? */
	     then do;				/* No, error. */
		ecode = error_table_$bad_arg;
		call com_err_ (ecode, "Speedtype", "-suffix argument must be ""on"", or ""off""");
		return;
	     end;
	     do i = 1 to hbound (exp.actionx, 1);	/* Set each suffix. */
		call speedtype_suffix_ (sb_ptr, exp_ptr, spc_ptr, i, arg_ptr, suffix_len);
	     end;
	     return;

OPTION (7):					/* "-exp" */
						/* Is expansion argument a valid length? */
	     if length (argument) > length (exp.expansion)
	     then do;				/* No, expansion argument is too long. */
		ecode = error_table_$bad_arg;
		call com_err_ (ecode, "Speedtype", "-exp value argument is too long");
		return;
	     end;
	     exp.expansion = argument;
	     exp.len = length (argument);
	     return;

	end PROCESS_OPTION;

     end change_symbols;



		    delete_symbols.pl1              01/06/81  1251.1rew 01/06/81  1246.9       47745


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

delete_symbols: dsb: procedure;

/*	This procedure implements the delete_symbols command.
   *	Created on 10/15/75 by Bill Silver as delete_notescript.
   *	Changed on 06/07/77 by Bill Silver to delete_symbols.
   *      Changed on 10/28/80 by Paul Benjamin for special suffixing.
   *
   *	The delete_symbols command will delete one or more symbols from
   *	the current Speedtype symbol dictinary.  Its calling sequence is:
   *
   *	     delete_symbols, dsb symbols
*/

dcl  arg_len fixed bin;				/* Length of symbol argument. */
dcl  arg_ptr ptr;					/* Pointer to symbol argument. */
dcl  argx fixed bin;				/* Index of current argument. */
dcl  del_exp_ptr ptr;				/* Pointer to expansion being deleted. */
dcl  del_sb_ptr ptr;				/* Pointer to symbol being deleted. */
dcl  del_spc_ptr ptr;                                       /* Pointer to special entry being deleted. */
dcl  dir_name char (168);				/* Directory containing symbol dict. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  ent_name char (32);				/* Symbol dictionary. */
dcl  i fixed bin;
dcl  sbx fixed bin;					/* Symbol entry index. */
dcl  temp_code fixed bin (35);			/* Used when already hav non-zero ecode. */
dcl  num_args fixed bin;				/* Number of command arguments. */

dcl  argument char (arg_len) based (arg_ptr);		/* Command argument. */

dcl (addr, hbound, unspec) builtin;

dcl  error_table_$no_w_permission fixed bin(35) ext static;
dcl  error_table_$wrong_no_of_args fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  speedtype_index_ entry (char (*), ptr, fixed bin, fixed bin (35));
dcl  speedtype_info_$name entry (char(168), char(32), fixed bin(35));
dcl  speedtype_info_$pointer entry (ptr, fixed bin (35));
dcl  speedtype_info_$set_bc entry (ptr, fixed bin (35));
dcl  speedtype_info_$shrink_table entry (ptr, fixed bin(35));
						/* 	*/
%include speedtype_symbols;
/* 	*/
/*	Begin delete_symbols command.
*/
	call speedtype_info_$pointer (ssd_ptr, ecode);
	if ecode ^= 0				/* Did we get a pointer to symbol dictionary? */
	     then do;				/* No. */
	     if ecode = error_table_$no_w_permission
		then do;
		call speedtype_info_$name (dir_name, ent_name, temp_code);
		call com_err_ (ecode, "Speedtype", "Attempting to convert ^a>^a to new version.", dir_name, ent_name);
	     end;
	     return;
	end;

	call cu_$arg_count (num_args);		/* Check calling sequence. */
	if num_args = 0
	then do;
	     call com_err_ (error_table_$wrong_no_of_args, "Speedtype",
		"Usage is: dsb symbols");
	     return;
	end;

	do argx = 1 to num_args;			/* Process each argument. */
	     call DELETE_SYMBOL;			/* It is a symbol to be deleted. */
	     if ecode ^= 0 then return;		/* Stop if any error. */
	end;

	call speedtype_info_$set_bc (ssd_ptr, ecode);

	return;
						/* 	*/
DELETE_SYMBOL: procedure;

/*	This procedure is called to get and delete one symbols.
   *	We will call speedtype_index_ to get the symbol entry index
   *	that corresponds to this symbol.
*/
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error getting symbol argument");
		return;
	     end;

	     call speedtype_index_ (argument, ssd_ptr, sbx, ecode);
	     if ecode ^= 0				/* Was it a valid symbol? */
	     then return;				/* No. */

	     if sbx = 0				/* Is it defined? */
	     then do;				/* No. */
		call com_err_ (0, "Speedtype", """^a"" not defined", argument);
		return;
	     end;

	     del_sb_ptr = addr (ssd.sb_tab (sbx));	/* Get pointer to symbol being deleted. */
	     del_exp_ptr = addr (ssd.exp_tab (sbx));	/* And corresponding expansion entry. */
	     del_spc_ptr = addr (ssd.spec_tab (sbx));     /* AND corresponding special entry. */
	     sb_ptr = addr (ssd.sb_tab (ssd.num_symbols)); /* Get pointer to last symbol entry. */
	     exp_ptr = addr (ssd.exp_tab (ssd.num_symbols)); /* And corresponding expansion entry. */
	     spc_ptr = addr (ssd.spec_tab (ssd.num_symbols)); /* AND corresponding special entry. */

	     del_sb_ptr -> sb.symbol = " ";		/* Blank deleted symbol. */

	     del_exp_ptr -> exp = exp;		/* Replace expansion with last expansion. */
	     del_spc_ptr -> spc = spc;                    /* Replace special with last special. */
	     del_sb_ptr -> sb = sb;			/* Now replace symbol. */

	     ssd.num_symbols = ssd.num_symbols - 1;	/* Last entry no longer defined. */

	     unspec (exp) = "0"b;			/* Zero last entries. */
	     unspec (spc) = "0"b;
	     unspec (sb) = "0"b;			/* This may gain back a page of quota. */

	     if mod (ssd.num_symbols, 100) < mod (ssd.num_symbols - 1, 100)
		then call speedtype_info_$shrink_table (ssd_ptr, ecode);

	end DELETE_SYMBOL;

     end delete_symbols;
   



		    expand_symbols.pl1              01/06/81  1251.1rew 01/06/81  1247.2       50094


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

expand_symbols: esb: procedure;

/*	This procedure implements the expand_symbols command.
   *	Created on 10/15/75 by Bill Silver as run_notescript_.
   *	Changed on 06/07/77 by Bill Silver to expand_symbols_.
   *
   *	The expand_symbols command will copy an input segment into
   *	an output segment and in so doing expand each symbol that
   *	is found in the input segment and is defined in the current
   *	Speedtype symbol dictionary.  Its calling sequence is:
   *
   *	     expand_symbols, esb input_path (output_path)
*/

/*		AUTOMATIC DATA		*/
dcl  dir_name char (168);				/* Used to expand pathnames. */
dcl  ent_name char (32);				/* Used to expand pathnames. */

dcl  arg_len fixed bin;				/* Length of control argument. */
dcl  arg_ptr ptr;					/* Pointer to control argument. */
dcl  argx fixed bin;				/* Index of control argument. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  in_len fixed bin (21);				/* Length of unused part of input segment. */
dcl  in_ptr ptr;					/* Pointer to input segment. */
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  out_ptr ptr;					/* Pointer to output segment. */
dcl  out_len fixed bin (21);				/* Max length of output segment. */
dcl  out_used fixed bin (21);				/* Length of used part of output segment. */
dcl  temp_flag bit (1) aligned;			/* ON -> using temporary output segment. */

/*		BASED DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Control argument string. */

/*		EXTERNAL ENTRIES		*/

dcl (addr) builtin;

dcl  error_table_$wrong_no_of_args fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  speedtype_expand_ entry (ptr, fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  speedtype_util_$fix_output_seg entry (bit (1) aligned, ptr, ptr, fixed bin (21), fixed bin (35));
dcl  speedtype_util_$init_input_seg entry (char (*), char (*), ptr, fixed bin (21), fixed bin (35));
dcl  speedtype_util_$init_output_seg entry (char (*), char (*), ptr, fixed bin (21), fixed bin (35));
						/* 	*/
	call cu_$arg_count (num_args);		/* Test for correct number of arguments. */
	if (num_args < 1) |				/* Must have either 1 or 2 arguments. */
	(num_args > 2)
	then do;
	     ecode = error_table_$wrong_no_of_args;
	     call com_err_ (ecode, "Speedtype", "Usage is: esb input_path (output_path)");
	     return;
	end;

	temp_flag = "1"b;				/* Assume that we need a temporary output segment. */

	do argx = 1 to num_args;			/* Process each argument. */
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error getting argument ^d", argx);
		return;
	     end;
	     call PROCESS_ARG;			/* Process this argument. */
	     if ecode ^= 0 then return;		/* Give up if argument error. */
	end;

	if temp_flag				/* Do we need a temporary output segment? */
	then do;					/* Yes, use temporary segment in process directory. */
	     call speedtype_util_$init_output_seg ("", "speedtype_temp", out_ptr, out_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error creating temporary output segment");
		return;
	     end;
	end;

/* Now expand input segment. */
	call speedtype_expand_ (in_ptr, in_len, out_ptr, out_len, out_used, ecode);
	if ecode ^= 0
	then do;
	     call com_err_ (ecode, "Speedtype", "Error expanding input");
	     return;
	end;

/* Fix up output segment. */
	call speedtype_util_$fix_output_seg (temp_flag, in_ptr, out_ptr, out_used, ecode);
	if ecode ^= 0
	then call com_err_ (ecode, "Speedtype", "Error fixing output segment");

	return;
						/* 	*/
PROCESS_ARG: procedure;

/*	This procedure is called to process one input argument.
   *	The first argument must be the pathname of the input segment.
   *	The second, optional argument, must be the pathanme of the output segment.
*/
/* Expand the pathname argument. */
	     call expand_path_ (arg_ptr, arg_len, addr (dir_name), addr (ent_name), ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error expanding pathanme: ^a", argument);
		return;
	     end;

	     goto ARGUMENT (argx);			/* Go process correct argument. */

ARGUMENT (1):					/* Pathname of input segment. */
	     call speedtype_util_$init_input_seg (dir_name, ent_name, in_ptr, in_len, ecode);
	     if ecode ^= 0
	     then call com_err_ (ecode, "Speedtype", "Error initializing input segment");
	     return;

ARGUMENT (2):					/* Pathname of output segment. */
	     call speedtype_util_$init_output_seg (dir_name, ent_name, out_ptr, out_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error initializing output segment");
		return;
	     end;
	     if out_ptr ^= in_ptr			/* If output segment different from input segment. */
	     then temp_flag = "0"b;			/* Then no need for temporary output segment. */
	end PROCESS_ARG;

     end expand_symbols;
  



		    list_symbols.pl1                01/06/81  1251.1rew 01/06/81  1247.5      132120


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

list_symbols: lsb: procedure;

/*	This procedure implements the list_symbols and find_symbols commands.
   *	Created on 10/13/75 by Bill Silver as list_notescript.
   *	Changed on 06/07/77 by Bill Silver to list_symbols.
   *	Changed on 08/16/78 by R.J.C. Kissel to handle more than 253 symbols.
   *      Changed on 10/28/80 by Paul Benjamin for special suffixing.
   *
   *	The list_symbols/find_symbols commands will list one or several or all
   *	or the symbols/expansions in the currently defined Speedtype symbol dictionary.
   *	Their calling sequences are:
   *
   *	list_symbols, lsb  {symbols} {-control_args}
   *	find_symbols, fsb  {expansions}  {-control_args}
   *
   *	where:
   *
   *	     -lg, -long	Print suffix expansions.
   *	     -op, -option	Print option info.
   *	     -tt, -total	Print total number of defined symbols.
*/

dcl  sb_buf char (8);				/* Symbol buffer. */
dcl  exp_buf char (56);				/* Expansion buffer. */

/* Note above that 56 is really length(exp.expansion). */


dcl  arg_len fixed bin;				/* Length of symbol argument. */
dcl  arg_ptr ptr;					/* Pointer to symbol argument. */
dcl  argx fixed bin;				/* Index of current argument. */
dcl  dir_name char (168) aligned;			/* Directory name of symbol dictionary. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  ent_name char (32) aligned;			/* Entry name of symbol dictionary. */
dcl  exp_buf_len fixed bin;				/* Length of expansion buffer. */
dcl  exp_buf_ptr ptr;				/* Pointer to expansion buffer. */
dcl  exp_len fixed bin;				/* Length of expansion. */
dcl  found_flag bit (1);				/* ON => expansion found. */
dcl  i fixed bin;
dcl  item_len fixed bin;				/* Length of current item. */
dcl  item_ptr ptr;					/* Pointer to current item. */
dcl  itemx fixed bin;				/* Index of current item. */
dcl  list_flag bit (1);				/* ON => symbol,  OFF => expansion. */
dcl  listx fixed bin;				/* Type of listing index. */
dcl  long_flag bit (1);				/* ON => list suffixes. */
dcl  sb_buf_ptr ptr;				/* Pointer to symbol buffer. */
dcl  sb_len fixed bin;				/* Length of symbol. */
dcl  sbx fixed bin;					/* Table index of symbol. */
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  num_items fixed bin;				/* Number of items specified. */
dcl  num_sb fixed bin;				/* Number of possible symbol entries. */
dcl  option_flag bit (1);				/* ON => list options. */
dcl  optx fixed bin;				/* Index of control arg option. */
dcl  string_len fixed bin;				/* Length of sorting strings. */
dcl  suffix_char char (1);				/* Suffix character. */
dcl  temp_code fixed bin (35);			/* Used when already have non-zero ecode. */
dcl  total_flag bit (1);				/* ON => list totals. */
dcl  items (16) char (56);				/* Temporary storage for items. */

/* Note above that 56 is really length(exp.expansion). */

dcl  item_lens (16) fixed bin;			/* Length of each item. */


/*		BASED DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Command argument. */

dcl  expansion char (exp_len) based (exp_buf_ptr);	/* Used to print expanded symbol. */

dcl  item char (item_len) based (item_ptr);		/* Used to reference first argument. */


/*		INTERNAL STATIC DATA	*/

dcl  brief_options (4) char (4)
     internal static init ("-lg", "-op", "-tt", "");

dcl  long_options (4) char (8)
     internal static init ("-long", "-option", "-total", "");

dcl  suffix_names (5) char (8)			/* List of knwon suffix names. */
     internal static init ("plural", "ed", "ing", "er", "ly");

dcl  escape_names (5) char (8)			/* List of known escape names. */
     internal static init ("pad", "perm", "temp", "trans", "space");

dcl  prefix_names (2) char (8)
     internal static init ("under", "upper");


/*		EXTERNAL DATA		*/

dcl (addr, hbound, index, length, substr) builtin;

dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$no_w_permission fixed bin(35) ext static;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  speedtype_expand_ entry (ptr, fixed bin, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  speedtype_info_$name entry (char (168) aligned, char (32) aligned, fixed bin (35));
dcl  speedtype_info_$pointer entry (ptr, fixed bin (35));
dcl  speedtype_index_ entry (char (*), ptr, fixed bin, fixed bin (35));
dcl  speedtype_sort_ entry (ptr, fixed bin, fixed bin);
						/* 	*/
%include speedtype_symbols;
/* 	*/
/*	Entry for list_symbols, lsb
*/
	list_flag = "1"b;
	goto COMMON;

/*	Entry for find_symbols, fsb
*/
find_symbols: fsb: entry;

	list_flag = "0"b;


COMMON:
	listx,
	     num_items = 0;				/* Initialize control variables. */
	long_flag,
	     option_flag,
	     total_flag = "0"b;

	sb_buf_ptr = addr (sb_buf);			/* Set up pointers and lengths for suffix listing. */
	exp_buf_ptr = addr (exp_buf);
	exp_buf_len = length (exp_buf);

	call cu_$arg_count (num_args);		/* Get number of arguments. */

	if num_args = 0				/* Are there any arguments? */
	then listx = 1;				/* No, sort and list all. */
	else do argx = 1 to num_args;			/* Process all the arguments. */
	     call PROCESS_ARGUMENT;			/* Process one argument. */
	     if ecode ^= 0 then return;
	end;

	call speedtype_info_$pointer (ssd_ptr, ecode);
	if ecode ^= 0				/* Is there a valid Speedtype symbol dictionary? */
	then do;
	     if ecode = error_table_$no_w_permission
		then do;
		call speedtype_info_$name (dir_name, ent_name, temp_code);
		call com_err_ (ecode, "Speedtype", "Attempting to convert ^a>^a to new version.", dir_name, ent_name);
	     end;
	     return;
	end;

	if option_flag then call LIST_OPTION;		/* If told to, list the options. */

	num_sb = ssd.num_symbols;			/* Make sure there are defined symbols. */
	if num_sb = 0
	then do;
	     call ioa_ ("No symbols defined");
	     return;
	end;

	if total_flag				/* If told to, print total. */
	then if num_sb = 1
	     then call ioa_ ("Total:  1 symbol");
	     else call ioa_ ("Total:  ^d symbols", num_sb);

	goto LISTX (listx);				/* Go do selected type of listing. */

LISTX (0):					/* List only the total or options. */
	return;

LISTX (1):					/* List all symbols or expansions. */
	call speedtype_info_$name (dir_name, ent_name, ecode);
	if ecode = 0
	then call ioa_ ("Speedtype symbol dictionary:  ^a>^a", dir_name, ent_name);
	if ^total_flag				/* List total if not already done. */
	then if num_sb = 1
	     then call ioa_ ("Total:  1 symbol");
	     else call ioa_ ("Total:  ^d symbols", num_sb);
	call LIST_SORT;				/* List in sorted order. */
	return;

LISTX (2):
	do itemx = 1 to num_items;			/* List all items specified. */
	     item_ptr = addr (items (itemx));		/* Set up reference to item string. */
	     item_len = item_lens (itemx);
	     if list_flag				/* List item. */
	     then call LIST_SYMBOL;			/* Item is a symbol. */
	     else call LIST_EXPANSION;		/* Item is a expansion. */
	end;
	return;
						/* 	*/
LIST_SORT: procedure;

/*	This procedure will list all symbol entries defined in the
   *	symbol dictionary currently in use.  They will be listed
   *	in ASCII collating sequence.
*/
dcl  vex fixed bin;					/* Local index. */
dcl  tseg_ptr (1) ptr;
dcl  vector_ptr ptr;

dcl 1 vector (num_sb) based (vector_ptr),		/* Structure for sorting. */
    2 string_ptr ptr,
    2 isbx fixed bin;				/* Rename to get around name-scope problem. */

dcl  get_temp_segments_ entry (char (*), (*)ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), (*)ptr, fixed bin (35));

dcl  cleanup condition;

	     call get_temp_segments_ ("list_symbols", tseg_ptr, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype");
		return;
	     end;

	     on cleanup
		begin;
		if tseg_ptr (1) ^= null ()
		then call release_temp_segments_ ("list_symbols", tseg_ptr, ecode);
	     end;

	     vector_ptr = tseg_ptr (1);

	     do vex = 1 to num_sb;			/* Put each entry in the sorting list. */
		vector (vex).isbx = vex;		/* Save symbol index. */
		if list_flag			/* List => sort symbols, Find => expansions. */
		then vector (vex).string_ptr = addr (ssd.sb_tab (vex));
		else vector (vex).string_ptr = addr (ssd.exp_tab (vex).expansion);
	     end;

	     if list_flag				/* Now sort list of symbols or expansions. */
	     then string_len = 8;			/* Symbol length. */
	     else string_len = length (exp.expansion);	/* Expansion length. */

	     call speedtype_sort_ (vector_ptr, num_sb, string_len);

	     do vex = 1 to num_sb;			/* List each symbol in sorted order. */
		sbx = vector (vex).isbx;		/* Get symbol index. */
		call DISPLAY_SYMBOL;		/* List information about this symbol. */
	     end;

	     call release_temp_segments_ ("list_symbols", tseg_ptr, ecode);

	end LIST_SORT;
						/* 	*/
LIST_SYMBOL: procedure;

/*	This procedure is called to list just one symbol.
*/

	     call speedtype_index_ (item, ssd_ptr, sbx, ecode);
	     if ecode ^= 0				/* Is this a valid symbol? */
	     then return;				/* No. */

	     if sbx > 0				/* Is this symbol defined? */
	     then call DISPLAY_SYMBOL;		/* Yes, list it. */
	     else call com_err_ (0, "Speedtype", "Symbol ""^a"" not defined", item);

	end LIST_SYMBOL;


LIST_EXPANSION: procedure;

/*	This procedure will look for and list a specified expansion.
   *	If it finds it it will display information about the symbol that
   *	represents this expansion.  All symbols representing this expansion
   *	will be listed.
*/

	     found_flag = "0"b;			/* Assume expansion not found. */

	     do sbx = 1 to num_sb;			/* Search expansion table. */
		exp_ptr = addr (ssd.exp_tab (sbx));	/* Get pointer to expansion entry. */
		if exp.expansion = item		/* Is this the one we are looking for. */
		then do;				/* Yes, expansion matches. */
		     call DISPLAY_SYMBOL;		/* List this symbol. */
		     found_flag = "1"b;		/* Note that expansion found. */
		end;
	     end;

	     if ^found_flag				/* Tell user if expansion not found. */
	     then call com_err_ (0, "Speedtype", "Expansion ""^a"" not defined", item);

	end LIST_EXPANSION;
						/* 	*/
DISPLAY_SYMBOL: procedure;

/*	This procedure is called to display information about one symbol.
*/

	     sb_ptr = addr (ssd.sb_tab (sbx));		/* Get pointer to symbol entry. */
	     exp_ptr = addr (ssd.exp_tab (sbx));	/* Get pointer to expansion entry. */

	     if list_flag				/* List => symbol first. */
	     then call ioa_ ("^a^-^a", sb.symbol, exp.expansion);
	     else call ioa_ ("^a  -  ^a", exp.expansion, sb.symbol);

	     if ^long_flag				/* If no long flag then all done. */
	     then return;

	     sb_buf = sb.symbol;			/* Copy symbol into work buffer. */
	     sb_len = index (sb_buf, " ");		/* Get length of symbol. */
	     if sb_len = 0 then sb_len = length (sb_buf);

	     do i = 1 to hbound (exp.actionx, 1);	/* Generate expansion with each suffix. */
		if exp.actionx (i) ^= 0		/* Is this suffix defined? */
		then do;				/* Yes, add suffix and expand. */
		     suffix_char,			/* Save suffix character. */
			substr (sb_buf, sb_len, 1) = substr (ssd.suffixes, i, 1);
		     call speedtype_expand_ (sb_buf_ptr, sb_len, exp_buf_ptr, exp_buf_len, exp_len, ecode);
		     if ecode ^= 0
		     then do;
			call com_err_ (ecode, "Speedtype", "Error expanding ^a", sb_buf);
			return;
		     end;				/* Next line lists suffix and expansion. */
		     call ioa_ ("^6x(^a) ^a", suffix_char, expansion);
		end;
	     end;
	     call ioa_ (" ");			/* Skip a line. */

	end DISPLAY_SYMBOL;
						/* 	*/
LIST_OPTION: procedure;

/*	This procedure is called to list the options found in the
   *	header of the current Speedtype symbol dictionary.
*/
	     call speedtype_info_$name (dir_name, ent_name, ecode);
	     if ecode = 0
	     then call ioa_ ("^/Options for Speedtype symbol dictionary:  ^a>^a", dir_name, ent_name);

	     call ioa_ ("Speedtype Version (^d)", ssd.version);

	     call ioa_ ("Suffixes:");
	     do i = 1 to hbound (suffix_names, 1);	/* List each suffix character. */
		call ioa_ ("^5x^10a""^a""", suffix_names (i), substr (ssd.suffixes, i, 1));
	     end;

	     call ioa_ ("Prefixes:");
	     do i = 1 to hbound (prefix_names, 1);	/* List each prefix character. */
		call ioa_ ("^5x^10a""^a""", prefix_names (i), substr (ssd.prefixes, i, 1));
	     end;

	     call ioa_ ("Escapes:");
	     do i = 1 to hbound (escape_names, 1);	/* List each escape character. */
		call ioa_ ("^5x^10a""^a""", escape_names (i), substr (ssd.escapes, i, 1));
	     end;

	     delim_ptr = addr (ssd.delimiters);
	     call ioa_ ("Delimiters:  ""^a""", delim_chars.others);

	end LIST_OPTION;
						/* 	*/
PROCESS_ARGUMENT: procedure;

/*	This procedure is called to process one argument.
*/
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error getting argument ^d", argx);
		return;
	     end;

	     if substr (argument, 1, 1) ^= "-"		/* If argument is not a control argument. */
	     then do;				/* It is a symbol or an expansion item. */
		listx = 2;			/* List items. */
		if num_items = hbound (items, 1)	/* Too many items? */
		then do;				/* Yes, reject this item. */
		     call com_err_ (0, "Speedtype", "Cannot list more than ^d symbols.", num_items);
		     return;
		end;
		num_items = num_items + 1;		/* Another item in the list. */
		items (num_items) = argument;		/* Add item to list. */
		item_lens (num_items) = arg_len;	/* Save length of item. */
		return;
	     end;

	     do optx = 1 to hbound (long_options, 1);	/* See if this a valid control argument. */
		if (argument = brief_options (optx)) |
		(argument = long_options (optx))
		then goto OPTION (optx);		/* Found it, go process it. */
	     end;

	     ecode = error_table_$badopt;
	     call com_err_ (ecode, "Speedtype", "Argument ^a unknown", argument);
	     return;

OPTION (1):					/* "-lg" or "-long" */
	     long_flag = "1"b;
	     if listx = 0 then listx = 1;		/* "-long" => list all by default. */
	     return;

OPTION (2):					/* "-op" or "-option" */
	     option_flag = "1"b;
	     return;

OPTION (3):					/* "-tt" or "-total" */
	     total_flag = "1"b;
	     return;

	end PROCESS_ARGUMENT;

     end list_symbols;



		    option_symbols.pl1              01/06/81  1251.1rew 01/06/81  1247.6       65844


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

option_symbols: osb: procedure;

/*	This procedure implements the option_symbols command.
   *	Created on 05/20/76 by Bill Silver as option_notescript.
   *	Changed on 06/08/77 by Bill Silver to option_symbols.
   *      Changed on 10/28/80 by Paul Benjamin for special suffixing.
   *
   *	The option_symbols command will set the special characters
   *	contained in the current Speedtype symbol dictionary.
   *	its calling sequence is:
   *
   *	option_symbols, osb {-control_args}
   *
   *	where:
   *
   *	     -plural A		Set specified SUFFIX character.
   *	     -ed A
   *	     -ing A
   *	     -er A
   *	     -ly A
   *
   *	     -pad A		Set specified ESCAPE character.
   *	     -perm A
   *	     -temp A
   *	     -trans A
   *	     -space A

   *	     -under A		Set specified PREFIX character.
   *	     -upper A
   *
   *	     -delim AA		/* Specify other delimiters.
*/

/*		AUTOMATIC DATA		*/

dcl  arg_len fixed bin;				/* Length of a command argument. */
dcl  arg_ptr ptr;					/* Pointer to a command argument. */
dcl  argx fixed bin;				/* Index of current command argument. */
dcl  dir_name char (168);				/* Directory of symbol dictionary. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  ent_name char (32);				/* Name of symbol dictionary. */
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  option char (8);				/* Option control argument. */
dcl  optx fixed bin;				/* Option index. */
dcl  temp_code fixed bin (35);			/* Used when already have non-zero ecode. */

/*		BASED DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Command argument. */


/*		INTERNAL STATIC DATA	*/

dcl  options (13) char (8)				/* Control argument options. */
     internal static init ("-plural", "-ed", "-ing", "-er", "-ly",
     "-pad", "-perm", "-temp", "-trans", "-space",
     "-under", "-upper", "-delim");


/*		EXTERNAL ENTRIES CALLED	*/

dcl (addr, hbound, length, substr) builtin;

dcl  error_table_$bad_arg fixed bin (35) external;
dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$no_w_permission fixed bin(35) ext static;
dcl  error_table_$odd_no_of_args fixed bin (35) external;
dcl  error_table_$wrong_no_of_args fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  speedtype_info_$name entry (char (*), char (*), fixed bin (35));
dcl  speedtype_info_$pointer entry (ptr, fixed bin (35));
						/* 	*/
%include speedtype_symbols;
/* 	*/
	call speedtype_info_$pointer (ssd_ptr, ecode);
	if ecode ^= 0				/* Did we get a pointer to the symbol dictionary? */
	     then do;				/* No. */
	     if ecode = error_table_$no_w_permission
		then do;
		call speedtype_info_$name (dir_name, ent_name, temp_code);
		call com_err_ (ecode, "Speedtype", "Attempting to convert ^a>^a to new version.", dir_name, ent_name);
	     end;
	     return;
	end;

	call cu_$arg_count (num_args);		/* Get number of arguments. */
	if num_args = 0				/* Is there at least one argument? */
	then do;					/* No, error. */
	     call com_err_ (error_table_$wrong_no_of_args, "Speedtype", "No arguments");
	     return;
	end;

	ecode = 0;				/* Initialize error code. */

	do argx = 1 to num_args while (ecode = 0);	/* Process all of the control arguments. */
	     call PROCESS_OPTION;
	end;

	return;
						/* 	*/
PROCESS_OPTION: procedure;

/*	This procedure is called to process the control arguments to
   *	this command.  These control arguments all come in pairs with a
   *	control argument followed by a value argument.
*/
/* Get the control argument. */
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error getting argument ^d", argx);
		return;
	     end;

	     option = argument;			/* Save control argument. */

	     argx = argx + 1;			/* Next argument is value argument. */
	     if argx > num_args			/* Is there a next argument? */
	     then do;				/* No, value argument is missing. */
		ecode = error_table_$odd_no_of_args;
		call com_err_ (ecode, "Speedtype", "^a requires a value argument", option);
		return;
	     end;
						/* Get value argument. */
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error getting argument ^d", argx);
		return;
	     end;

	     do optx = 1 to hbound (options, 1);	/* Look up option. */
		if option = options (optx)		/* Is this a known option? */
		then goto OPTION (optx);		/* Yes, go process this option. */
	     end;

	     ecode = error_table_$badopt;		/* Option not known. */
	     call com_err_ (ecode, "Speedtype", "Control argument ^a unknown", option);
	     return;

OPTION (1): OPTION (2): OPTION (3):			/* Defining a SUFFIX character. */
OPTION (4): OPTION (5):
	     call CHECK_CHARACTER;			/* Is this a valid suffix character? */
	     if ecode ^= 0 then return;		/* No. */
	     substr (ssd.suffixes, optx, 1) = argument;	/* Yes, set this suffix character. */
	     return;

OPTION (6): OPTION (7): OPTION (8):			/* Defining an ESCAPE character. */
OPTION (9): OPTION (10):
	     call CHECK_CHARACTER;			/* Is this a valid escape character? */
	     if ecode ^= 0 then return;		/* No. */
	     optx = optx - 5;			/* Turn option index into an escape index. */
	     substr (ssd.escapes, optx, 1) = argument;	/* Set escape character. */
	     delim_ptr = addr (ssd.delimiters);		/* Update delimiter escapes too. */
	     delim_chars.escapes = ssd.escapes;
	     return;				/* Escape character has been set. */

OPTION (11): OPTION (12):				/* Defining a PREFIX character. */
	     call CHECK_CHARACTER;			/* Is this a valid prefix character? */
	     if ecode ^= 0 then return;		/* No. */
	     optx = optx - 10;			/* Turn option index into a prefix index. */
	     substr (ssd.prefixes, optx, 1) = argument;	/* Set prefixes character. */
	     return;

OPTION (13):					/* Set DELIMITERS. */
	     if arg_len > length (delim_chars.others)	/* Is new delimiter string too long? */
	     then do;				/* Yes, too long. */
		ecode = error_table_$bad_arg;
		call com_err_ (ecode, "Speedtype", "Delimiter string ""^a"" is too long", argument);
		return;
	     end;
	     delim_ptr = addr (ssd.delimiters);		/* Set up to reference delimiters. */
	     delim_chars.others = argument;		/* Set delimiter characters. */
	     return;

	end PROCESS_OPTION;


CHECK_CHARACTER: procedure;

/*	This procedure checks to see that the new suffix, escape, or prefix character
   *	is valid.
*/
	     if arg_len > 1				/* Must be only one character. */
	     then do;
		ecode = error_table_$bad_arg;
		call com_err_ (ecode, "Speedtype", "^a argument ""^a"" is too long", option, argument);
		return;
	     end;

	end CHECK_CHARACTER;

     end option_symbols;



		    print_symbols_path.pl1          01/06/81  1251.1rew 01/06/81  1247.6       15372


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

print_symbols_path: psbp: procedure;

/*	This procedure implements the print_symbols_path command.
   *	Created on 10/13/75 by Bill Silver as show_notescript.
   *	Changed on 06/10/77 by Bill Silver to print_symbols_path.
   *
   *	The print_symbols_path (psbp) command prints the pathanme of the current
   *	Speedtype symbol dictionary.  This command takes no arguments.
*/

dcl  ecode fixed bin (35);				/* Error table code. */
dcl  dir_name char (168);				/* Directory of current symbol dictionary. */
dcl  ent_name char (32);				/* Entry name of current symbol dictionary. */
dcl  num_args fixed bin;				/* Number of command arguments. */

dcl  error_table_$wrong_no_of_args fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  ioa_ entry options (variable);
dcl  speedtype_info_$name entry (char (*), char (*), fixed bin (35));


	call cu_$arg_count (num_args);
	if num_args ^= 0
	then do;
	     call com_err_ (error_table_$wrong_no_of_args, "Speedtype", "Usage is:  psbp");
	     return;
	end;

	call speedtype_info_$name (dir_name, ent_name, ecode);
	if ecode = 0
	then call ioa_ ("Using Speedtype symbol dictionary: ^a>^a", dir_name, ent_name);

     end print_symbols_path;



		    retain_symbols.pl1              01/06/81  1251.1rew 01/06/81  1247.6       59571


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

retain_symbols: rsb: procedure;

/*	This procedure implements the retain_symbols command.
   *	Created on 02/04/76 by Bill Silver as escape_notescript.
   *	Changed on 06/10/77 by Bill Silver as retain_symbols.
   *
   *	The retain_symbols (rsb) command takes an input segment and inserts escapes
   *	wherever text would be expanded by the expand_symbols command.
   *	Its calling sequence is:
   *
   *	     retain_symbols, rsn input_path (output_path) (-perm | -temp)
*/

/*		AUTOMATIC DATA		*/
dcl  dir_name char (168);				/* Used to expand pathnames. */
dcl  ent_name char (32);				/* Used to expand pathnames. */

dcl  arg_len fixed bin;				/* Length of control argument. */
dcl  arg_ptr ptr;					/* Pointer to control argument. */
dcl  argx fixed bin;				/* Index of control argument. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  in_len fixed bin (21);				/* Length of unused part of input segment. */
dcl  in_ptr ptr;					/* Pointer to input segment. */
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  out_ptr ptr;					/* Pointer to output segment. */
dcl  out_len fixed bin (21);				/* Max length of output segment. */
dcl  out_used fixed bin (21);				/* Length of used part of output segment. */
dcl  perm_flag bit (1) aligned;			/* ON => permanent escape, OFF => temporary escape. */
dcl  temp_flag bit (1) aligned;			/* ON -> using temporary output segment. */

/*		BASED DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Control argument string. */

/*		EXTERNAL ENTRIES		*/

dcl (addr, substr) builtin;

dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$wrong_no_of_args fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  speedtype_retain_ entry (bit (1) aligned, ptr, fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  speedtype_util_$fix_output_seg entry (bit (1) aligned, ptr, ptr, fixed bin (21), fixed bin (35));
dcl  speedtype_util_$init_input_seg entry (char (*), char (*), ptr, fixed bin (21), fixed bin (35));
dcl  speedtype_util_$init_output_seg entry (char (*), char (*), ptr, fixed bin (21), fixed bin (35));
						/* 	*/
	call cu_$arg_count (num_args);		/* Test for correct number of arguments. */
	if (num_args < 1) |				/* Must have either 1 or 2 or 3 arguments. */
	(num_args > 3)
	then do;
	     ecode = error_table_$wrong_no_of_args;
	     call com_err_ (ecode, "Speedtype", "Usage is: rsb input_path (output_path) (-perm | -temp");
	     return;
	end;

	perm_flag,				/* Default is to use permanent escape. */
	     temp_flag = "1"b;			/* Assume that we need a temporary output segment. */

	do argx = 1 to num_args;			/* Process each argument. */
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error getting argument ^d", argx);
		return;
	     end;
	     call PROCESS_ARG;			/* Process this argument. */
	     if ecode ^= 0 then return;		/* Give up if argument error. */
	end;

	if temp_flag				/* Do we need a temporary output segment? */
	then do;					/* Yes, use temporary segment in process directory. */
	     call speedtype_util_$init_output_seg ("", "speedtype_temp", out_ptr, out_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error creating temporary output segment");
		return;
	     end;
	end;

/* Now expand input segment. */
	call speedtype_retain_ (perm_flag, in_ptr, in_len, out_ptr, out_len, out_used, ecode);
	if ecode ^= 0
	then do;
	     call com_err_ (ecode, "Speedtype", "Error processing input");
	     return;
	end;

/* Fix up output segment. */
	call speedtype_util_$fix_output_seg (temp_flag, in_ptr, out_ptr, out_used, ecode);
	if ecode ^= 0
	then call com_err_ (ecode, "Speedtype", "Error fixing output segment");

	return;
						/* 	*/
PROCESS_ARG: procedure;

/*	This procedure is called to process one input argument.
   *	The first argument must be the pathname of the input segment.
   *	The second, optional argument, may be the pathanme of the output segment.
   *	An optional control argument may specify which escape character to use.
*/
	     goto ARGUMENT (argx);			/* Go process argument. */

ARGUMENT (1):					/* Pathname of input segment. */
	     call expand_path_ (arg_ptr, arg_len, addr (dir_name), addr (ent_name), ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error expanding input pathanme: ^a", argument);
		return;
	     end;
	     call speedtype_util_$init_input_seg (dir_name, ent_name, in_ptr, in_len, ecode);
	     if ecode ^= 0
	     then call com_err_ (ecode, "Speedtype", "Error initializing input segment");
	     return;

ARGUMENT (2):					/* Pathname of output segment. */
	     if substr (argument, 1, 1) = "-"		/* Is this a control argument? */
	     then goto ARGUMENT (3);			/* Yes, process as such. */
	     call expand_path_ (arg_ptr, arg_len, addr (dir_name), addr (ent_name), ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error expanding output pathname: ^a", argument);
		return;
	     end;
	     call speedtype_util_$init_output_seg (dir_name, ent_name, out_ptr, out_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error initializing output segment");
		return;
	     end;
	     if out_ptr ^= in_ptr			/* If output segment different from input segment. */
	     then temp_flag = "0"b;			/* Then no need for temporary output segment. */
	     return;

ARGUMENT (3):					/* (-temp | -perm) */
	     if argument = "-perm"			/* This is the default. */
	     then return;				/* Everything already set up. */
	     if argument = "-temp"			/* Temporary escape? */
	     then perm_flag = "0"b;			/* Yes. */
	     else do;				/* No, illegal control argument. */
		ecode = error_table_$badopt;
		call com_err_ (ecode, "Speedtype", "Unknown control argument: ^a", argument);
	     end;
	     return;

	end PROCESS_ARG;
     end retain_symbols;
 



		    show_symbols.pl1                01/06/81  1251.1rew 01/06/81  1247.6       30294


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

show_symbols: ssb: procedure;

/*	This procedure implements the show_symbols command.
   *	Created on 12/29/75 by Bill Silver as test_notescript.
   *	Changed on 06/10/77 by Bill Silver to show_symbols.
   *
   *	The show_symbols (ssb) command will expand an input string using
   *	the currently defined Speedtype symbol dictionary.
   *	Its calling sequence is:
   *
   *	     show_symbols, ssb  term1 ... termi
*/

dcl  in_buffer char (256);				/* Used to hold input string. */
dcl  out_buffer char (512);				/* Used to hold expanded stroutg. */

dcl  arg_len fixed bin (21);				/* Length of an input term argument. */
dcl  arg_ptr ptr;					/* Pointer to an argument term. */
dcl  argx fixed bin;				/* Number of argument term. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  in_len fixed bin (21);				/* Length of input string. */
dcl  in_ptr ptr;					/* Pointer to input string. */
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  out_used fixed bin (21);				/* Length of output string. */

dcl  argument char (arg_len) based (arg_ptr);

dcl  string char (in_len) based (in_ptr);		/* Input string. */

dcl (addr, length, substr) builtin;

dcl  error_table_$bad_arg fixed bin (35) external;
dcl  error_table_$wrong_no_of_args fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  speedtype_expand_ entry (ptr, fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (35));
						/* 	*/
	call cu_$arg_count (num_args);
	if num_args = 0
	then do;
	     ecode = error_table_$wrong_no_of_args;
	     call com_err_ (ecode, "Speedtype", "Usage is:  ssb term1 ... termi");
	     return;
	end;

	in_buffer = " ";				/* Clear input buffer. */
	in_ptr = addr (in_buffer);
	in_len = 0;

	do argx = 1 to num_args;			/* Each argument is an input term. */
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "Speedtype", "Error getting argument");
		return;
	     end;
	     if (in_len + arg_len) > length (in_buffer)
	     then do;				/* Length of input buffer exceeded. */
		ecode = error_table_$bad_arg;
		call com_err_ (ecode, "Speedtype", "Length of input buffer exceeded.");
		return;
	     end;
	     if argx > 1				/* Is this the second or greater term? */
	     then in_len = in_len + 1;		/* Yes, sikp a space. */
						/* Copy term to input string. */
	     substr (in_buffer, (in_len + 1), (in_len + 1 + arg_len)) = argument;
	     in_len = in_len + arg_len;
	end;

	call speedtype_expand_ (in_ptr, in_len, addr (out_buffer), length (out_buffer), out_used, ecode);
	if ecode = 0
	then call ioa_ ("^a", substr (out_buffer, 1, out_used));
	else call com_err_ (0, "Speedtype", "Error expanding ^a", string);

     end show_symbols;
  



		    speedtype_expand_.pl1           01/06/81  1251.1rew 01/06/81  1248.1      197352


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

speedtype_expand_: procedure (arg_in_ptr, arg_in_len, arg_out_ptr, arg_out_len, arg_out_used, arg_ecode);

/*	This procedure is an internal and external interface of the Speedtype subsystem.
   *	Created on 12/29/75 by Bill Silver as notescript_expand_.
   *	Changed on 06/13/77 by Bill Silver to speedtype_expand_.
   *      Changed on 06/03/80 by Paul Benjamin to add special suffixing.
*/
/*		ARGUMENTS			*/

dcl  arg_ecode fixed bin (35);			/* (O) error_table code. */
dcl  arg_in_len fixed bin (21);			/* (I) Length of input string in characters. */
dcl  arg_in_ptr ptr;				/* (I) Pointer to input string. */
dcl  arg_out_len fixed bin (21);			/* (I) Length of output buffer in characters. */
dcl  arg_out_ptr ptr;				/* (I) Pointer to output buffer. */
dcl  arg_out_used fixed bin (21);			/* (O) Actual length of output in characters. */


/*		AUTOMATIC DATA		*/

dcl  symbol_buffer char (8);				/* Holds symbol string. */
dcl  exp_buffer char (300);				/* Holds modified expansion. */

dcl  continue_flag bit (1);				/* ON => continue prefix processing. */
dcl  convert_flag bit (1);				/* ON => convert perm escape to pad escape. */
dcl  escape_flag bit (1);				/* ON => escape next text token. */
dcl  first_flag bit (1);				/* ON => first letter of symbol is a capital. */
dcl  period_flag bit (1);				/* ON => last character of symbol is a period. */
dcl  prefix_flag bit (1);				/* ON => symbol preceded by prefix character(s). */
dcl  under_flag bit (1);				/* ON => underline processing. */
dcl  upper_flag bit (1);				/* ON => uppercase processing. */

dcl  actionx fixed bin;				/* Used to process suffixes. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  first_char_ptr ptr;				/* Pointer to first output character. */
dcl  i fixed bin;
dcl  in_len fixed bin (21);				/* Length of unused part of input string. */
dcl  in_ptr ptr;					/* Pointer to input string. */
dcl  in_used fixed bin;				/* Length of used part of input string. */
dcl  last_char char (1);				/* Used for adding "ing". */
dcl  sb_tab_len fixed bin;				/* Length of defined symbol entry table. */
dcl  sb_tab_ptr ptr;				/* Pointer to symbol table. */
dcl  sbx fixed bin;					/* Symbol table entry index. */
dcl  out_len fixed bin (21);				/* Length of actual output. */
dcl  out_ptr ptr;					/* Pointer to output string. */
dcl  out_used fixed bin (21);				/* Length of used part of output string. */
dcl  space_count fixed bin;				/* Number of spaces to add. */
dcl  startx fixed bin;				/* Start of underscore triplet in work buffer. */
dcl  suffix char (4) varying;				/* Used to add a suffix string. */
dcl  suffix_len fixed bin;				/* Length of the suffix string. */
dcl  suffixx fixed bin;				/* Index of suffix character. */
dcl  symbol_len fixed bin;				/* Length of actual symbol. */
dcl  symbol_ptr ptr;				/* Pointer to actual symbol. */
dcl  test_char char (1);
dcl  token_len fixed bin;				/* Length of one token. */
dcl  token_ptr ptr;					/* Pointer to a token. */
dcl  x fixed bin;


/*		BASED DATA		*/

dcl 1 input based (in_ptr) aligned,			/* Overlay of input string. */
    (2 used char (in_used),				/* Part of segment that has been processed. */
    2 text char (in_len)) unaligned;			/* Part of segment still to be processed. */

dcl 1 output based (out_ptr) aligned,			/* Overlay of output string. */
    (2 used char (out_used),				/* Part of segment that has been processed. */
    2 text char (1)) unaligned;			/* Beginning of unprocessed part. */

dcl  sb_table char (sb_tab_len) based (sb_tab_ptr) aligned;

dcl  symbol char (symbol_len) based (symbol_ptr);		/* Overlay of actual symbol. */
dcl  token char (token_len) based (token_ptr);		/* Overlay of one token string. */

dcl  token_first_char char (1) based (token_ptr);


/*		INTERNAL STATIC DATA	*/

dcl  spaces char (99)				/* Used to fill in spaces. */
     internal static init (" ");

dcl  backspace char (1)				/* Used to underscore a token. */
     internal static init ("");

dcl  caps char (26) aligned				/* Capital letters in frequency order. */
     internal static init ("EAIOUSTCYHNLMRWFGPBDJQKXVZ");

dcl  lowers char (26) aligned				/* Lower case letters in the same order. */
     internal static init ("eaioustcyhnlmrwfgpbdjqkxvz");

dcl  suffix_strings (5) char (4) varying aligned
     internal static init ("s", "ed", "ing", "er", "ly");

dcl  period char (1)				/* Used to move a period character. */
     internal static init (".");


/*		EXTERNAL ENTRIES		*/

dcl (addr, fixed, index, length, search, substr, verify) builtin;

dcl  error_table_$item_too_big fixed bin (35) external;

dcl  speedtype_info_$pointer entry (ptr, fixed bin (35));
						/* 	*/
%include speedtype_symbols;
/* 	*/
/*	Begin Expansion
*/
	in_ptr = arg_in_ptr;			/* Copy arguments and initialize. */
	in_len = arg_in_len;
	out_ptr = arg_out_ptr;
	out_len = arg_out_len;

	in_used,
	     out_used,
	     ecode = 0;

	call INIT_SYMBOL_DICT;			/* Set up to use current Speedtype symbol dictionary. */
	if ecode ^= 0 then goto RETURN;

	do while ((in_len > 0) & (ecode = 0));		/* Copy input to output until no more input. */
	     call COPY_DELIMITERS;			/* Copy all delimiters up to next token. */
	     call COPY_TEXT;			/* Copy next text token. */
	end;

RETURN:
	arg_out_used = out_used;			/* Return number of chars in output string. */
	arg_ecode = ecode;
	return;


MOVE_OUT:	procedure;

/*	This procedure is called to move the current token string
   *	into the output string.  It will make sure that there is
   *	enough room in the output string.
*/
	     if token_len = 0 then return;		/* No token => nothing to do. */

	     if (out_used + token_len) > out_len	/* Is there room for this output? */
	     then do;				/* No. */
		token_len = out_len - out_used;	/* Make equal to actual length of token moved. */
		ecode = error_table_$item_too_big;
	     end;

	     addr (output.text) -> token = token;	/* Copy token into output. */

	     out_used = out_used + token_len;		/* Move output pointer over token. */

	end MOVE_OUT;
						/* 	*/
COPY_DELIMITERS: procedure;

/*	This procedure is called to copy all delimiters up to the next token
   *	or up to the end of the input string.
*/
	     token_ptr = addr (input.text);		/* Copy delimiters as a token. */
	     token_len = verify (input.text, ssd.delimiters); /* Position to next non-delimiter character. */

	     if token_len > 0			/* Did we hit a real token? */
	     then token_len = token_len - 1;		/* Yes, get real length of delimiter token. */
	     else token_len = in_len;			/* No, we hit the end of the input string. */

	     if token_len = 0 then return;		/* If no delimiters return. */

	     in_used = in_used + token_len;		/* Move window on input string. */
	     in_len = in_len - token_len;

	     call CHECK_ESCAPES;			/* Process any escape delimiters. */

	     call MOVE_OUT;				/* Copy delimiters into output string. */

	     if convert_flag			/* Was there a perm escape? */
	     then do;				/* Yes, convert to pad escape. */
		substr (output.used, out_used, 1) = substr (ssd.escapes, 1, 1);
		convert_flag = "0"b;
	     end;

	     if continue_flag			/* Was there a trans escape? */
	     then continue_flag = "0"b;		/* Yes, just turn off flag. */
	     else do;				/* No, turn off all prefix flags. */
		under_flag = "0"b;
		upper_flag = "0"b;
	     end;

	     if space_count = 0 then return;		/* If no spacing, all done. */

	     token_ptr = addr (spaces);		/* Prepare to move the specified number of spaces. */
	     token_len = space_count;
	     call MOVE_OUT;				/* Move the spaces. */
	     space_count = 0;			/* Reset this counter/flag. */

	end COPY_DELIMITERS;
						/* 	*/
CHECK_ESCAPES: procedure;

/*	This procedure is called to check the last character in a delimiter string
   *	to see if it is an escape.  If so, special processing must be done.
   *	The escape flag will be ON if the following term is to be escaped.
*/
/* See if last delimiter is an escape. */
	     x = index (ssd.escapes, substr (token, token_len, 1));

	     goto ESCAPE (x);			/* Go process escape accordingly. */

ESCAPE (0):					/* NONE */
	     return;

ESCAPE (1):					/* PAD */
	     escape_flag = "1"b;
	     return;				/* Nothing to do, next token is escaped. */

ESCAPE (2):					/* PERMANENT */
	     convert_flag,				/* After move, convert to pad escape. */
		escape_flag = "1"b;
	     return;

ESCAPE (3):					/* TEMPORARY */
	     escape_flag = "1"b;
	     token_len = token_len - 1;		/* This escape character not copied. */
	     return;

ESCAPE (4):					/* TRANSPARENT */
	     continue_flag = "1"b;			/* Continue any prefix processing. */
	     token_len = token_len - 1;		/* Don't copy transparent escape character. */
	     return;

ESCAPE (5):					/* SPACE */
	     if in_len = 0 then return;		/* If no more input then all done. */

	     x = verify (input.text, "0123456789") -1;	/* Get following numeric characters. */
	     if (x < 1) | (x > 2)			/* Space count must be from 1 to 99. */
	     then return;				/* Not a valid space count. */

	     space_count = fixed (substr (input.text, 1, x));

	     in_used = in_used + x;			/* Skip over space count characters. */
	     in_len = in_len - x;

	     token_len = token_len - 1;		/* Delete space escape delimiter. */
	     return;

	end CHECK_ESCAPES;
						/* 	*/
COPY_TEXT: procedure;

/*	This procedure will copy one real token from the input string to the
   *	output string.  A real token is defined as a string with no delimiters.
   *	We will check to see if this token is a defined symbol in the current
   *	Speedtype symbol dictionary.  If it is we will copy its expansion.
*/
	     if (in_len = 0) |			/* Have we reached the end of the input string? */
	     (ecode ^= 0)				/* Or was there an error? */
	     then return;				/* Yes, no copy needed. */

	     token_ptr = addr (input.text);		/* Token starts with beginning of input data. */
	     token_len = search (input.text, delimiters); /* Ends with next delimiter. */

	     if token_len > 0			/* Did we hit a delimiter? */
	     then token_len = token_len - 1;		/* Yes, get real length of token. */
	     else token_len = in_len;			/* No, we hit the end of the input string. */

	     in_used = in_used + token_len;		/* Move window on input string. */
	     in_len = in_len - token_len;

	     call GET_SYMBOL;			/* Get expanded or unexpanded symbol. */

	     first_char_ptr = addr (output.text);	/* Remember where first output character will be. */
	     call MOVE_OUT;				/* Copy token into output string. */
	     if ecode ^= 0 then return;		/* Check for end of output seg. */

	     if first_flag				/* Do we have to replace the first character? */
	     then do;				/* Yes, translate 1st char of expansion. */
		x = index (lowers, token_first_char);
		if x ^= 0				/* If a lowercase letter make uppercase. */
		then first_char_ptr -> token_first_char = substr (caps, x, 1);
		first_flag = "0"b;
	     end;
	     if upper_flag				/* Uppercase processing? */
	     then do;				/* Yes, convert lowercase to uppercase. */
		token_ptr = first_char_ptr;		/* Process expansion in output string. */
		do i = 1 to token_len;		/* Test each text character copied. */
		     x = index (lowers, substr (token, i, 1));
		     if x ^= 0			/* Is this character a lowercase letter? */
		     then substr (token, i, 1) = substr (caps, x, 1);
		end;
	     end;
	     if under_flag				/* Underline processing? */
	     then do;				/* Yes. */
		call UNDERLINE;
		if ecode ^= 0 then return;
	     end;
	     if period_flag				/* Did symbol have a trailing period? */
	     then do;				/* Yes. */
		token_ptr = addr (period);		/* Copy a period into output string. */
		token_len = 1;
		call MOVE_OUT;
		period_flag = "0"b;
	     end;

	end COPY_TEXT;
						/* 	*/
GET_SYMBOL: procedure;

/*	This procedure will test the current token to see if it is a defined
   *	symbol in the current Speedtype symbol dictionary.  If it is, the expansion
   *	of this symbol will be copied instead.  Special processing of the leading
   *	and trailing characters of the token is performed:
   *	     1.	If the last delimiter character was the escape character then the
   *		token is without expansion.
   *	     2.	If the first characters of the token are prefix characters,
   *		then these prefix character are stripped from the token.
   *		The output string for this token (expanded or not) is
   *		processed as specified by these prefixes.
   *	     3.	If the last character of the text token is a period ".",
   *		then the period is temporarily stripped from the token.
   *	     4.	If the last character (after any period is stripped) is a
   *		suffix character, then this character is stripped off and
   *		suffixing is specified.
   *	     5.	Before testing to see if this token is a defined symbol we
   *		will translate the first character to lower case if it is an
   *		upper case letter.  The original character will be replaced
   *		in the expanded string.
   *	     6.	If the last character in the token was a suffix character then the
   *		expansion, if there is one, has the specified suffix added.
*/
	     if escape_flag				/* Is this token to be escaped? */
	     then do;				/* Yes, copy as is. */
		escape_flag = "0"b;
		return;
	     end;

	     symbol_len = token_len;			/* Now, symbol = text token. */
	     symbol_ptr = token_ptr;

	     prefix_flag = "1"b;			/* Turn ON to get into the loop. */
	     do while (prefix_flag);			/* Process all prefix characters. */
		x = index (ssd.prefixes, substr (symbol, 1, 1));
		if x = 0				/* Is there a prefix? */
		then prefix_flag = "0"b;		/* No. */
		else do;				/* Yes, remember to process this prefix. */
		     if symbol_len = 1		/* Is the symbol just the prefix? */
		     then return;			/* Yes, it is not a valid symbol. */
		     symbol_ptr = addr (substr (symbol, 2, 1)); /* Strip prefix character from symbol. */
		     symbol_len = symbol_len - 1;
		     if x = 1			/* Which prefix is it? */
		     then under_flag = "1"b;
		     else upper_flag = "1"b;
		end;
	     end;

	     if substr (symbol, symbol_len, 1) = "."	/* Is there a trailing period? */
	     then do;				/* Yes. */
		if symbol_len = 1			/* Is the symbol just the period? */
		then do;				/* Yes, it is an invalid symbol. */
		     under_flag,			/* Turn off prefix processing. */
			upper_flag = "0"b;
		     return;
		end;
		symbol_len = symbol_len - 1;		/* Strip off period. */
		period_flag = "1"b;			/* Remember period. */
	     end;

	     suffixx = index (ssd.suffixes, substr (symbol, symbol_len, 1));
	     if suffixx > 0				/* Is last character of symbol a suffix? */
	     then do;				/* Yes. */
		if symbol_len = 1			/* Is symbol just a suffix? */
		then return;			/* Yes, an invalid symbol. */
		symbol_len = symbol_len - 1;		/* Strip off suffix character. */
	     end;

/* We now have found the symbol. */
	     if symbol_len > 7			/* Is symbol too long? */
	     then do;				/* Yes, an invalid symbol. */
		token_ptr = symbol_ptr;		/* make the token be the symbol */
		if suffixx > 0
		then token_len = symbol_len+1;	/* put back a suffix if it was there */
		else token_len = symbol_len;
		return;
	     end;

	     sb.symbol = symbol;			/* Copy symbol into symbol buffer. */

	     x = index (caps, substr (sb.symbol, 1, 1));	/* Check for capitalization. */
	     if x ^= 0				/* Is first character a capital letter? */
	     then do;				/* Yes, translate to lowercase. */
		substr (sb.symbol, 1, 1) = substr (lowers, x, 1);
		first_flag = "1"b;			/* Note special first character processing. */
	     end;

	     sbx = index (sb_table, symbol_buffer);	/* Search for symbol in symbol table. */
	     if sbx = 0				/* Did we find it? */
	     then do;				/* No, symbol is not defined. */
		token_ptr = symbol_ptr;		/* Copy symbol within text token. */
		if suffixx > 0			/* Put back suffix character if there was one. */
		then token_len = symbol_len + 1;
		else token_len = symbol_len;
		first_flag = "0"b;			/* No capitialization needed. */
		return;
	     end;

	     sbx = ((sbx -1) / 8) + 1;		/* Convert string index to table index. */
	     exp_ptr = addr (ssd.exp_tab (sbx));	/* Get pointer to corresponding expansion. */

	     if suffixx = 0				/* Was a suffix character specified? */
	     then do;				/* No, copy expansion as is. */
		token_ptr = addr (exp.expansion);	/* Replace token with this expansion. */
		token_len = exp.len;		/* Get actual length of expansion string. */
		return;
	     end;

	     actionx = exp.actionx (suffixx);		/* Index => how to add suffix. */

	     if actionx = 0				/* 0 => no expansion, no suffix. */
	     then do;				/* Copy as if symbol not defined. */
		token_ptr = symbol_ptr;
		if suffixx > 0
		then token_len = symbol_len + 1;
		else token_len = symbol_len;
		first_flag = "0"b;			/* No modification. */
		return;
	     end;

	     exp_buffer = exp.expansion;		/* Move expansion so we can add a suffix. */
	     token_ptr = addr (exp_buffer);		/* We will copy from this buffer. */

	     goto ACTION (actionx);			/* Add suffix according to specified suffix type. */

ACTION (6):					/* Add "e", then add suffix. */
	     token_len = exp.len + 1;
	     substr (token, token_len, 1) = "e";
	     goto ADD_SUFFIX;

ACTION (5):					/* Replace last char with "ie", then add suffix. */
	     token_len = exp.len + 1;
	     substr (token, (token_len - 1), 2) = "ie";
	     goto ADD_SUFFIX;

ACTION (4):					/* Replace last char with "i", then add suffix. */
	     token_len = exp.len;
	     substr (token, token_len, 1) = "i";
	     goto ADD_SUFFIX;

ACTION (3):					/* Double last letter. */
	     last_char = substr (token, exp.len, 1);
	     token_len = exp.len + 1;
	     substr (token, token_len, 1) = last_char;
	     goto ADD_SUFFIX;			/* Now go add suffix string. */

ACTION (2):					/* Drop last letter. */
	     token_len = exp.len - 1;
	     goto ADD_SUFFIX;

ACTION (1):					/* Add suffix directly. */
	     token_len = exp.len;
	     goto ADD_SUFFIX;

ACTION (7):                                                 /* User has supplied his own suffixed word. */    
	     spc_ptr = addr (ssd.spec_tab (sbx));
	     token_len = length(rtrim(spc.special(suffixx)));
	     token = spc.special(suffixx);
	     return;

ADD_SUFFIX:					/* Add suffix to expanded string. */
	     suffix = suffix_strings (suffixx);		/* Get the suffix string to add. */
	     suffix_len = length (suffix);		/* Get length of this suffix. */
	     substr (token, (token_len + 1), suffix_len) = suffix;
	     token_len = token_len + suffix_len;

	end GET_SYMBOL;
						/* 	*/
UNDERLINE: procedure;

/*	This procedure is called to underline the current text token.
   *	The text token has already been copied into the output string.
   *	This procedure copies it back into a work buffer.  This is done
   *	character by character.  Each character copied is underlined in
   *	accordance with canonical form.
*/
	     token_ptr = first_char_ptr;		/* Token already copied into output string. */

	     if index (token, backspace) ^= 0		/* Is there any backspace in this string? */
	     then return;				/* Yes, asume already underlined. */

	     startx = 1;				/* Initialize place in expansion buffer. */
	     do i = 1 to token_len;			/* Copy each character in output string. */
		if (startx + 3) > length (exp_buffer)	/* Is there room in work buffer? */
		then do;
		     ecode = error_table_$item_too_big;
		     return;
		end;
		test_char = substr (token, i, 1);	/* Save the current character. */
		if (test_char = " ") |		/* Special case blanks and underscore. */
		(test_char = "_")
		then do;				/* Relpace with just one underscore. */
		     substr (exp_buffer, startx, 1) = "_";
		     startx = startx + 1;
		end;
		else if test_char = ""		/* Test for PAD character. */
		then do;				/* Copy without underlining. */
		     substr (exp_buffer, startx, 1) = test_char;
		     startx = startx + 1;
		end;
		else if test_char < "_"		/* Less than or greater than underscore? */
		then do;				/* Less than, => character first. */
		     substr (exp_buffer, startx, 3) = test_char || backspace || "_";
		     startx = startx + 3;

		end;
		else do;				/* Greater than => underscore first. */
		     substr (exp_buffer, startx, 3) = "_" || backspace || test_char;
		     startx = startx + 3;
		end;
	     end;

	     out_used = out_used - token_len;		/* Back up the real output string. */
	     token_ptr = addr (exp_buffer);		/* Copy underlined string in expansion buffer. */
	     token_len = startx - 1;			/* Get actual length of underlined string. */
	     call MOVE_OUT;				/* Move underlined string to output string. */

	end UNDERLINE;
						/* 	*/
INIT_SYMBOL_DICT: procedure;

/*	This procedure will get a pointer to the Speedtype symbol dictionary
   *	currently in use.  It will set up the overlays used to search the
   *	symbol entry table.
*/
	     call speedtype_info_$pointer (ssd_ptr, ecode);
	     if ecode ^= 0 then return;

	     sb_tab_len = ssd.num_symbols * 8;		/* Get length of all entries actually used. */
	     sb_tab_ptr = addr (ssd.sb_tab);		/* Get pointer to beginning of the table. */

	     sb_ptr = addr (symbol_buffer);		/* Get pointer to work symbol entry. */
	     sb.new_line = "
";						/* Set new line in work symbol entry. */

	     continue_flag,				/* Initialize flags. */
		convert_flag,
		escape_flag,
		first_flag,
		period_flag,
		under_flag,
		upper_flag = "0"b;

	     space_count = 0;

	end INIT_SYMBOL_DICT;

     end speedtype_expand_;



		    speedtype_index_.pl1            01/06/81  1251.1rew 01/06/81  1247.7       38214


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

speedtype_index_: procedure (arg_symbol, arg_ssd_ptr, arg_sbx, arg_ecode);

/*	This procedure is an internal interface of the Speedtype subsystem.
   *	Created on 10/13/75 by Bill Silver as notescript_index_.
   *	Changed on 06/13/77 by Bill Silver to speedtype_symbol_.
   *
   *	This procedure takes a symbol and returns the index in the current
   *	Speedtype symbol dictionary that corresponds to this symbol.
*/

dcl  arg_ecode fixed bin (35);			/* (O) Error table code. */
dcl  arg_symbol char (*);				/* (I) A symbol token. */
dcl  arg_ssd_ptr ptr;				/* (I) Pointer to current symbol dictionary. */
dcl  arg_sbx fixed bin;				/* (O) Index of symbol entry. */


dcl  ecode fixed bin (35);
dcl  sb_tab_len fixed bin;				/* Length of actual symbol array. */
dcl  sb_tab_ptr ptr;				/* Pointer to symbol table. */
dcl  sbx fixed bin;					/* Symbol index. */
dcl  symbol_len fixed bin;				/* Length of test symbol. */
dcl  symbol_ptr ptr;				/* Pointer to test symbol. */

dcl  symbol_buffer char (8);				/* Used to copy symbol argument. */


dcl  symbol char (symbol_len) based (symbol_ptr);		/* Overlay of the test symbol. */

dcl  sb_table char (sb_tab_len) based (sb_tab_ptr);	/* Symbol table as a string. */


dcl  caps char (26) aligned				/* Uppercase letters. */
     internal static init ("EAIOUSTCYHNLMRWFGPBDJQKXVZ");


dcl (addr, index, length, search, substr) builtin;

dcl  error_table_$bad_arg fixed bin (35) external;
dcl  error_table_$bigarg fixed bin (35) external;

dcl  com_err_ entry options (variable);
						/* 	*/
%include speedtype_symbols;
/* 	*/
	ssd_ptr = arg_ssd_ptr;			/* Get pointer to symbol dictionary. */
	sb_ptr = addr (symbol_buffer);		/* Build a test symbol entry. */
	sb.new_line = "
";						/* Set it up like an entry in the sb_tab array. */
	sb.symbol = arg_symbol;			/* Copy symbol argument. */
	sbx = 0;					/* Initialize to not found. */

	symbol_ptr = addr (sb.symbol);		/* Set up overlay of symbol. */
	symbol_len = length (arg_symbol);

	if symbol_len > 7				/* Is symbol too long? */
	then do;					/* Yes, illegal symbol. */
	     ecode = error_table_$bigarg;
	     call com_err_ (ecode, "Speedtype", "Symbol ""^a"" longer than 7 characters.", arg_symbol);
	     goto RETURN;
	end;

	ecode = error_table_$bad_arg;			/* Set error until symbol validated. */

	if search (symbol, ssd.delimiters) ^= 0		/* Check for delimiters in symbol. */
	then do;
	     call com_err_ (ecode, "Speedtype", "Symbol ""^a"" contains a delimiter character.", symbol);
	     goto RETURN;
	end;
	if index (caps, substr (symbol, 1, 1)) ^= 0	/* Check for leading capital letter. */
	then do;
	     call com_err_ (ecode, "Speedtype", "Symbol ""^a"" contains a leading capital letter.", symbol);
	     goto RETURN;
	end;
	if index (ssd.prefixes, substr (symbol, 1, 1)) ^= 0
	then do;					/* Symbol begins with a prefix character. */
	     call com_err_ (ecode, "Speedtype", "Symbol ""^a"" begins with a prefix character.", symbol);
	     goto RETURN;
	end;
	if index (ssd.suffixes, substr (symbol, symbol_len, 1)) ^= 0
	then do;
	     call com_err_ (ecode, "Speedtype", "Symbol ""^a"" ends with a suffix character.", symbol);
	     goto RETURN;
	end;
	if substr (symbol, symbol_len, 1) = "."
	then do;
	     call com_err_ (ecode, "Speedtype", "Symbol ""^a"" ends with a period.", symbol);
	     goto RETURN;
	end;

	ecode = 0;				/* Now reset to good error code. */

	sb_tab_len = ssd.num_symbols * (2 * 4);		/* Use symbol table as a string. */
	sb_tab_ptr = addr (ssd.sb_tab);

	sbx = index (sb_table, symbol_buffer);		/* Look for symbol in table. */
	if sbx ^= 0				/* Did we find it? */
	then sbx = ((sbx-1) / 8) + 1;			/* Yes, convert to table index. */

RETURN:
	arg_sbx = sbx;				/* Return index. */
	arg_ecode = ecode;

     end speedtype_index_;
  



		    speedtype_info_.pl1             02/04/82  1522.6rew 02/04/82  1351.1      125460


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


speedtype_info_: procedure;

/*	This procedure is an internal interface of the Speedtype subsystem.
   *	Created on 12/31/75 by Bill Silver as notescript_info_.
   *	Changed on 06/13/77 by Bill Silver to speedtype_info_.
   *      Changed on 10/28/80 by Paul Benjamin for special suffixing.
   *                          Added expand_table entrypoint.
   *                          Fixed deleted symbol dictionary bug.
   *      Changed on 11/09/81 by Paul Benjamin to fix bug where expanding
   *                          symbol dict causes some expansions to be overlaid.
   *
   *	It is called to set and get a pointer and pathname of the current
   *	Speedtype symbol dictionary.  It has the following entry points:
   *
   *           expand_table:  Add another 100 entries to symbol dictionary.
   *	     use:		Set up to use new symbol dictionary.
   *	     name:	Return the name of the current symbol dictionary.
   *	     pointer:	Return a pointer to the current symbol dictionary.
   *	     set_bc:	Sets bit count of the current symbol dictionary.
   *           shrink_table:  Remove 100 entries from symbol dictionary.
*/

/*		ARGUMENTS			*/

dcl  arg_dir_name char (168);				/* (I/O) Directory name of current symbol dictionary. */
dcl  arg_ecode fixed bin (35);			/* (O)   Error table code. */
dcl  arg_ent_name char (32);				/* (I/O) Entry name of current symbol dictionary. */
dcl  arg_ssd_ptr ptr;				/* (O)   Pointer to current notescri  Pt segment. */


/*		AUTOMATIC  DATA		*/

dcl  account char (32);         			/* Just used to satisfy call arguments. */
dcl  answer char (4) varying;				/* Answer to command query. */
dcl  bit_count fixed bin (24);			/* Bit count of the symbol dictionary. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl (i, j) fixed bin;
dcl  project char (9);  	        		          /* Not used. */
dcl  words fixed bin (19);				/* Size in words of symbol dictionary. */

dcl 1 query_info aligned,				/* Info structure for command_query_. */
    2 version fixed bin,
    (2 yes_no bit (1),
    2 suppress_name bit (1)) unaligned,
    2 status_code fixed bin,
    2 other_code fixed bin;


/*		INTERNAL STATIC DATA	*/

dcl  cur_dir_name char (168)                                /* Directory name of current symbol dictionary. */
     internal static init (" ");
dcl  cur_ent_name char (32)      			/* Entry name of current symbol dictionary. */
     internal static init (" ");
dcl  cur_ssd_ptr ptr				/* Pointer to current symbol dictionary. */
     internal static init (null ());

dcl  new_line char (1)				/* Used to set up delimiter string. */
     internal static init ("
");

dcl  default_prefixes char (2)			/* Under, upper. */
     internal static init ("_|");

dcl  default_suffixes char (5)			/* Plural, ing, ed, ly, able. */
     internal static init ("+-*=|");

dcl  default_escapes char (5)				/* Pad, perm, temp, trans, space */
     internal static init ("`~:;");

dcl  default_delimiters char (12)			/* Default delimiters:  ,?!"()<>[]{} */
     internal static init (",""()?!<>[]{}");


/*		EXTERNAL ENTRIES CALLED	*/

dcl (addr, index, null, size, substr) builtin;

dcl  error_table_$bad_arg fixed bin (35) external;
dcl  error_table_$no_w_permission fixed bin (35) external;
dcl  error_table_$noentry fixed bin (35) external;
dcl  error_table_$unimplemented_version fixed bin (35) external;

dcl  clock_ entry returns (fixed bin (71));
dcl  com_err_ entry options (variable);
dcl  command_query_ entry options (variable);
dcl  hcs_$chname_seg entry (ptr, char(*), char(*), fixed bin(35));
dcl  hcs_$delentry_seg entry (ptr, fixed bin(35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin(19), fixed bin(35));
dcl  ioa_	entry() options(variable);
dcl  nd_handler_ entry (char(*), char(*), char(*), fixed bin(35));
dcl  speedtype_info_$set_bc entry (ptr, fixed bin (35));
dcl  user_info_$homedir entry (char (*));
dcl  user_info_$whoami entry (char (*), char (*), char (*));
						/* 	*/
%include speedtype_symbols;
/* 	*/
use:	entry (arg_dir_name, arg_ent_name, arg_ecode);

/*	This entry specifies the pathname of a new symbol dictionary.
   *	The current symbol dictionary (if there is one) is no longer used.
   *	This symbol dictionary is used for all future Speedtype operations
   *	for this process until a new symbol dictionary is specified.
*/
	ssd_ptr = null ();
	cur_dir_name = arg_dir_name;			/* Save pathname of new symbol dictionary. */
	cur_ent_name = arg_ent_name;

	call GET_POINTER;				/* Establish new symbol dictionary. */
	arg_ecode = ecode;
	return;


name:	entry (arg_dir_name, arg_ent_name, arg_ecode);

/*	This entry will return the pathname of the current symbol dictionary.
*/
	call GET_POINTER;
	arg_dir_name = cur_dir_name;			/* Copy current pathname. */
	arg_ent_name = cur_ent_name;
	arg_ecode = ecode;
	return;


pointer:	entry (arg_ssd_ptr, arg_ecode);

/*	This entry is called to return a pointer to the current symbol dictionary.
*/
	call GET_POINTER;				/* Get pointer. */
	arg_ssd_ptr = cur_ssd_ptr;			/* Return current pointer. */
	arg_ecode = ecode;
	return;


set_bc:	entry (arg_ssd_ptr, arg_ecode);

/*	This entry is called to set the bit count of the current symbol dictionary.
*/
	ssd_ptr = arg_ssd_ptr;
	words = size (ssd);				/* Start with the whole segment. */
						/* Subtract unused symbol entries. */
	words = words - ((hbound (sb_tab, 1) - ssd.num_symbols) * size (sb));
	bit_count = words * 36;
	call hcs_$set_bc_seg (ssd_ptr, bit_count, ecode);
	if ecode ^= 0
	then call com_err_ (ecode, "Speedtype", "Error setting bit count of symbol dictionary.");
	arg_ecode = ecode;
	return;

expand_table:
	entry (arg_ssd_ptr, arg_ecode);

/*        This entry is called to add 100 more entries to the symbol dictionary. */

	ssd_ptr = arg_ssd_ptr;
	call EXPAND;
	arg_ecode = ecode;
	return;

shrink_table:
	entry (arg_ssd_ptr, arg_ecode);

/* This entry is called to remove the last 100 from the symbol dictionary. */

	ssd_ptr = arg_ssd_ptr;
	call SHRINK;
	arg_ecode = ecode;
	return;
	

GET_POINTER: procedure;

/*	This procedure is called to get a pointer to the current symbol dictionary.
*/
	     ecode = 0;
	     if cur_ent_name = " "			/* Have we been told what symbol dictionary to use? */
	     then do;				/* No, use default symbol dictionary. */
		call user_info_$homedir (cur_dir_name);
		call user_info_$whoami (cur_ent_name, project, account);
		i = index (cur_ent_name, " ") - 1;	/* Add ".symbols" suffix. */
		cur_ent_name = substr (cur_ent_name, 1, i) || ".symbols";
	     end;

	     call INITIATE_SSD;			/* Initiate symbol dictionary. */
	     if ecode ^= 0 then return;

	     if ssd.identifier ^= "Speedtype_SD"	/* Make sure this is a symbol dictionary. */
	     then do;				/* It is not. */
		call com_err_ (0, "Speedtype", "^a>^a is not a valid Speedtype symbol dictionary",
		     cur_dir_name, cur_ent_name);
		ecode = error_table_$bad_arg;		/* Note error. */
		return;
	     end;

	     if ssd.version ^= ssd_version_2		/* Check for current version. */
	     then do;				/* Not the current version. */
		call CONVERT_VERSIONS;		/* Convert symbol dictionary. */
		if ecode ^= 0 then return;
	     end;

	     cur_ssd_ptr = ssd_ptr;			/* Save current pointer. */

	end GET_POINTER;
						/* 	*/
INITIATE_SSD: procedure;

/*	This procedure is called to initiate the symbol dictionary whose pathname
   *	is defined in internal static.  If this segment does not exist, it is
   *	created.  We will ask the user if he really wants to create this
   *	new symbol dictionary.  If so we will created it and initialize it.
*/
	     call hcs_$initiate (cur_dir_name, cur_ent_name, "", 0, 0, ssd_ptr, ecode);
	     if ssd_ptr ^= null ()			/* Got pointer, assume segment initiated OK. */
	     then do;
		ecode = 0;			/* Make sure no error code. */
		return;
	     end;

	     if ecode ^= error_table_$noentry		/* Fatal error? */
	     then do;				/* Yes, no way to initiate segment. */
		call com_err_ (ecode, "Speedtype", "Unable to get pointer to ^a>^a",
		     cur_dir_name, cur_ent_name);
		return;
	     end;

	     query_info.version = 0;			/* Set up query info. */
	     query_info.yes_no = "1"b;
	     query_info.suppress_name = "0"b;
	     query_info.status_code,
		query_info.other_code = 0;
	     call command_query_ (addr (query_info), answer, "Speedtype",
		"^a>^a not found. ^/Do you want to create it?", cur_dir_name, cur_ent_name);
	     if answer = "no"			/* Does user want new symbol dictionary? */
	     then do;				/* No. */
		ecode = 1;			/* Note that no symbol dictionary segment created. */
		return;
	     end;

	     call hcs_$make_seg (cur_dir_name, cur_ent_name, "", 01010b, ssd_ptr, ecode);
	     if ecode ^= 0				/* Did we create segment successfully? */
	     then do;				/* No, fatal error. */
		call com_err_ (ecode, "Speedtype", "Unable to create ^a>^a", cur_dir_name, cur_ent_name);
		return;
	     end;

	     call INIT_SSD_SEG;			/* Initialize the new symbol dictionary. */

	     call speedtype_info_$set_bc (ssd_ptr, ecode); /* Set bit count of new symbol dictionary. */

	end INITIATE_SSD;
						/* 	*/
INIT_SSD_SEG: procedure;

/*	This procedure is called to initialize a Speedtype symbol dictionary.
   *	Default values will be used for all fields.
*/

	     ssd.version = ssd_version_2;		/* Initialize header of new symbol dictionary. */
	     ssd.flags = "0"b;
	     delim_ptr = addr (ssd.delimiters);		/* Set up overlay of delimiter string. */
	     delim_chars.blank = " ";			/* Now fill in delimiter characters. */
	     delim_chars.new_line = new_line;
	     delim_chars.tab = "	";
	     delim_chars.escapes = default_escapes;	/* Escapes are delimiters too. */
	     delim_chars.others = default_delimiters;
	     ssd.escapes = default_escapes;		/* Now set up default special characters. */
	     ssd.prefixes = default_prefixes;
	     ssd.suffixes = default_suffixes;
	     ssd.num_symbols = 0;			/* No symbols defined yet. */
	     ssd.identifier = "Speedtype_SD";		/* Mark this as a symbol dictionary. */
	     ssd.table_size = 100;                        /* Allocate 100 symbols initially. */

	end INIT_SSD_SEG;
						/* 	*/
CONVERT_VERSIONS: procedure;

/*	This procedure is called to convert old versions of symbol dictionaries into
   *	the current version.
*/

dcl old_ssd_ptr ptr;

dcl    1	old_ssd  based(old_ssd_ptr) aligned,	/* Format of a Speedtype Symbol Dictionary. */
	2  version	fixed bin,	/* Version number.  Currently = 1. */
	2  identifier	char(12),		/* "Speedtype_SD" => this is a Speedtype Symbol Dictionary. */
	2  flags		bit(36),		/* Not used, all zero. */
	2  delimiters	char(24),		/* Blank, New Line, Tab, Escapes, Others. */
	2  escapes	char(5), 		/* Pad, Perm, Temp, Trans, Space */
	2  prefixes	char(2),		/* Under, Upper. */
	2  suffixes	char(5),		/* Plural, ed, ing, er, ly. */
	2  num_symbols	fixed bin,	/* Number of defined symbols. */
	2  pad(15)	bit(36),		/* Round out header to 32 words. */
	2  sb_tab(1008) like  sb,	/* Symbol entries. */
	2  exp_tab(1008) like  exp;	/* Expansion entries. */
 
dcl no_write_permission condition;
	        
	        on no_write_permission goto nowrite;
	        
	        old_ssd_ptr = ssd_ptr;

	        call hcs_$make_seg ("", "speedtype_scratch", "", 01010b, ssd_ptr, ecode);
	        if ssd_ptr = null() 
		   then return;

	        ssd.version = ssd_version_2;
	        ssd.identifier = old_ssd.identifier;
	        ssd.flags = old_ssd.flags;
	        ssd.delimiters = old_ssd.delimiters;
	        ssd.escapes = old_ssd.escapes;
	        ssd.prefixes = old_ssd.prefixes;
	        ssd.suffixes = old_ssd.suffixes;
	        ssd.num_symbols = old_ssd.num_symbols;
	        ssd.table_size = (divide(old_ssd.num_symbols,100,17,0)+1)*100;
	        do i = 1 to old_ssd.num_symbols;
		   ssd.exp_tab(i) = old_ssd.exp_tab(i);
		   ssd.sb_tab(i) = old_ssd.sb_tab(i);
                  end;
	        words = words - ((hbound (spec_tab, 1) - ssd.num_symbols) * size (spc));
	        old_ssd_ptr -> ssd = ssd;

	        call hcs_$delentry_seg (ssd_ptr, ecode);
	        if ecode ^= 0
		   then return;

	        ssd_ptr = old_ssd_ptr;

	        call speedtype_info_$set_bc (ssd_ptr, ecode);
	        
	        return;

nowrite:	        call hcs_$delentry_seg (ssd_ptr, ecode);
	        ecode = error_table_$no_w_permission;
	        
	        return;

	end CONVERT_VERSIONS;

EXPAND:	proc;

dcl (a, b, c) fixed;
dcl  1  new_ssd  based(ssd_ptr) aligned,
	2  pad (32) bit(36),
	2  spec_tab (a) like spc,
	2  exp_tab (b) like exp,
	2  sb_tab (c) like sb;

	a,b = ssd.table_size + 100;
	c = ssd.table_size;
	new_ssd.sb_tab = ssd.sb_tab;
	b = ssd.table_size;
	do i = b to 1 by -1;			/* Must go backwards so as not */
	     new_ssd.exp_tab (i) = ssd.exp_tab (i);	/* to overlay any data */
	end;
	ecode = 0;
	ssd.table_size = ssd.table_size + 100;
     end;

SHRINK:	proc;

dcl  (a,b,c) fixed;
dcl  1  old_ssd  based(ssd_ptr) aligned,
	2  pad (32) bit(36),
	2  spec_tab (a) like spc,
	2  exp_tab (b) like exp,
	2  sb_tab (c) like sb;

	ssd.table_size = ssd.table_size - 100;
	a = ssd.table_size + 100;
	b = ssd.table_size;
	ssd.exp_tab = old_ssd.exp_tab;
	b = ssd.table_size + 100;
	c = ssd.table_size;
	ssd.sb_tab = old_ssd.sb_tab;	     
	ecode = 0;

     end;

     end speedtype_info_;



		    speedtype_retain_.pl1           01/06/81  1251.1rew 01/06/81  1247.6       72189


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

speedtype_retain_: procedure (arg_perm_flag, arg_in_ptr, arg_in_len, arg_out_ptr, arg_out_len, arg_out_used, arg_ecode);

/*	This procedure is an internal interface of the Speedtype subsystem.
   *	Created on 02/20/76 by Bill Silver as notescript_escape_.
   *	Changed on 06/13/77 by Bill Silver to speedtype_retain_.
*/

/*		ARGUMENTS			*/

dcl  arg_ecode fixed bin (35);			/* (O) error_table code. */
dcl  arg_in_len fixed bin (21);			/* (I) Length of input string in characters. */
dcl  arg_in_ptr ptr;				/* (I) Pointer to input string. */
dcl  arg_out_len fixed bin (21);			/* (I) Length of output buffer in characters. */
dcl  arg_out_ptr ptr;				/* (I) Pointer to output buffer. */
dcl  arg_out_used fixed bin (21);			/* (O) Actual length of output string in characters. */
dcl  arg_perm_flag bit (1) aligned;			/* (I) ON => Perm (`), OFF => Temp (~). */


/*		AUTOMATIC DATA		*/

dcl  dtok_len fixed bin;				/* Length of delimiter token string. */
dcl  dtok_ptr ptr;					/* Pointer to delimiter token. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  escape_char char (1);				/* Specified escape character to insert. */
dcl  texp_len fixed bin (21);				/* Length of test expansion string. */
dcl  texp_len_max fixed bin (21);			/* Length of output string left. */
dcl  texp_ptr ptr;					/* Where test expansion string will go. */
dcl  in_len fixed bin (21);				/* Length of unused part of input segment. */
dcl  in_ptr ptr;					/* Pointer to input segment. */
dcl  in_used fixed bin;				/* Length of used part of input segment. */
dcl  out_len fixed bin (21);				/* Length of actual output string. */
dcl  out_ptr ptr;					/* Pointer to output string. */
dcl  out_used fixed bin (21);				/* Length of used part of output segment. */
dcl  pad_escape char (1);				/* Used to hold pad escape character. */
dcl  ttok_len fixed bin;				/* Length of text token string. */
dcl  ttok_ptr ptr;					/* Pointer to text token string. */
dcl  token_len fixed bin (21);			/* Length of one token. */
dcl  token_ptr ptr;					/* Pointer to a token. */


/*		BASED DATA		*/

dcl 1 input based (in_ptr) aligned,			/* Overlay of input segment. */
    (2 used char (in_used),				/* Part of segment that has been processed. */
    2 text char (in_len)) unaligned;			/* Part of segment still to be processed. */

dcl 1 output based (out_ptr) aligned,			/* Overlay of output segment. */
    (2 used char (out_used),				/* Part of segment that has been processed. */
    2 text char (1)) unaligned;			/* Beginning of unprocessed part. */

/* Overlay of temporary output string. */
dcl  test_expansion char (texp_len) based (texp_ptr) aligned;

dcl  token char (token_len) based (token_ptr);		/* Overlay of one token string. */


/*		EXTERNAL ENTRIES		*/

dcl (addr, length, search, substr, verify) builtin;

dcl  error_table_$item_too_big fixed bin (35) external;

dcl  speedtype_expand_ entry (ptr, fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  speedtype_info_$pointer entry (ptr, fixed bin (35));
						/* 	*/
%include speedtype_symbols;
/* 	*/
/*	Begin Escaping
*/
	in_ptr = arg_in_ptr;			/* Copy arguments and initialize. */
	in_len = arg_in_len;
	out_ptr = arg_out_ptr;
	out_len = arg_out_len;

	in_used,
	     out_used,
	     ecode = 0;

/* Get pointer to current symbol dictionary. */
	call speedtype_info_$pointer (ssd_ptr, ecode);
	if ecode ^= 0 then goto RETURN;

	if arg_perm_flag				/* Save selected escape character. */
	then escape_char = substr (ssd.escapes, 2, 1);	/* Perm escape. */
	else escape_char = substr (ssd.escapes, 3, 1);	/* Temp escape. */
	pad_escape = substr (ssd.escapes, 1, 1);	/* Save pad escape character. */

	do while ((in_len > 0) & (ecode = 0));		/* Copy input to output until no more input. */
	     call COPY_PAIR;			/* Copy next delimiter/text token pair. */
	end;

RETURN:
	arg_out_used = out_used;			/* Return number of chars in output segment. */
	arg_ecode = ecode;
	return;
						/* 	*/
COPY_PAIR: procedure;

/*	This procedure copies the input string into the output string one
   *	delimiter/text token pair at a time.  Each pair is expanded to see
   *	if it would be altered by the expansion process.  It it would be,
   *	then the specified escape character is inserted between the two tokens.
   *	Otherwise the token pair is copied into the output string as is.
   *	In addition, if the last character of the delimiter token is a PAD
   *	escape character, then it is converted to the specified escape character.
*/
	     dtok_ptr = addr (input.text);		/* Get pointer to delimiter token. */
	     dtok_len = verify (input.text, ssd.delimiters);
	     if dtok_len > 0			/* Adjust length of delimiter token. */
	     then dtok_len = dtok_len - 1;
	     else dtok_len = in_len;
	     in_used = in_used + dtok_len;		/* Move input window past delimiter token. */
	     in_len = in_len - dtok_len;

	     if in_len = 0				/* Is there any text token? */
	     then do;				/* No, special case last delimiter token. */
		token_ptr = dtok_ptr;		/* Move just the delimiter token. */
		token_len = dtok_len;
		call MOVE_OUT;
		return;
	     end;

	     ttok_ptr = addr (input.text);		/* Get address of text token. */
	     ttok_len = search (input.text, ssd.delimiters);
	     if ttok_len > 0			/* Adjust length of text token. */
	     then ttok_len = ttok_len -1;
	     else ttok_len = in_len;
	     in_used = in_used + ttok_len;		/* Move input window past text token. */
	     in_len = in_len - ttok_len;

	     token_ptr = dtok_ptr;			/* Define token to be whole pair. */
	     token_len = dtok_len + ttok_len;

	     texp_ptr = addr (output.text);		/* Expand directly into our output string. */
	     texp_len_max = out_len - out_used;		/* Use all the space that is left. */
	     call speedtype_expand_ (token_ptr, token_len, texp_ptr, texp_len_max, texp_len, ecode);
	     if ecode ^= 0 then return;

	     if token = test_expansion		/* Did expansion change anything? */
	     then do;				/* No, expanded string OK. */
		if dtok_len > 0			/* If delim token, check for PAD escape. */
		then if substr (test_expansion, dtok_len, 1) = pad_escape
		     then substr (test_expansion, dtok_len, 1) = escape_char;
		out_used = out_used + texp_len;	/* Move output window. */
		return;
	     end;

/*	Expansion does alter the input text.  Thus expanded string cannot be used.
   *	Move input string tokens one at a time and insert an escape character in between.
*/
	     token_ptr = dtok_ptr;			/* First move th delimiter token. */
	     token_len = dtok_len;
	     call MOVE_OUT;
	     if ecode ^= 0 then return;

	     token_ptr = addr (escape_char);		/* Add the escape character. */
	     token_len = 1;
	     call MOVE_OUT;
	     if ecode ^= 0 then return;

	     token_ptr = ttok_ptr;			/* Now move the text token. */
	     token_len = ttok_len;
	     call MOVE_OUT;

	end COPY_PAIR;
						/* 	*/
MOVE_OUT:	procedure;

/*	This procedure is called to move the current token string
   *	into the output string.  It will make sure that there is
   *	enough room in the output string.
*/

	     if token_len = 0 then return;		/* No token => nothing to do. */

	     if (out_used + token_len) > out_len	/* Is there room for this output? */
	     then do;				/* No. */
		out_used = out_len;			/* Make sure no other output fits. */
		ecode = error_table_$item_too_big;
		return;
	     end;

	     addr (output.text) -> token = token;	/* Copy token into output. */

	     out_used = out_used + token_len;		/* Move output pointer over token. */

	end MOVE_OUT;

     end speedtype_retain_;
   



		    speedtype_sort_.pl1             01/06/81  1251.1rew 01/06/81  1247.6       35028


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

speedtype_sort_: procedure (arg_vector_ptr, arg_vector_size, arg_string_len);

/*	This program is an internal interface of the Speedtype subsystem.
   *	Changed on 10/21/75 by Bill Silver to notescript_sort_.
   *	Changed on 06/13/77 by Bill Silver to speedtype_sort_.
   *
   *	This program sorts symbols and expansions.
   *	It was taken from "sort_strings_".
   *	Algorithm 347
   *	AN EFFICIENT ALGORITHM FOR SORTING WITH MINIMAL STORAGE
   *	Richard C. Singleton
   *	CACM 12, Number 3, March 1969, pp. 185-7
*/

dcl  arg_vector_ptr ptr;				/* Pointer to array of string pointers. */
dcl  arg_vector_size fixed bin;			/* Number of symbols to sort. */
dcl  arg_string_len fixed bin;			/* Length of sort strings. */

dcl  vector_ptr ptr;				/* Pointer to vector of pointers. */
dcl  vector_size fixed bin;				/* Number of symbols. */
dcl  string_len fixed bin;				/* Length of sort strings. */

dcl 1 temp like vector_entry aligned;			/* Work entry. */
dcl 1 swap_temp like vector_entry aligned;		/* Work entry. */

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

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

dcl 1 vector (vector_size) based (vector_ptr) like vector_entry aligned;

dcl 1 vector_entry based aligned,
    2 string_ptr ptr,
    2 sbx fixed bin,
    2 pad bit (36);

dcl  string char (string_len) based;			/* Template to reference strings. */

dcl (divide) builtin;
						/* 	*/
	vector_ptr = arg_vector_ptr;			/* Copy arguments. */
	vector_size = arg_vector_size;
	string_len = arg_string_len;

	depth = 0;
	first = 1;
	last = vector_size;
	go to L4;


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

	if vector (first).string_ptr -> string > vector (median).string_ptr -> string
	then do;
	     vector (median) = vector (first);
	     vector (first) = temp;
	     temp = vector (median);
	end;

	if vector (last).string_ptr -> string < vector (median).string_ptr -> string
	then do;
	     vector (median) = vector (last);
	     vector (last) = temp;
	     temp = vector (median);
	     if vector (first).string_ptr -> string > vector (median).string_ptr -> string
	     then do;
		vector (median) = vector (first);
		vector (first) = temp;
		temp = vector (median);
	     end;
	end;

L2:	do high = (high -1) by -1 while (vector (high).string_ptr -> string > temp.string_ptr -> string);
	end;

	do low = (low + 1) by 1 while (vector (low).string_ptr -> string < temp.string_ptr -> string);
	end;

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

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

	depth = depth + 1;

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

	if first = 1
	then if first < last
	     then goto L1;

	do first = (first + 1) to last;
	     temp = vector (first);
	     do low = first -1 by -1 while (vector (low).string_ptr -> string > temp.string_ptr -> string);
		vector (low + 1) = vector (low);
	     end;
	     vector (low + 1) = temp;
	end;

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

     end speedtype_sort_;



		    speedtype_suffix_.pl1           01/06/81  1251.1rew 01/06/81  1247.7       66654


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

speedtype_suffix_: procedure (arg_sb_ptr, arg_exp_ptr, arg_spc_ptr, arg_suffixx, arg_match_ptr, arg_match_len);

/*	This procedure is an internal interface of the Speedtype subsystem.
   *	Created on 01/01/76 by Bill Silver as notescript_suffix_.
   *	Changed on 06/13/77 by Bill Silver to speedtype_suffix_.
   *      Changed on 06/04/80 by Paul Benjamin for special suffixing.
   *
   *	It is called to set a suffix action index for a defined symbol.
   *	The action index set depends upon the suffix and the expansion string
   *	for this symbol.  All possible action indexes will be tried until one is
   *	found that matches the specified string.  If no action index results
   *	in a match then this suffix for this symbol is disabled.  If the
   *	length of the match string is "0" or "-1", then the following special
   *	processing is performed:
   *	   0 => default action index
   *	  -1 => disable this suffix.
*/

/*		ARGUMENTS			*/

dcl  arg_exp_ptr ptr;				/* (I) Pointer to expansion entry. */
dcl  arg_match_len fixed bin;				/* (I) Length of expansion ( 0=>default, -1=>disable). */
dcl  arg_match_ptr ptr;				/* (I) Pointer to expansion we have to match. */
dcl  arg_sb_ptr ptr;				/* (I) Pointer to symbol entry. */
dcl  arg_spc_ptr ptr;                                       /* (I) Pointer to special entry. */
dcl  arg_suffixx fixed bin;				/* (I) Number of specified suffix. */


/*		AUTOMATIC DATA		*/

dcl  sb_buf char (8);				/* Used to expand symbol with suffix. */
dcl  exp_buf char (56);				/* Holds expansion. */

/* Note above that 56 is really length(exp.expansion). */

dcl  ecode fixed bin (35);				/* Error table code. */
dcl  exp_buf_len fixed bin;				/* Length of expansion buffer. */
dcl  exp_buf_ptr ptr;				/* Pointer to expansion buffer. */
dcl  exp_len fixed bin;				/* Length of expansion argument. */
dcl  i fixed bin;
dcl  match_len fixed bin;				/* Length of expansion we have to match. */
dcl  match_ptr ptr;					/* Pointer to expansion we have to match. */
dcl  sb_buf_ptr ptr;				/* Pointer to symbol buffer. */
dcl  sb_len fixed bin;				/* Length of symbol with suffix. */
dcl  suffixx fixed bin;				/* Number of specified suffix. */
dcl  word_type fixed bin;				/* Word type of expansion. */


/*		BASED  DATA		*/

dcl  expansion char (exp_len) based (exp_buf_ptr);

dcl  match_expansion char (match_len) based (match_ptr);


/*		INTERNAL STATIC DATA	*/

dcl  num_actions fixed bin				/* Current number of known suffix actions. */
     internal static init (6);

dcl  default_actionx (0:6, 5) fixed bin			/* (word_type, suffix) default action indexes. */
     internal static init (1, 1, 1, 1, 1,		/* other */
     1, 2, 2, 2, 2,					/* "Ce" */
     1, 2, 1, 2, 1,					/* "Ve" */
     5, 4, 1, 4, 1,					/* "Cy" */
     1, 1, 1, 1, 1,					/* "Vy" */
     6, 1, 1, 1, 1,					/* "ch", "sh", or "ex" */
     1, 3, 3, 3, 1);				/* "CVC" */

dcl  vowels char (5)
     internal static init ("eaiou");


/*		EXTERNAL ENTRIES CALLED	*/

dcl (addr, index, length, ptr, substr) builtin;

dcl  speedtype_expand_ entry (ptr, fixed bin, ptr, fixed bin, fixed bin, fixed bin (35));
						/* 	*/
%include speedtype_symbols;
/* 	*/
	sb_ptr = arg_sb_ptr;			/* Copy arguments. */
	exp_ptr = arg_exp_ptr;
	spc_ptr = arg_spc_ptr;
	suffixx = arg_suffixx;
	match_ptr = arg_match_ptr;			/* Set reference to expansion to match. */
	match_len = arg_match_len;

	if match_len = -1				/* -1 => disable this suffix. */
	then do;					/* That is what we have to do. */
	     exp.actionx (suffixx) = 0;
	     return;
	end;

	if match_len = 0				/* 0 => set default action index. */
	then do;
	     word_type = GET_WORD_TYPE ();		/* Get word type of expansion. */
	     exp.actionx (suffixx) = default_actionx (word_type, suffixx);
	     return;
	end;

/*	We must find an action index that will expand this symbol the
   *	way the caller wants.  First  test expansion to see if it is valid.
   *	Then built the symbol with the specified suffix.
*/
	ssd_ptr = ptr (sb_ptr, 0);			/* Get pointer to base of symbol dictionary. */
	if match_len > length (exp.expansion)		/* Is expansion too long? */
	then do;					/* Yes, disable this suffix. */
	     exp.actionx (suffixx) = 0;
	     return;
	end;

	sb_buf = sb.symbol;				/* Copy symbol into our buffer. */
	sb_len = index (sb_buf, " ");			/* Get the length of the symbol. */
	if sb_len = 0 then sb_len = length (sb_buf);
	sb_buf_ptr = addr (sb_buf);			/* Set up buffer pointers and lengths for expanding. */
	exp_buf_ptr = addr (exp_buf);
	exp_buf_len = length (exp_buf);

/* Add suffix to symbol. */
	substr (sb_buf, sb_len, 1) = substr (ssd.suffixes, suffixx, 1);

	do i = 1 to num_actions;			/* Try all known action indexes. */
	     exp.actionx (suffixx) = i;		/* Try this action index. */
	     call speedtype_expand_ (sb_buf_ptr, sb_len, exp_buf_ptr, exp_buf_len, exp_len, ecode);
	     if expansion = match_expansion		/* Does expansion match? */
	     then return;				/* Yes, action index set correctly. */
	end;

	exp.actionx(suffixx) = 7;                         /* User has specified special suffixing. */
	spc.special(suffixx) = match_expansion;

	return;
						/* 	*/
GET_WORD_TYPE: procedure returns (fixed bin);

/*	This function will return an index that represents the word type of
   *	the expansion.  Speedtype currently recognizes the following word
   *	types:
   *	  0 - other => none of the below
   *	  1 - ends in "e" preceeded by a consonant
   *	  2 - ends in "e" preceeded by a vowel
   *	  3 - ends in "y" preceeded by a consonant
   *	  4 - ends in "y" preceeded by a vowel
   *	  5 - ends in "ch" or "sh" or "ex"
   *	  6 - ends with a consonant || vowel || consonant
*/
	     exp_buf_ptr = addr (exp.expansion);	/* Work on expansion entry itself. */
	     exp_len = exp.len;

	     if exp_len < 3 then return (0);		/* Default for short expansions. */

	     if substr (expansion, exp_len, 1) = "e"
	     then do;				/* Expansion ends with "e". */
		if index (vowels, substr (expansion, (exp_len - 1), 1)) = 0
		then return (1);			/* Preeceded by a consonant. */
		else return (2);			/* Preceeded by a vowel. */
	     end;

	     if substr (expansion, exp_len, 1) = "y"
	     then do;				/* Expansion ends with "y". */
		if index (vowels, substr (expansion, (exp_len - 1), 1)) = 0
		then return (3);			/* Preceded by a consonant. */
		else return (4);			/* Preceded by a vowel. */
	     end;

	     if (substr (expansion, (exp_len - 1), 2) = "ch") |
	     (substr (expansion, (exp_len - 1), 2) = "sh") |
	     (substr (expansion, (exp_len - 1), 2) = "ex")
	     then return (5);

	     if (index (vowels, substr (expansion, exp_len, 1)) = 0) &
	     (index (vowels, substr (expansion, (exp_len - 1), 1)) ^= 0) &
	     (index (vowels, substr (expansion, (exp_len - 2), 1)) = 0)
	     then return (6);			/* Consonant || vowel || consonant */

	     return (0);				/* None of the above. */

	end GET_WORD_TYPE;

     end speedtype_suffix_;
  



		    speedtype_util_.pl1             01/06/81  1251.1rew 01/06/81  1247.7       48987


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

speedtype_util_: rns: procedure;

/*	This procedure is an internal interface of the Speedtype subsystem.
   *	Created on 02/03/76 by Bill Silver as notescript_util_.
   *	Changed on 06/13/77 by Bill Silver to speedtype_util_.
   *      Changed on 05/30/80 by Paul Benjamin to change dcl of bit_count.
   *
   *	It contains entry points that are called to set up input and output
   *	segments for the expand_symbols and retain_symbols commands.
*/

/*		ARGUMENTS			*/

dcl  arg_dir_name char (*);				/* (I)   Directory containing input or output segment. */
dcl  arg_ent_name char (*);				/* (I)   Entry name of input or output segment. */
dcl  arg_ecode fixed bin (35);			/* (O)   Returned error_table_ code. */
dcl  arg_in_ptr ptr;				/* (I/O) Pointer to input segment. */
dcl  arg_out_ptr ptr;				/* (I/O) Pointer to output segment. */
dcl  arg_seg_len fixed bin (21);			/* (I/O) Length of input or output segment. */
dcl  arg_temp_flag bit (1);				/* (I)   ON => copy output segment into input segment. */

/*		AUTOMATIC DATA		*/

dcl  bit_count fixed bin (24);			/* Bit count of input and output segments. */
dcl  ecode fixed bin (35);				/* Error table code. */
dcl  in_ptr ptr;					/* Pointer to input segment. */
dcl  out_ptr ptr;					/* Pointer to output segment. */
dcl  seg_len fixed bin (21);				/* Length of an output segment. */
dcl  words fixed bin (19);				/* Size of output segment at completion of command. */


/*		BASED DATA		*/

dcl  based_data char (seg_len) based;			/* Used to copy temporary output segment. */

/*		EXTERNAL ENTRIES		*/

dcl (null) builtin;

dcl  error_table_$zero_length_seg fixed bin (35) external;

dcl  hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl  hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24),
	fixed bin(2), ptr, fixed bin(35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_bc_seg  entry (ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35));
						/* 	*/
init_input_seg: entry (arg_dir_name, arg_ent_name, arg_in_ptr, arg_seg_len, arg_ecode);

/*	This entry will initiate an input segment.  it will return a pointer
   *	to this segment and will return the length of the segment.
*/
	call hcs_$initiate_count (arg_dir_name, arg_ent_name, "", bit_count, (0), in_ptr, ecode);
	if in_ptr = null ()				/* Did we get a pointer to segment? */
	then do;					/* No, error. */
	     arg_ecode = ecode;
	     return;
	end;

	if bit_count = 0				/* Is this a zero length segment? */
	then do;					/* Yes, cannot process input segment. */
	     arg_ecode = error_table_$zero_length_seg;
	     return;
	end;

	arg_in_ptr = in_ptr;			/* Return pointer to input segment. */
	arg_seg_len = bit_count / 9;			/* Return length of input segment. */
	arg_ecode = 0;				/* No error, make sure no error code. */
	return;
						/* 	*/
init_output_seg: entry (arg_dir_name, arg_ent_name, arg_out_ptr, arg_seg_len, arg_ecode);

/*	This entry will initialize an output segment.  If the segment does not
   *	exist it will be created.  It will return a pointer to the segment
   *	and it will return the maximum length of the segment in characters.
*/
	if arg_dir_name ^= " "			/* Blank name => use process directory. */
	then call hcs_$make_seg (arg_dir_name, arg_ent_name, "", 01010b, out_ptr, ecode);
	else call hcs_$make_seg ("", arg_ent_name, "", 01010b, out_ptr, ecode);

	if out_ptr = null ()			/* Did we get a pointer to the output segment? */
	then do;					/* No. */
	     arg_ecode = ecode;
	     return;
	end;

	call hcs_$get_max_length_seg (out_ptr, words, ecode);
	if ecode ^= 0
	then do;
	     arg_ecode = ecode;
	     return;
	end;

	arg_out_ptr = out_ptr;			/* Return a pointer to the output segment. */
	arg_seg_len = words * 4;			/* Return max size of segment in characters. */
	arg_ecode = 0;
	return;
						/* 	*/
fix_output_seg: entry (arg_temp_flag, arg_in_ptr, arg_out_ptr, arg_seg_len, arg_ecode);

/*	This entry will fix an output segment so that its actual size
   *	and bit count are correct.
*/
	in_ptr = arg_in_ptr;			/* Copy arguments. */
	out_ptr = arg_out_ptr;
	seg_len = arg_seg_len;
	if arg_temp_flag				/* Is output segment a temporary? */
	then do;					/* Yes, copy output into input segment. */
	     in_ptr -> based_data = out_ptr -> based_data;
	     call hcs_$truncate_seg (out_ptr, 0, ecode);
	     out_ptr = in_ptr;			/* Input and output segments are now the same. */
	end;

	words = (seg_len + 3) / 4;			/* Get number of words needed by output segment. */
	call hcs_$truncate_seg (out_ptr, words, ecode);
	if ecode ^= 0				/* Error trying to adjust size of output segment. */
	then do;					/* Yes there was an error. */
	     arg_ecode = ecode;
	     return;
	end;

	bit_count = seg_len * 9;			/* Get number of bits in output segment. */
	call hcs_$set_bc_seg (out_ptr, bit_count, ecode);

	arg_ecode = ecode;
	return;

     end speedtype_util_;
 



		    use_symbols.pl1                 01/06/81  1251.1rew 01/06/81  1247.7       27090


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

use_symbols: usb: procedure;

/*	This procedure implments the use_symbols command.
   *	Created on 10/13/75 by Bill Silver as use_notescript.
   *	Changed on 06/10/77 by Bill Silver to use_symbols.
   *      Changed on 10/28/80 by Paul Benjamin for special suffixing.
   *
   *	The use_symbols (usb) command will establish the specified segment
   *	as the current Speedtypesymbol dictionary.  Its calling sequence is:
   *
   *	     use_symbols, usb  path
*/
dcl  dir_name char (168);				/* Directory of new symbol dictionary. */
dcl  ent_name char (32);				/* Entry name of new symbol dictionary. */

dcl  ecode fixed bin (35);				/* Error table code. */
dcl  i fixed bin;
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  path_len fixed bin;				/* Length of pathanme argument. */

dcl  path_ptr ptr;					/* Pointer to pathname argument. */

dcl  pathname_arg char (path_len) based (path_ptr);

dcl (addr, index, substr) builtin;

dcl  error_table_$no_w_permission fixed bin(35) ext static;
dcl  error_table_$wrong_no_of_args fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  speedtype_info_$use entry (char (*), char (*), fixed bin (35));
						/* 	*/
	call cu_$arg_count (num_args);		/* Check the number of arguments. */
	if num_args ^= 1				/* There should be one and only one. */
	then do;					/* Wrong number of args. */
	     ecode = error_table_$wrong_no_of_args;
	     call com_err_ (ecode, "Speedtype", "Usage is:  usb path");
	     return;
	end;

	call cu_$arg_ptr (1, path_ptr, path_len, ecode);
	if ecode ^= 0
	then do;
	     call com_err_ (ecode, "Speedtype", "Error getting pathname argument");
	     return;
	end;

	call expand_path_ (path_ptr, path_len, addr (dir_name), addr (ent_name), ecode);
	if ecode ^= 0
	then do;
	     call com_err_ (ecode, "Speedtype", "Error expanding pathname ^a", pathname_arg);
	     return;
	end;

	i = index (ent_name, ".symbols");
	if i = 0					/* Does entry name already contain suffix? */
	then do;					/* No. */
	     i = index (ent_name, " ") - 1;		/* Look for first blank. */
	     ent_name = substr (ent_name, 1, i) || ".symbols";
	end;

	call speedtype_info_$use (dir_name, ent_name, ecode);
	if ecode = error_table_$no_w_permission
	     then call com_err_ (ecode, "Speedtype", "Attempting to convert ^a>^a to new version.", dir_name, ent_name);

     end use_symbols;


		    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