


		    PNOTICE_fast.alm                10/27/88  1048.1r w 10/27/88  1048.1        2853


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

	aci	"C1FASM0E0000"
	aci	"C2FASM0E0000"
	aci	"C3FASM0E0000"
	end
   



		    add_line_numbers.pl1            01/19/88  1505.6rew 01/19/88  1501.8       76329


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


/****^  HISTORY COMMENTS:
  1) change(87-12-03,TLNguyen), approve(87-12-03,MCR7806),
     audit(87-12-10,Lippard), install(88-01-19,MR12.2-1015):
     - Fixed string range condition occured in the copy internal procedure.
     - Replace the hcs_$initiate_count entrypoint in the get_seg internal
       procedure with the initiate_file_ to meet standards and add the include
       file named access_mode_values.incl.pl1.
     - Replace the "^a>^a" argument string in com_err_ with the pathname_.
     - Remove error_table_$badopt and error_table_$segknown entrypoints
       from the source since they are not referenced anywhere within it.
                                                   END HISTORY COMMENTS */


add_line_numbers: aln: proc;

/* * This procedure adds or deletes line numbers from the beginning of each line or a specified segment.
   * It also discards characters at the end of a segment that does not end with a new_line character.
   *
   *	add_line_numbers, aln  path  [sequence_number]  [increment]
   *
   *	     default values:
   *		sequence_number = 100
   *		increment = 10
   *
   *	delete_line_numbers, dln  path
   *
   *	     This procedure strips off leading digits from a line.  If the line does not begin with a digit,
   *	     it is kept unchanged.  If the leading digits are followed by a blank, then one blank is also  removed.
   *
   *		" 20 abc"		->	" 20 abc"		no leading digit
   *		"20 abc"		->	"abc"
   *		"20abc"		->	"abc"
   *		"20  abc"		->	" abc"		only one blank is removed
   *
   * Written 3/76 by S.E. Barr
*/
/* Bug fixed that adds null chars 06/24/81 S. Herbst */

/* automatic */

dcl  arg_len fixed bin;
dcl  arg_ptr ptr;
dcl  bit_count fixed bin (24);
dcl  command_name char (19);
dcl  code fixed bin (35);
dcl  directory_name char (168) aligned;
dcl  entry_name char (32) aligned;
dcl  i fixed bin (21);				/* num characters in line */
dcl  increment fixed bin;
dcl  nargs fixed bin;				/* number of arguments to command */
dcl  number_pic pic "99999";				/* leading zeros  */
dcl  seg_length fixed bin (21);
dcl  seg_ptr ptr init (null);
dcl  seq_number fixed bin;
dcl  start fixed bin (21);
dcl  temp_length fixed bin (21);
dcl  temp_ptr ptr init (null);

dcl (addr, length, substr, index, verify, null, divide) builtin;

dcl  cleanup condition;

/* constants */

dcl  DIGIT char (10) int static options (constant) init ("0123456789");
dcl  edit_max_number fixed bin int static options (constant) init (99999);
dcl  NEW_LINE char int static options (constant) init ("
");

/* based */

dcl  arg char (arg_len) based (arg_ptr);
dcl  ptr_array (1) ptr based;
dcl  seg char (seg_length) based (seg_ptr);
dcl  temp char (temp_length) based (temp_ptr);


/* 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  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  error_table_$wrong_no_of_args fixed bin (35) ext;
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  fst_cv_line_num_ entry (char (*), fixed bin, fixed bin (35)) returns (bit (1) unal);
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (21), fixed bin (35));
dcl  initiate_file_ entry (char (*) aligned, char (*) aligned, bit (*), pointer, fixed bin (24), fixed bin (35));
dcl  pathname_ entry (char (*) aligned , char (*) aligned) returns (char (168));
dcl  release_temp_segments_ entry (char (*), (*)ptr, fixed bin (35));

%page;
%include dfast_error_codes;
%page;
%include access_mode_values;

/*   */
	command_name = "add_line_numbers";

/* parse arguments for pathname and optionsl sequence number and increment */

	call cu_$arg_count (nargs);
	if nargs > 0 & nargs <= 3 then do;

	     temp_ptr, seg_ptr = null;
	     on cleanup call term_seg;

	     if get_seg () then do;
		seq_number = 100;
		increment = 10;

		if nargs >= 2 then do;
		     call cu_$arg_ptr (2, arg_ptr, arg_len, code);
		     if code = 0 then do;
			if fst_cv_line_num_ (arg, seq_number, code) then do;
			     if nargs = 3 then do;
				call cu_$arg_ptr (3, arg_ptr, arg_len, code);
				if code = 0 then if fst_cv_line_num_ (arg, increment, code) then;
			     end;
			end;
		     end;
		     if code ^= 0 then call dfast_error_ (code, command_name, arg);
		end;


/* loop through the text adding the numbers to each line.  The only error that can occur, is exceeding the max line number */

		if code = 0 then do;
		     do start = 1 repeat (start + i) while (start <= seg_length & code = 0);

			if seq_number <= edit_max_number then do;
			     i = index (substr (seg, start), NEW_LINE);
			     if i > 0 then do;
				number_pic = seq_number;
				call copy (number_pic || " ");
				call copy (substr (seg, start, i));
			     end;
			     else i = seg_length + 1; /* discard rest of the characters */
			     seq_number = seq_number + increment;
			end;
			else code = error_edit_max_num;
		     end;

		     if code = 0 then call switch;
		     else call dfast_error_ (code, command_name, "");
		end;
	     end;
	     call term_seg;
	end;
	else call com_err_ (error_table_$wrong_no_of_args, command_name, """path seq_number increment""");

	return;

/*  */
delete_line_numbers: dln: entry;

	command_name = "delete_line_numbers";
	call cu_$arg_count (nargs);
	if nargs = 1 then do;

	     temp_ptr, seg_ptr = null;
	     on cleanup call term_seg;

	     if get_seg () then do;
		do start = 1 repeat (start + i) while (start <= seg_length);
		     i = verify (substr (seg, start), DIGIT);
		     if i > 0 then do;
			if i > 1 then if substr (seg, start + i -1, 1) = " " then i = i + 1;
			start = start + i -1;
			i = index (substr (seg, start), NEW_LINE);
			if i = 0 then i = seg_length; /* discard line fragment */
			else call copy (substr (seg, start, i));
		     end;
		     else i = seg_length;		/* discard line fragment */
		end;
		call switch;
	     end;
	     call term_seg;
	end;
	else call com_err_ (error_table_$wrong_no_of_args, command_name, "pathname is missing");

	return;

/*  */
get_seg:	proc returns (bit (1) unal);


	     call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	     if code = 0 then do;
		call expand_path_ (arg_ptr, arg_len, addr (directory_name), addr (entry_name), code);
		if code = 0 then do;
		     call initiate_file_ (directory_name, entry_name, R_ACCESS, seg_ptr, bit_count, code);
		     if seg_ptr ^= null then do;
			if bit_count > 0 then do;
			     seg_length = divide (bit_count, 9, 21, 0);
			     call get_temp_segments_ ("fast", addr (temp_ptr) -> ptr_array, code);
			     temp_length = 0;
			     if code = 0 then return ("1"b);
			end;
			else call com_err_ (0, command_name, "segment is empty", arg);
		     end;
		     else call com_err_ (code, command_name, pathname_ (directory_name, entry_name));
		end;
		else call com_err_ (code, command_name, arg);
	     end;
	     else call com_err_ (code, command_name, "pathname is missing");

	     return ("0"b);

	end get_seg;

/*   */
copy:	proc (string);

dcl  string char (*);
dcl  next_position fixed bin;

	     next_position = temp_length + 1;
	     temp_length = temp_length + length (string);
	     substr (temp, next_position, length (string)) = string;


	     return;

	end copy;


term_seg:	proc;

	     if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, 0);
	     if temp_ptr ^= null then call release_temp_segments_ (command_name, addr (temp_ptr) -> ptr_array, code);

	     return;

	end term_seg;


switch:	proc;

	     seg_length = temp_length;
	     bit_count = seg_length * 9;
	     seg = temp;
	     call hcs_$set_bc_seg (seg_ptr, bit_count, code);
	     if code = 0 then call hcs_$truncate_seg (seg_ptr, divide (bit_count + 35, 36, 21, 0), code);

	     return;

	end switch;

     end add_line_numbers;
   



		    dfast_basic_resequence_.pl1     01/19/88  1505.6rew 01/19/88  1500.7      122733


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


/****^  HISTORY COMMENTS:
  1) change(87-12-03,TLNguyen), approve(87-12-03,MCR7806),
     audit(87-12-10,Lippard), install(88-01-19,MR12.2-1015):
     - Remove the "search" from the source because it is not referenced
       anywhere within the source program.
                                                   END HISTORY COMMENTS */


dfast_basic_resequence_: proc (max_seg_size, line_table_ptr, input_segment, resequence_lines, temp_ptr, temp_length, code);

/* *	This procedure is given a block of Basic source lines and a table of line numbers.
   *	The table has two numbers for each line that is to be changed -- old_number, the current number for the
   *	line; and new_number, the number that the line will have after resequencing.  The source code is
   *	parsed and all Basic references to lines in the line table are edited.  the procedure can be called
   *	in two ways:
   *
   *	     resequence_lines = "1"b		The line numbers will be checked against the line table in addition
   *					to the editing for line number references.
   *
   *	     resequence_lines = "0"b		Only the line reference editing will be done.
   *
   *
   *	Statements with possible line number references:
   *
   *	     if ---- then NUMBER
   *	     if ---- goto NUMBER
   *	     gosub NUMBER
   *	     goto NUMBER
   *	     on ---- goto NUMBER, NUMBER . . .
   *	     on ---- gosub NUMBER, NUMBER . . .
   *	     on ---- then NUMBER, NUMBER . . .
   *
   *	Keywords may contain blanks and may be uppercase or lowercase.
   *   Modified 10/28/83 C Spitzer. phx8299. fix so doesn't remove whitespace at
		end of line or end of statement but before comment.
*/

/* parameters */

dcl  max_seg_size fixed bin (21);			/* max number of characters in segment */
dcl  line_table_ptr ptr;
dcl  input_segment char (*);
dcl  resequence_lines bit (1);
dcl  temp_ptr ptr;
dcl  temp_length fixed bin (21);
dcl  code fixed bin (35);

/* automatic */

dcl  char char (1);
dcl  line char (256) var;				/* lowercase image of one line */
dcl  line_start fixed bin (21);			/* index in input_segment of line being edited */
dcl  line_length fixed bin (21);			/* number of characters in input segment */
dcl  input_segment_length fixed bin (21);		/* number of characters to be edited */
dcl  number_string char (12);				/* scratch space for formatting new numbers */
dcl  number_length fixed bin (21);			/* number of ditits in line number */
dcl  number_pic pic "99999";

dcl (index, length, substr, translate, verify) builtin;

/* constants */

dcl  LEADING_ZERO bit (1) unal int static options (constant) init ("1"b);
dcl  NEW_LINE char (1) int static options (constant) init ("
");
dcl  DIGITS char (10) int static options (constant) init ("0123456789");
dcl  MAX_NUM_DIGITS int static options (constant) init (5); /* number of digits in a line number */
dcl  WHITE_SPACE char (2) int static options (constant) init ("	 "); /* tab & blank */
dcl  APOSTROPHE char (1) int static options (constant) init ("'"); /* ' = rest of line is comment */
dcl  QUOTE char (1) int static options (constant) init (""""); /* "string" is ignored by resequencer */

/* based */

dcl 1 t aligned based (line_table_ptr),
    2 num_lines fixed bin (21),
    2 line_table (t.num_lines),
      3 old_number fixed bin (17) unal,
      3 new_number fixed bin (17) unal;

dcl  temp_seg char (max_seg_size) based (temp_ptr);

/* entries */

dcl  ioa_$rsnnl entry options (variable);

%include dfast_error_codes;
/*  */
/* *	The source code is parsed one line at a time and the edited version is put in temp_seg.
   *
   *	The line begins with a number:
   *
   *	     1.  The line number is edited and copied into temp_seg.
   *	     2.  The portion of the line following the line number is converted to lowercase and stored in line.
   *	     3.  The line image is parsed for line number references and the original is copied into temp_seg
   *	         with the line references changed.
   *
   *	The line does not begin with a number:
   *
   *	     The line is copied as is.
*/

	line_start = 1;
	input_segment_length = length (input_segment);

	do while (line_start <= input_segment_length & code = 0);

	     line_length = index (substr (input_segment, line_start), NEW_LINE);
	     if line_length > 0 then do;

		number_length = verify (substr (input_segment, line_start, line_length), DIGITS) -1;
		if number_length > 0 then do;
		     if resequence_lines then do;
			if ^store_new_number (LEADING_ZERO, substr (input_segment, line_start, number_length))
			then call move (line_start, number_length);
		     end;
		     else call move (line_start, number_length);
		     line_start = line_start + number_length;
		     line_length = line_length - number_length;

		     line = translate (substr (input_segment, line_start, line_length),
			"abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");

		     call edit_line;
		end;

		else call move (line_start, line_length);

		line_start = line_start + line_length;
	     end;

	     else code = error_no_nl;
	end;

	return;

/*  */
/*  This procedure copies a portion of the input segment into the temporary segment.
*/
move:	proc (start, num_chars);

dcl  start fixed bin (21);				/* index on input segment of first character to move */
dcl  num_chars fixed bin (21);			/* number of characters to move */

	     if num_chars > 0 then do;
		substr (temp_seg, temp_length + 1, num_chars) = substr (input_segment, start, num_chars);
		temp_length = temp_length + num_chars;
	     end;

	     return;

	end move;

/*  */
/*  This procedure checks line which contains a lowercase image of one basic source line.
   If it locates a basic statement that refers to a line number, the new line number (if it exits)
   is substituted.  If it does not find a line number reference, no change is made.
*/
edit_line: proc;

dcl  i fixed bin (21);
dcl  replace_number bit (1);
dcl  multiple_numbers bit (1);			/* ON if more than on number expected */

	     i = 1;
	     replace_number = "0"b;
	     multiple_numbers = "0"b;

/* if ---- then NUMBER */

	     if next_word (i, "if") then do;

		if search_word (i, "then") then replace_number = "1"b;
		else if search_word (i, "go") then
		     if next_word (i, "to") | next_word (i, "sub") then replace_number = "1"b;
	     end;

/* goto NUMBER */

	     else if next_word (i, "go") then do;
		if next_word (i, "to") | next_word (i, "sub") then replace_number = "1"b;
	     end;

/* on ---- goto NUMBER, NUMBER . . . */

	     else if next_word (i, "on") then do;
		multiple_numbers = "1"b;
		if search_word (i, "go") then do;
		     if next_word (i, "to") | next_word (i, "sub") then replace_number = "1"b;
		end;
		else if search_word (i, "then") then replace_number = "1"b;
	     end;

	     if replace_number then do;

		call move (line_start, i -1);

		call store_multiple_numbers (i, multiple_numbers);

		call move (line_start + i -1, line_length - i + 1);
	     end;

	     else call move (line_start, line_length);

	     return;

	end edit_line;

/*  */
/* *	This procedure parses line (which contains a lowercase image of a Basic source line) beginning at start.
   *	It ignores blanks and tabs.  There are two returns:
   *
   *	     "1"b		The next word is 'word'
   *			start = index on line following 'word'
   *
   *	     "0"b		The next word is not 'word'
   *			start is unchanged.
*/
next_word: proc (start, word) returns (bit (1));

dcl  start fixed bin (21);
dcl  word char (*);

dcl  word_length fixed bin (21);
dcl  word_index fixed bin (21);
dcl  line_index fixed bin (21);

	     word_length = length (word);
	     line_index = start;

	     do word_index = 1 to word_length;

		if get_char (line_index, char) then do;

		     if char ^= substr (word, word_index, 1) then return ("0"b);
		     line_index = line_index + 1;
		end;
		else return ("0"b);
	     end;

	     start = line_index;
	     return ("1"b);

	end next_word;

/*  */
/*  This procedure looks for a word in line beginning at start.  The word may have imbedded blanks.

   *	returns	"1"b	The word was found.
   *			start = index of character following word.
   *	returns	"0"b	The word was not found.
   *			start is unchanged.
   *
   * The procedure skips quoted strings and stops checking if an apostrophy is found
   * indicating the rest of the line is a comment.
*/
search_word: proc (start, word) returns (bit (1));

dcl  start fixed bin (21);
dcl  word char (*);

dcl  word_length fixed bin (21);
dcl  word_index fixed bin (21);
dcl (i, j) fixed bin (21);

	     i = start;
	     word_length = length (word);
	     word_index = 1;

	     do while (i <= line_length);
		if get_char (i, char) then do;
		     if char = substr (word, word_index, 1) then do;
			if word_index = word_length then do;
			     start = i + 1;
			     return ("1"b);
			end;

			else word_index = word_index + 1;
		     end;

		     else do;
			word_index = 1;

			if char = QUOTE then do;
			     j = index (substr (line, i + 1), QUOTE); /* This also covers "" inside a string */
			     if j > 0 then i = i + j;
			     else return ("0"b);
			end;
			else if char = APOSTROPHE then i = line_length; /* omit rest of line */
		     end;

		     i = i + 1;
		end;

		else return ("0"b);
	     end;

	     return ("0"b);

	end search_word;


/*  */
/*  This procedure finds the next non_blank character on the line.  If the end of the line is
   *  reached "0"b is returned.
*/
get_char:	proc (start, char) returns (bit (1));

dcl  start fixed bin (21);
dcl  char char (1);

dcl  i fixed bin (21);

	     if start <= line_length then do;

		i = verify (substr (line, start), WHITE_SPACE);

		if i > 0 then do;
		     start = start + i -1;
		     char = substr (line, start, 1);
		     return ("1"b);
		end;
	     end;

	     start = line_length;

	     return ("0"b);

	end get_char;

/*  */

/*  This procedure expects a line segment of the form:
   *
   *	[<blanks> <digit>] . . .
   *
   *  It forms a number from the digits and if the number is in the line table, the corresponding
   *  new number is used instead.  If the number is not in the line table or if a number is not
   *  found on the line, the line is copied as is.
*/
edit_number: proc (start) returns (bit (1));

dcl  start fixed bin (21);

dcl  index_first_digit fixed bin (21);
dcl  num_digits fixed bin;
dcl  i fixed bin (21);
dcl  not_eol bit (1) aligned;

	     num_digits = 0;
	     i = start;
	     not_eol = get_char (i, char);

	     do while (not_eol);

		if index (DIGITS, char) > 0 then do;

		     num_digits = num_digits + 1;
		     if num_digits <= MAX_NUM_DIGITS then do;
			if num_digits = 1 then index_first_digit = i;
			substr (number_string, num_digits, 1) = char;
			i = i + 1;
			if i > line_length
			then not_eol = "0"b;
			else char = substr (line, i, 1);
		     end;

		     else return ("0"b);
		end;

		else do;
		     if num_digits > 0 then do;
			call move (line_start + start -1, index_first_digit - start);
			if store_new_number (^LEADING_ZERO, substr (number_string, 1, num_digits)) then start = i;
			else do;
			     call move (line_start + index_first_digit -1, i - index_first_digit);
			     start = i;
			end;
			return ("1"b);
		     end;

		     else return ("0"b);

		end;

	     end;


	     return ("0"b);

	end edit_number;

/*  */

store_multiple_numbers: proc (start, multiple_numbers);

dcl  start fixed bin (21);
dcl  j fixed bin (21);
dcl  multiple_numbers bit (1);

	     do while (edit_number (start));
		j = start;
		if get_char (j, char) then do;
		     if char = "," then do;
			call move (line_start + start -1, j - start + 1);
			start = j + 1;
		     end;
		     else return;
		end;
		else return;

		if ^multiple_numbers then return;
	     end;

	     return;

	end store_multiple_numbers;

/*  */
/* *	This procedure is given a string of digits.  It converts the string into a number and looks
   *	the number up in the line table.  If the number is in the line table, it puts the corresponding
   *	new number in the temporary segment.  If the number is not in the line table, it does nothing.
   *
   *	There are two returns:
   *
   *	     "1"b		The number was found.
   *	     "0"b		The number was not found.
*/
store_new_number: proc (leading_zero, string) returns (bit (1));

dcl  leading_zero bit (1) unal;			/* ON for leading zeros */
dcl  string char (*);

dcl  number fixed bin (21);
dcl  j fixed bin (21);
dcl  i fixed bin;

	     number_pic = 0;
	     substr (number_pic, MAX_NUM_DIGITS + 1 - length (string), length (string)) = string;
	     number = number_pic;

	     do j = 1 to num_lines;
		if number = line_table (j).old_number then do;
		     if leading_zero then do;

			number_pic = line_table (j).new_number;
			substr (temp_seg, temp_length + 1, MAX_NUM_DIGITS) = number_pic;
			temp_length = temp_length + MAX_NUM_DIGITS;
		     end;
		     else do;
			call ioa_$rsnnl ("^d", number_string, i, line_table (j).new_number);
			substr (temp_seg, temp_length + 1, i) = number_string;
			temp_length = temp_length + i;
		     end;

		     return ("1"b);
		end;
	     end;


	     return ("0"b);

	end store_new_number;

     end dfast_basic_resequence_;
   



		    dfast_error_.pl1                03/18/76  1556.2r w 03/18/76  1527.2       31626


dfast_error_: proc (code, name, additional_info);

dcl  code fixed bin (35);
dcl  name char (*);
dcl  additional_info char (*);

dcl  extra_message fixed bin;				/*  = 1 for a non-null message */
dcl  print_name fixed bin;				/* = 1 for non-null name */
dcl  message char (100) aligned;
dcl  shortinfo char (8) aligned;

dcl  hbound builtin;
dcl  iox_$user_output ptr ext;
dcl  com_err_$convert_status_code_ entry (fixed bin (35), char (*) aligned, char (*) aligned);
dcl  ioa_$ioa_switch entry options (variable);

%include dfast_error_codes;

dcl  err_mess (-1:43) char (60) var int static options (constant) init (
     "",
     "",						/* 0 */
     "alter file is empty",				/* alt_empty */
     "file would exceed maximum size",			/* max_size */
     "current file is empty",				/* cur_empty */
     "file is not saved",				/* not_saved */
     "name duplication (save denied)",			/* name_dup */
     "input line is too long",			/* long_rec */
     "unknown argument",				/* unknown_arg */
     "no explain file for",				/* no_expl */
     "illegal character in name",			/* bad_name */
     "unknown command",				/* bad_req */
     "syntax error in string specification",		/* syntax_string */
     "current segment does not have a name",		/* name_miss */
     "error in compilation",				/* no_comp */
     "no main program",				/* no_main */
     "syntax error in range specification",		/* block_spec */
     "command is not permitted for object code",		/* obj_nob */
     "current file must be saved",			/* sav_cur */
     "unknown terminal type",				/* bad_type */
     "system is not implemented",			/* unk_sys */
     "suffix missing: "".basic"" or "".fortran""",	/* no_suffix */
     "current file does not end with a new_line",		/* no_nl */
     "current file is out of order",			/* bad_sort */
     "command expects a line number",			/* no_num */
     "line was not found",				/* line_miss */
     "request is missing",				/* request_miss */
     "syntax error in line number",			/* bad_line */
     "could not find",				/* no_string */
     "line numbers must be in increasing order",		/* line_order */
     "maximum of 16 lines per request exceeded",		/* max_lines */
     "illegal pathname",				/* bad_pathname */
     "ZZZ",					/* access_mode */
     "delimitor is missing",				/* delimiter_miss */
     "record would exceed the size specified.  Length =",	/* size_fixed_record */
     "record length is expected",			/* error_no_rec_len */
     "maximum string size for replacement is 256",	/* max_string_size */
     "maximum line number has 6 digits",		/* max_line_number */
     "maximum number of arguments for a command is 10",	/* max_arg */
     "system can't be changed to conflict with name",	/*  name_sys */
     "only one segment can be printed with the ""-map"" option", /* dprint_map */
						/* fst */
     "maximum line number is 99999",			/* max_num */
     "change would exceed maximum line number (99999)", /* edit_max_num */
     "text contains un-numbered line",			/* un_num */
    "segment does not end with a new_line");		/* no_new_line */

	if code > hbound (err_mess, 1) | code < -1 then call com_err_$convert_status_code_ (code, shortinfo, message);
	else message = err_mess (code);
	if additional_info = "" then extra_message = 0;
	else extra_message = 1;
	if name = "" then print_name = 0;
	else print_name = 1;
	call ioa_$ioa_switch (iox_$user_output, "^a^v(:  ^)^a  ^v(^a", name, print_name, message, extra_message, additional_info);

	return;

     end dfast_error_;
  



		    dfast_get_table_.pl1            01/19/88  1505.6r w 01/19/88  1501.5       40410


dfast_get_table_: proc (convert, seg_ptr, seg_length, table_ptr, code);

/* * This procedure fills in the line table and checks the segment to be sure it is ordered.
   * If the segment is out of order and convert is not set then an error code is set.
   * Otherwise the table is set up and sorted so that the lines will be in order when copied.
   *
   *	If the segment doesn't end with a new line it the characters following the last new line will
   *	be discarded.  (The whole file if necessary).
   *
   *	If lines do not begin with line numbers they will be deleted.
   */

dcl  convert bit (1) unal;				/* ON if illegal lines should be converted */
dcl  seg_ptr ptr;					/* points to segment with source code */
dcl  seg_length fixed bin (21);			/* number of characters in segment */
dcl  table_ptr ptr;					/* points to table structure */
dcl  code fixed bin (35);

/* automatic */

dcl  seg_index fixed bin (21);			/* seg_index from 1 on segment */
dcl  new_number fixed bin;
dcl  last_num fixed bin;
dcl  i fixed bin (21);
dcl  sorted bit (1) unal;
dcl  blank bit (1) unal;				/* ON if line with just a number */
dcl  len fixed bin (21);

dcl 1 temp_line,
    2 temp_num fixed bin (21),			/* for moving lines around */
    2 temp_start fixed bin (21),
    2 temp_num_chars fixed bin (21);

dcl  (index, substr, verify) builtin;

/* external */

dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));

/*  constants */

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

/* based */

dcl  seg char (seg_length) based (seg_ptr);
dcl 1 t aligned based (table_ptr) like dfast_line_table;

%include dfast_line_table;
%include dfast_error_codes;

/*  */
	last_num = -1;
	seg_index = 1;
	sorted = "1"b;
	t.table_length = 0;

	do while (seg_index <= seg_length);

	     len = index (substr (seg, seg_index, seg_length - seg_index + 1), new_line);
	     if len = 0 then do;
		if convert then seg_index = seg_length + 1;	/* discard line fragment */
		else code = error_no_nl;
	     end;

	     else do;
		if get_number (substr (seg, seg_index, len), new_number, blank, code) then do;
		     if new_number > last_num then t.table_length = t.table_length +1;

		     else do;
			if ^convert then code = error_bad_sort;

/*  If the lines have the same number the index is not incremented and so the earlier line is ignored. */

			else do;
			     if new_number < last_num then do;
				t.table_length = t.table_length +1;
				sorted = "0"b;
			     end;
			end;
		     end;

		     if code = 0 then do;
			t.line (t.table_length).number = new_number;
			t.line (t.table_length).start = seg_index;
			if blank then t.line (t.table_length).num_chars = 0;
			else t.line (t.table_length).num_chars = len;
		     end;
		     last_num = new_number;
		end;
	     end;
	     if code ^= 0 then do;
		call dfast_error_ (code, "sort", substr (seg, seg_index, len));
		return;
	     end;
	     seg_index = seg_index + len;
	end;


	do i = 1 to t.table_length -1 while (^sorted);
	     sorted = "1"b;
	     do seg_index = 1 to t.table_length -i;
		if t.line (seg_index).number > t.line (seg_index+1).number then do;
		     sorted = "0"b;
		     temp_line = t.line (seg_index);
		     t.line (seg_index) = t.line (seg_index+1);
		     t.line (seg_index+1) = temp_line;
		end;

		else if t.line (seg_index).number = t.line (seg_index +1).number then t.line (seg_index).num_chars = 0;
	     end;
	end;

	return;

/*  */
/* This procedure is given a string of characters ending with a new_line character.
   It returns the line number of the line and if it is a blank line.  A blank line
   contains a line number followed by a new_line character.  If the line contains blanks or tabs it is
   not considered blank.
   If convert is 0 then code is set.
*/
get_number: proc (string, number, blank, code) returns (bit (1) unal);

dcl  string char (*);
dcl  number fixed bin;
dcl  blank bit (1) unal;				/* On if the line only contains a number */
dcl  code fixed bin (35);

dcl  fst_cv_line_num_ entry  (char (*), fixed bin, fixed bin (35)) returns (bit (1) unal);

dcl  i fixed bin (21);

	     i = verify (string, "0123456789");
	     if i = 1 then code = error_bad_line;
	     else do;
		if fst_cv_line_num_ (substr (string, 1, i-1), number, code) then do;
		     if substr (string, i, 1) = new_line then blank = "1"b;
		     else blank = "0"b;
		     return ("1"b);
		end;
	     end;

	     if convert then code = 0;
	     return ("0"b);

	end get_number;
     end dfast_get_table_;
  



		    fast_run_unit_manager_.pl1      01/19/88  1505.6rew 01/19/88  1500.1      275220


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


/****^  HISTORY COMMENTS:
  1) change(87-12-02,TLNguyen), approve(87-12-02,MCR7806),
     audit(87-12-10,Lippard), install(88-01-19,MR12.2-1015):
     - Fixed size condition raised when calculate the length of the allocated
       variable named dump in the set_up_run_unit internal procedure.
     - Remove based_bit75, i, index, link_ptr, original_linkp, and size
       from the source because they are referenced anywhere within it.
                                                   END HISTORY COMMENTS */


fast_run_unit_manager_: proc (program_ptr, program_lng, arg_flags, main_ename, a_code);

/* coded March 1976 by M. Weaver */
/* modified October 1976 by M. Weaver to use new get_definition_  calling  sequence */
/* modified December 1976 by M. Weaver to again look for main_ */
/* modified January 1977 to restore fortran_io_initiated */

dcl  program_ptr ptr;				/* ptr to main program for run unit */
dcl  program_lng fixed bin (24);			/* bit count of main program */
dcl 1 arg_flags aligned,
    2 just_compiled bit (1) unaligned,			/* ON if main prog compiled  by  run command */
    2 brief bit (1) unaligned,			/* ON if warning messages to be inhibited */
    2 probe bit (1) unaligned,			/* ON if program to be run under debugger  */
    2 mbz bit (33) unaligned;
dcl  main_ename char (32) varying;			/* name of main program */
dcl  a_code fixed bin (35);

/* pointers */
dcl  blank_common_ptr ptr;
dcl  seg_ptr ptr;
dcl  rp ptr;
dcl  definition_p ptr;
dcl  main_ptr ptr;
dcl  ftn_io_p ptr;
dcl  scratch_ptr (1) ptr static;
dcl  rnt_p ptr static;
dcl  clp ptr static;
dcl  segment_table_ptr ptr static;
dcl  static_lotp ptr static;
dcl  static_isotp ptr static;
dcl  eio_ptr ptr static;
dcl  entry_ptr ptr static;
dcl  saved_ftn_buffer_p ptr;
dcl  n_ptr ptr static;

/* fixed bin */
dcl  max_severity fixed bin;
dcl  i fixed bin;
dcl  blank_length fixed bin;
dcl  scratch_lng fixed bin (19);
dcl  code fixed bin (35);
dcl  dlng fixed bin;
dcl  ecount fixed bin static;
dcl  total_names fixed bin static;

/* bit strings */
dcl  terminating bit (1) aligned;
dcl  dir_empty bit (1) aligned static;
dcl  saved_fortran_io_initiated bit (1) aligned;

/* character strings */
dcl  language char (8) aligned static;
dcl  dirname char (168) static;
dcl  entname char (32);

/* area */
dcl  scratch_area area (255000) based (scratch_ptr (1));

/* external */
dcl (error_table_$not_done, error_table_$name_not_found) fixed bin (35) external;
dcl  fast_related_data_$fortran_io_initiated bit (1) aligned ext;
dcl  fast_related_data_$fortran_buffer_p ptr ext;
dcl  fast_related_data_$terminate_run entry variable ext;
dcl  fast_related_data_$basic_area_p ptr ext;

/* external entries  */

dcl  ioa_ entry options (variable);
dcl  hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl  cu_$gen_call entry (ptr, ptr);
dcl  fortran_io_$close_file entry (fixed bin, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*),
     fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  area_ entry (fixed bin (19), ptr);
dcl  decode_definition_$init entry (ptr, fixed bin (24));
dcl  decode_definition_ entry (ptr, ptr) returns (bit (1) aligned);
dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  get_definition_ entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  get_wdir_ entry () returns (char (168) aligned);
dcl  find_command_$clear entry ();

/* builtins and  conditions */

dcl (addr, addrel, baseno, baseptr, bit, bin, fixed, length, max) builtin;
dcl (null, ptr, rel, reverse, substr, verify) builtin;
dcl  cleanup condition;
dcl  fault_tag_3 condition;

/* structures */

dcl 1 ext_template aligned based,			/* holds link info */
    2 type fixed bin,				/* link type */
    2 section char (8) aligned,
    2 ename char (32) varying,			/* entry name of link target */
    2 init_info_p ptr;				/* ptr to init info for common */

dcl 1 dd aligned,					/* structure filled in by decode_definition_ */
    2 next_def ptr,					/* ptr to next definition in list */
    2 last_def ptr,					/* ptr to previous definition in list */
    2 block_ptr ptr,				/* ptr to either defblock or segname block */
    2 section char (4) aligned,			/* "text", "link", "symb" or "segn" */
    2 offset fixed bin,				/* offset within class (if ^= "segn") */
    2 entrypoint fixed bin,				/* value of entrypoint in text if ^= 0 */
    2 symbol char (32) aligned;			/* the symbolic name of the definition */


dcl 1 static_st (0:1) aligned static like st;		/* used before hcs_$star is called */

dcl 1 st (0:ecount+1) aligned based (segment_table_ptr),
    2 segno bit (18) unaligned,
    2 flags unaligned,
      3 links_snapped bit (1) unaligned,
      3 temp_lote bit (1) unaligned,
      3 wrong_language bit (1) unaligned,
      3 nonobject bit (1) unaligned,
      3 cant_initiate bit (1) unaligned,
      3 pad bit (13) unaligned,
    2 defptr ptr,
    2 ftn_ls_p ptr unaligned,
    2 ftn_symbol_p ptr unaligned,
    2 language char (8) aligned;

dcl 1 rnt_node aligned based (rp),
    2 entryp ptr,
    2 back_thread bit (18) unaligned,
    2 seg_table_offset fixed bin (17) unaligned,
    2 nchars fixed bin (17),
    2 name char (32) aligned;


dcl 1 oi aligned like object_info;

%include object_info;


%include linkdcl;


%include definition;


%include lot;


%include stack_header;


/* initialize variables */

	a_code = 0;
	scratch_ptr (1) = null;
	blank_common_ptr = null;
	ftn_io_p = null;
	rnt_p = null;
	clp = null;
	segment_table_ptr = addr (static_st);
	eio_ptr = null;
	entry_ptr = null;
	n_ptr = null;

	max_severity = 0;
	ecount = 0;
	static_st (0).segno, static_st (1).segno = "0"b;

	terminating = "0"b;
	dir_empty = "0"b;

/* get info about main program */

	oi.version_number = object_info_version_2;
	call object_info_$display (program_ptr, program_lng, addr (oi), code);
	if code ^= 0 then do;
	     call ioa_ ("Specified main program cannot be executed.");
	     a_code = code;
	     return;
	end;

/* initialize more stuff needed by cleanup handler */

	saved_ftn_buffer_p = fast_related_data_$fortran_buffer_p;
	saved_fortran_io_initiated = fast_related_data_$fortran_io_initiated;
						/* will restore for debugging purposes */
	fast_related_data_$fortran_io_initiated = "0"b;
	fast_related_data_$terminate_run = terminate_run_entry;

	sb = ptr (addr (rp), 0);			/* get ptr to stack header */
	static_lotp = sb -> stack_header.lot_ptr;
	static_isotp = sb -> stack_header.isot_ptr;

	on cleanup call Clean_up;

/* obtain scratch area if necessary */

	if (oi.compiler = "basic") | (oi.compiler = "fortran2") then do;
	     language = oi.compiler;
	     call get_temp_segments_ ("fast_run_unit_manager_", scratch_ptr, code);
	     call hcs_$get_max_length_seg (scratch_ptr (1), scratch_lng, code);
	     call area_ (scratch_lng, scratch_ptr (1));
	end;
	else language = "other";			/* all linking done by standard system */


/* set up run unit */

	dirname = get_wdir_ ();
	call set_up_run_unit;

	if max_severity > 2 then do;
incomplete_set_up:
	     a_code = error_table_$not_done;
	     call Clean_up;
	     return;
	end;

	if main_ptr = null then do;
	     call ioa_ ("Could not find main entry point.");
	     goto incomplete_set_up;
	end;

	on fault_tag_3 call fault_tag_3_handler;

	call cu_$gen_call (main_ptr, null);
terminate:
	call Clean_up;
	return;					/* end of main program */


Clean_up:	proc;

	     if scratch_ptr (1) ^= null then do;
		call terminate_run_unit;
		call release_temp_segments_ ("fast_run_unit_manager_", scratch_ptr, code);
	     end;
	     call find_command_$clear;	/* have cleared LOT entries; make cp use hcs_$make_ptr */

/* reset fast_related_data_ pointers in case basic or fortran
   programs are called by a pl1 program in another run unit or are run outside of FAST. */

	     fast_related_data_$fortran_buffer_p = saved_ftn_buffer_p;
	     fast_related_data_$fortran_io_initiated = saved_fortran_io_initiated;
	     fast_related_data_$basic_area_p = null;

	     return;


terminate_run_unit: proc;

/* This code is a separate procedure to facilitate error loop checking */

dcl  m fixed bin (18);

		if terminating then return;		/* don't risk loop */
		terminating = "1"b;

/* terminate all segments and clean up LOT and ISOT;
   If language = "other", no st entries are filled in */

		do i = 0 to ecount + 1;
		     if st (i).segno then do;
			if st (i).flags.temp_lote then do;
			     m = fixed (st (i).segno, 18);
			     static_lotp -> lot.lp (m) = baseptr (0);
			     static_isotp -> lot.lp (m) = baseptr (0);
			end;
			if i > 0 then		/* caller initiated main program */
			     call hcs_$terminate_noname (baseptr (st (i).segno), code);
		     end;
		end;

		if language = "fortran2" then if ftn_io_p ^= null
		     then call fortran_io_$close_file (-1, code);

		terminating = "0"b;

		return;
	     end;					/* of terminate_run_unit */

	end;					/* of Clean_up */

set_up_run_unit: proc;

/* This procedure gets a pointer to the main entry point, prelinks all fortran programs
   in  the run unit, alllocates blank common and sets the pointers in fast_related_data_. */

dcl  dummy_length fixed bin (19);
dcl  bit18_based bit (18) unaligned based;
dcl  dummy_ptr ptr;
dcl  main_dir char (168);
dcl  dummy (dummy_length) fixed bin (35) based;
dcl  blank_common (blank_length) fixed bin (35) based (blank_common_ptr);
dcl  main_ename_c32 char (32);


	     main_ptr = null;
	     main_ename_c32 = main_ename;		/* need nonvarying string */

	     if language = "other" then do;		/* won't need RNT or anything
						   else in scratch seg */
		call hcs_$fs_get_path_name (program_ptr, main_dir, dlng, entname, code);
						/*  get pathname of main program */
		if code ^= 0 then do;
other_not_found:
		     call error (3, "Could not find main program.", " ");
		     return;
		end;
		call hcs_$initiate (main_dir, entname, main_ename_c32, 0, 1, seg_ptr, code);
						/* associate reference name with main prog */
		if seg_ptr = null then goto other_not_found;
		call hcs_$make_ptr (null, main_ename_c32, main_ename_c32, main_ptr, code);
		if main_ptr = null
		then call hcs_$make_ptr (null, main_ename_c32, "main_", main_ptr, code);
		return;
	     end;

	     st (0).defptr = oi.defp;
	     st (0).segno = baseno (program_ptr);
	     st (0).language = language;
	     addr (st (0).flags) -> bit18_based = "0"b;	/* array still in  stack at this point */

	     if arg_flags.just_compiled then do;
		call process_just_compiled_entries;
		if main_ptr = null then return;
		call allocate_linkage ("1"b, 0);
	     end;

	     else do;
		call get_definition_ (oi.defp, main_ename_c32, main_ename_c32, definition_p, code);
		if definition_p = null then do;	/* look for main_ */
		     call get_definition_ (oi.defp, main_ename_c32, "main_", definition_p, code);
		     if definition_p = null then return;
		     if definition_p -> definition.class then return; /* entry must be in text */
		end;

		main_ptr = addrel (oi.textp, definition_p -> definition.value);
		call add_to_rnt (main_ename_c32, main_ptr, 0);
		call allocate_linkage ("0"b, 0);
	     end;

	     if language = "basic" then fast_related_data_$basic_area_p = scratch_ptr (1);
						/* use scratch seg  area */
	     else do;				/* main program is fortran; ppelink */
		blank_length = 0;
		call snap_ftn_links (0);		/* recursive; when it returns all is  prelinked */
		if max_severity > 2 then return;
		if blank_length > 0
		then allocate blank_common in (scratch_area) set (blank_common_ptr);

/*  The rest of scratch segment will be used for fortran I/O.  We must calculate the
   size and allocate  it to get a good pointer;  In order to find out where we
   are now, a dummy variable will be allocated. */

		dummy_length = 1;
		allocate dummy in (scratch_area) set (dummy_ptr);
		dummy_length = scratch_lng - bin (rel (dummy_ptr), 18) - 20;
						/* alllow room for  area header, etc. */
		allocate dummy in (scratch_area) set (fast_related_data_$fortran_buffer_p);
		ftn_io_p = fast_related_data_$fortran_buffer_p;
	     end;

	     return;

	end;					/* set_up_run_unit */


snap_ftn_links: proc (st_offset_2);

/* This procedure  snaps all links in fortran programs.   It is called
   recursively; for example, if while snapping program a's links a
   link  is snapped to program b, and  none of  program b's links have
   been snapped yet, snap_ftn_links is called to snap b's links before
   proceeding further with program a's links. */

dcl 1 common_list_node aligned based (cl_node_ptr),
    2 back_thread bit (18) unaligned,
    2 block_lng fixed bin (17) unaligned,
    2 name char (32) aligned,
    2 block_p ptr unaligned;

dcl (link_ptr, lp, ep, cl_node_ptr, common_p) ptr;
dcl (dl_code, st_offset_2, target_st_offset, j) fixed bin;
dcl  last_rel bit (18) aligned;
dcl  FT3 bit (6) aligned init ("100111"b);
dcl  based_ptr ptr based;

dcl  init_template (j) bit (36) aligned based;

dcl 1 ext aligned like ext_template;

dcl 1 init_info aligned based,
    2 lng fixed bin,
    2 icode fixed bin,
    2 template (0 refer (init_info.lng)) bit (36) aligned;


	     st (st_offset_2).flags.links_snapped = "1"b; /* so won't get called  again for this program */
	     lp = st (st_offset_2).ftn_ls_p;		/* get   ptr to active linkage section */
	     last_rel = rel (addrel (lp, bin (lp -> header.stats.block_length, 18)));
						/* get offset of end of linkage section for optimization */

	     do link_ptr = addrel (lp, lp -> header.stats.begin_links) repeat (addrel (link_ptr, 2))
		     while (rel (link_ptr) < last_rel);
		call decode_ftn_link (link_ptr, addr (ext), "1"b, dl_code);
		if dl_code ^= 0 then do;
		     if dl_code ^= 1 then link_ptr -> link.ft2 = FT3;
						/*   get fault tag 3 if reference */
		end;
		else if (ext.type = 5) & (ext.section = "*system") then do; /* common */
		     if ext.ename = "blnk*com" then do; /* blank common */
			blank_length = max (blank_length, ext.init_info_p -> init_info.lng);
			link_ptr -> based_ptr = addr (blank_common_ptr);
						/* snap link indirect thru blank_common_ptr */
			link_ptr -> link.modifier = "010000"b; /* make  pointer indirect */
		     end;

		     else do;			/* labelled common */
			call find_common_block;
			if code = 0 then link_ptr -> based_ptr = common_p; /*  snap link */
		     end;
		end;

		else if (ext.type = 1) & (ext.section = "*sybmol")
		then link_ptr -> based_ptr = st (st_offset_2).ftn_symbol_p;

		else do;				/* ordinary link */
		     call find_entry ((ext.ename), ep, target_st_offset);
		     if ep = null then link_ptr -> link.ft2 = FT3; /* message already printed  */
		     else do;			/* found entry */
			link_ptr -> based_ptr = ep;	/* snap link */
			if ^st (target_st_offset).flags.links_snapped
			then if st (target_st_offset).ftn_ls_p ^= null
			     then call snap_ftn_links (target_st_offset);
		     end;
		end;
	     end;

	     return;


find_common_block: proc;

		code = 0;
		if clp ^= null
		then do cl_node_ptr = clp repeat (ptr (cl_node_ptr, cl_node_ptr -> common_list_node.back_thread))
			while (rel (cl_node_ptr));

		     if rel (cl_node_ptr) then do;
			if ext.ename = common_list_node.name then do; /* found match */
			     if common_list_node.block_lng = ext.init_info_p -> init_info.lng then do;
				common_p = common_list_node.block_p; /* use allocated block */
				if ext.init_info_p -> init_info.icode = 3
				then do;		/* but initialize now */
				     j = ext.init_info_p -> init_info.lng;
				     common_p -> init_template = ext.init_info_p -> init_info.template;
				end;
			     end;
			     else do;
				call error (3, "Different lengths specified  for common block ^a",
				     substr (ext.ename, 1, length (ext.ename)));
				code = 1;
			     end;
			     return;
			end;
		     end;
		end;

/* no match; allocate new node and new block in scratch seg */

		cl_node_ptr = clp;
		allocate common_list_node in (scratch_area) set (clp);
		if cl_node_ptr = null then clp -> common_list_node.back_thread = "0"b;
		else clp -> common_list_node.back_thread = rel (cl_node_ptr);
		clp -> common_list_node.name = ext.ename;
		j, clp -> common_list_node.block_lng = ext.init_info_p -> init_info.lng;
		allocate init_template in (scratch_area) set (common_p);
		clp -> common_list_node.block_p = common_p;
		if ext.init_info_p -> init_info.icode = 3
		then common_p -> init_template = ext.init_info_p -> init_info.template;

		return;
	     end;					/* find_common_block */


	end;					/* snap_ftn_links */

decode_ftn_link: proc (linkp, extp, linking, dcode);

/* This procedure returns  information about legal fortran links only.
   Do not distinguish types of errors except for missing fault tag 2. */
/* This is outside set_up_run_unit_  so fault tag 3 handler can ca
   l it */

dcl (linkp, extp) ptr;
dcl  linking bit (1) aligned;
dcl  dcode fixed bin;

dcl (head_pointer, def_pointer, exp_pointer, type_pointer, ext_pointer) ptr;
dcl (ntype, section_id) fixed bin (18);
dcl  name_length fixed bin;

dcl 1 ext aligned based,				/* holds link info */
    2 type fixed bin,				/* link type */
    2 section char (8) aligned,
    2 ename,
      3 nchars fixed bin,
      3 string char (32),
    2 init_info_p ptr;				/* ptr  to init info for  common */

	     dcode = 1;
	     if linking then if linkp -> link.ft2 ^= "100110"b then return;
						/* must have fault tag 2 */
	     dcode = 2;

	     head_pointer = addrel (linkp, linkp -> link.head_ptr);
	     def_pointer = head_pointer -> header.def_ptr;
	     exp_pointer = addrel (def_pointer, linkp -> link.exp_ptr);
	     if exp_pointer -> exp_word.exp then return;	/* must have 0 expression */

	     type_pointer = addrel (def_pointer, exp_pointer -> exp_word.type_ptr);
	     ext_pointer = addrel (def_pointer, type_pointer -> type_pair.ext_ptr);
	     section_id = bin (type_pointer -> type_pair.seg_ptr, 18);

	     extp -> ext.type, ntype = bin (type_pointer -> type_pair.type, 18);

	     if (ntype = 4) | (ntype = 5) then do;
		name_length = bin (ext_pointer -> name.nchars, 9);
		if name_length > 32 then return;	/* name too long */
		extp -> ext.ename.nchars = name_length;
		substr (extp -> ext.ename.string, 1, name_length)
		     = substr (ext_pointer -> name.char_string, 1, name_length);

		if ntype = 4 then do;
		     if type_pointer -> type_pair.seg_ptr ^= type_pointer -> type_pair.ext_ptr then return;
						/* don't  allow $ names in DFAST  */
		     extp -> ext.section = " ";
		     extp -> ext.init_info_p = null;
		end;
		else do;				/* ntype = 5 */
		     if section_id ^= 5 /* *system */ then return;
		     extp -> ext.section = "*system";
		     if type_pointer -> type_pair.trap_ptr = "0"b then return;
						/* must have init info */
		     extp -> ext.init_info_p = addrel (def_pointer, type_pointer -> type_pair.trap_ptr);
		end;
	     end;

	     else if ntype = 1 then do;
		if section_id ^= 2 then return;	/* must be *symbol|0 */
		extp -> ext.section = "*symbol";
		extp -> ext.ename.nchars = 0;
		extp -> ext.init_info_p = null;
	     end;

	     else return;				/*  not a legal fortran type */

	     dcode = 0;
	     return;

	end;					/* decode_ftn_link */

find_entry: proc (ename, ep, st_offset_3);

/* This procedure returns a pointer to the entrypoint  corresponding to ename.
   If there is anything  wrong with  the segment that ename refers to,   the ep
   returned is null and the caller should not do anything more with that name.
   In this case, find_entry prints a error  message the first
   time that ename is referenced.
   find_entry first searches the RNT;  if the name is not foune there, the working directory
   is searched (via output from hcs_$star_).  If the segment  was not previously
   referenced by a different name, it is initiated and the segment's st entry is
   filled in.  To  simplify  error handling, the rnt  node is  filled in
   with a null entry pointer until  the real entry pointer is found. */

dcl  ename char (32);
dcl  ep ptr;
dcl  st_offset_3 fixed bin;
dcl (i, j, k, ename_length) fixed bin;
dcl  seg_bc fixed bin (24);

dcl 1 entries (ecount) aligned based (entry_ptr),
    (2 type bit (2),
    2 nnames fixed bin (15),
    2 nindex fixed bin (17)) unaligned;

dcl  e_info_offset (total_names) fixed bin based (eio_ptr);

dcl  names (total_names) char (32) aligned based (n_ptr);


	     ep = null;
	     st_offset_3 = 0;
	     ename_length = 33 - verify (reverse (ename), " ");

/* search RNT for ename */

	     if rnt_p ^= null
	     then do rp = rnt_p repeat (ptr (rp, rp -> rnt_node.back_thread))
		     while (rp -> rnt_node.back_thread);
		if ename_length = rnt_node.nchars
		then if ename = rnt_node.name then do;	/* found match */
			ep = rnt_node.entryp;
			st_offset_3 = rnt_node.seg_table_offset;
			return;
		     end;
	     end;

	     if dir_empty then return;		/* can't do any more */

	     if ecount = 0 then do;			/* get   contents of working dir */
		call hcs_$star_ (dirname, "**", 3, scratch_ptr (1), ecount, entry_ptr, n_ptr, code);
		if code ^= 0 then do;
		     dir_empty = "1"b;
		     call error (3, "Home directory is empty. Referenced programs cannot be found.", " ");
		     return;
		end;
		allocate st in (scratch_area) set (segment_table_ptr);
		st (0) = static_st (0);		/* copy maiin program's entry */
		total_names = 0;
		do i = 1 to ecount;			/* find number of names returned */
		     total_names = total_names + entries (i).nnames;
		end;

/*  fill in array relating  names with the appropriate entry  info. */

		allocate e_info_offset in (scratch_area) set (eio_ptr);
		k = 0;
		do i = 1 to ecount;
		     do j = 1 to entries (i).nnames;
			k = k + 1;
			e_info_offset (k) = i;
		     end;
		end;
	     end;

	     do i = 1 to total_names while (ename ^= names (i)); end;

	     if i = total_names + 1 then do;
		st_offset_3 = ecount + 1;		/* dummy entry  for names not found */
		call add_to_rnt (ename, null, st_offset_3);
		call error (2, "Referenced segment ^a cannot be found.", ename);
		return;
	     end;

	     k, st_offset_3 = e_info_offset (i);
	     call add_to_rnt (ename, null, st_offset_3);

	     if entries (k).type = "10"b then do;
		st (k).flags.nonobject = "1"b;
		call error (2, "Illegal reference to directory ^a.", ename);
		return;
	     end;

	     if st (k).flags.cant_initiate then goto bad_access;

	     if st (k).segno = "0"b then do;
		call hcs_$initiate_count (dirname, ename, "", seg_bc, 1, seg_ptr, code);
		if seg_ptr = null then do;
		     st (k).flags.cant_initiate = "1"b;
bad_access:	     call error (2, "Insufficient access to ^a.", ename);
		     return;
		end;

		if (^arg_flags.just_compiled) & (baseno (seg_ptr) = st (0).segno) then st (k) = st (0);
		else do;				/*  collect info about seg */
		     st (k).segno = baseno (seg_ptr);
		     oi.version_number = object_info_version_2;
		     call object_info_$display (seg_ptr, seg_bc, addr (oi), code);
		     if code ^= 0 then do;
			st (k).flags.nonobject = "1"b;
bad_object:		call error (2, "^a cannot be called because it is not a program.", ename);
			return;
		     end;

		     st (k).defptr = oi.defp;
		     if (oi.compiler = "fortran2") | (oi.compiler = "basic") then do;
			st (k).language = oi.compiler;
			if oi.compiler ^= language then do;
			     st (k).flags.wrong_language = "1"b;
wrong_lang:		     call error (2, "Subprogram ^a  is in an  incompatible language.", ename);
			     return;
			end;
			call allocate_linkage ("0"b, st_offset_3);
		     end;
		     else do;
			st (k).language = "other";
			st (k).ftn_ls_p, st (k).ftn_symbol_p = null;
		     end;
		end;
	     end;					/* done filling in info about new seg */

	     else do;				/*  check flags of known seg */
						/* different name,  so print message agaiin */
		if st (k).flags.wrong_language then goto wrong_lang;
		if st (k).flags.nonobject then goto bad_object;
	     end;

/* finally get the  pointer to the entrypoint */

	     if st (k).language = "other" then call hcs_$make_ptr (seg_ptr, ename, ename, ep, code);
	     else do;
		call get_definition_ (st (k).defptr, ename, ename, definition_p, code);
		if definition_p ^= null
		then if definition_p -> definition.class = "0"b
		     then ep = addrel (seg_ptr, definition_p -> definition.value);
	     end;

	     if ep = null then call error (2, "Cannot find subprogram ^a in segment.", ename);
	     rnt_p -> rnt_node.entryp = ep;		/* fill in final value of entry pointer */

	     return;
	end;					/* of find_entry */


allocate_linkage: proc (temp_object, st_offset_4);

/* This procedure  is called only for fortran and basic programs.  For these we always
   allocate linkage and fill in the LOT entry. */

dcl  temp_object bit (1) aligned;
dcl  st_offset_4 fixed bin;
dcl (k, link_lng) fixed bin;
dcl  linkage_section_p ptr;
dcl  linkage_section (link_lng) fixed bin (35) based;


	     st (st_offset_4).flags.temp_lote = "1"b;	/* so terminate will zap LOT entry */
	     if temp_object then linkage_section_p = oi.linkp; /* use linkage section in  place */
	     else do;				/*  copy into scratch seg */
		link_lng = oi.llng;
		allocate linkage_section in (scratch_area) set (linkage_section_p);
		linkage_section_p -> linkage_section = oi.linkp -> linkage_section;
	     end;

	     if st (st_offset_4).language = "fortran2" then do;
		st (st_offset_4).ftn_ls_p = linkage_section_p;
		st (st_offset_4).ftn_symbol_p = oi.symbp;
	     end;

	     else st (st_offset_4).ftn_ls_p, st (st_offset_4).ftn_symbol_p = null;

/*  fill in LOT, ISOT */

	     k = bin (baseno (oi.textp), 18);
	     static_lotp -> lot.lp (k),
		static_isotp -> lot.lp (k) = linkage_section_p;

/* fill in linkage  section header */

	     linkage_section_p -> header.def_ptr = oi.defp;
	     linkage_section_p -> header.symbol_ptr = oi.symbp;
	     linkage_section_p -> header.original_linkage_ptr = oi.linkp;
	     linkage_section_p -> header.stats.segment_number = bit (k, 18);
	     linkage_section_p -> header.stats.static_length = bit (bin (oi.ilng, 18), 18);

	     return;

	end;					/* of allocate_linkage */


add_to_rnt: proc (ename, ep, st_offset_5);

/* This procedure  simply adds a node to the RNT; searching is done in find_entry. */

dcl  ename char (32);
dcl  ep ptr;
dcl  st_offset_5 fixed bin;


	     rp = rnt_p;
	     allocate rnt_node in (scratch_area) set (rnt_p);

	     rnt_p -> rnt_node.entryp = ep;
	     rnt_p -> rnt_node.name = ename;
	     rnt_p -> rnt_node.nchars = 33 - verify (reverse (ename), " ");
	     rnt_p -> rnt_node.seg_table_offset = st_offset_5;

	     if rp = null then rnt_p -> rnt_node.back_thread = "0"b; /* first node */
	     else rnt_p -> rnt_node.back_thread = rel (rp);

	     return;
	end;					/*  of add_to_rnt */


process_just_compiled_entries: proc;

/*  This procedure adds the names of all the entrypoints in a just compiled
   program to the RNT. */

dcl  defptr ptr;

	     main_ptr = null;
	     call decode_definition_$init (program_ptr, program_lng);

	     do defptr = oi.defp repeat (dd.next_def) while (^decode_definition_ (defptr, addr (dd)));
		if dd.section = "text" then do;
		     if dd.symbol = "main_" then main_ptr = addrel (oi.textp, dd.offset);
		     else call add_to_rnt ((dd.symbol), addrel (oi.textp, dd.offset), 0);
		end;
	     end;

	     return;

	end;					/* of process_just_compiled entries  */

find_entry_value: entry (a_entname, a_ep, ecode);

/* This entry is called by basic_find_proc_.
   Because it is an external entry, the procedures it calls must use
   static pointers and counts. */

dcl  a_entname char (32);
dcl  a_ep ptr;
dcl  ecode fixed bin (35);
dcl  st_offset_5 fixed bin;

	call find_entry (a_entname, a_ep, st_offset_5);
	if a_ep = null then ecode = error_table_$name_not_found;
	else ecode = 0;
	return;


terminate_run_entry: proc;

/* This procedure is called by fortran stop */

	     goto terminate;

	end;					/* of terminate_run_entry */


error:	proc (severity, control_string, arg_string);

dcl  severity fixed bin;
dcl (control_string, arg_string) char (*);
dcl  new_control_string char (200) varying;

	     max_severity = max (max_severity, severity);
	     if severity <= 2 then do;		/* warning only */
		if arg_flags.brief then return;	/* don't print any message */
		new_control_string = "Warning: " || control_string;
	     end;
	     else new_control_string = control_string;
	     call ioa_ (new_control_string, arg_string);

	     return;
	end;					/* error */

fault_tag_3_handler: proc;

/* fortran links which could not be snapped are converted to fault tag 3's */

dcl  link_ptr ptr;
dcl  dl_code fixed bin;
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  continue_to_signal_ entry (fixed bin (35));

dcl 1 ext aligned like ext_template;

dcl 1 cond_info aligned,
%include cond_info;

%include mc;

     cond_info.version = 1;
	     call find_condition_info_ (null, addr (cond_info), code);
	     if code ^= 0 then goto continue_ft3;

	     scup = addr (cond_info.mcptr -> mc.scu (0));
	     link_ptr = ptr (baseptr (fixed (fixed (scup -> scu.tpr.tsr, 15), 18)), scup -> scu.ca);

	     call decode_ftn_link (link_ptr, addr (ext), "0"b, dl_code);
	     if dl_code = 0 then call ioa_ ("Attempt to reference missing subprogram ^a.^/Program aborted.",
		ext.ename);
	     else if dl_code = 2 then call ioa_ (
		"Attempt to reference through invalid link.^/FORTRAN compiler error. Program aborted.");
	     else do;				/* at this writing no other codes are returned, but... */
continue_ft3:	call continue_to_signal_ (code);
		return;
	     end;

	     goto terminate;

	end;					/* fault_tag_3_handler */
     end;



		    fst_command_processor_.pl1      01/19/88  1505.6rew 01/19/88  1500.7       76428


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


/****^  HISTORY COMMENTS:
  1) change(87-12-03,TLNguyen), approve(87-12-03,MCR7806),
     audit(87-12-10,Lippard), install(88-01-19,MR12.2-1015):
     - Replace the "changes will be lost if you continue.  Do you want to
       continue?" queried message with "Changes will be lost if you quit.
       Do you want to quit?".
     - Remove the mod from the source because it is not referenced anywhere
       within the source.
                                                   END HISTORY COMMENTS */


fst_command_processor_: proc (arg_line, edit_changes);

/* * This procedure parses the user's command line.  If it finds a commmand it recognizes, it builds a descriptor
   * list and calls the command.  The input line is assumed to be non-blank.
   * Arguments are separated by blanks or tabs and there is a maximum of ten arguments allowed.
   *
   *	edm	on quit the user is queried, if he wants to continue, pi is signaled.
   *	logout	if editing changes will be lost, the user is queried.
   *
   * Written 3/76 by S.E. Barr
   */
/* Fixed to find commands each time rather than assume their existence 12/12/79 S. Herbst */
/* Add use_ep_basic and use_sp_basic commands. 10/25/83 C Spitzer */

/* parameters */

dcl  arg_line char (*);				/* user's command line */
dcl  edit_changes bit (1) unal;			/* edit changes since last save */

/* automatic */
dcl (start, num_chars) fixed bin;			/* start and number of characters in argument */
dcl  name char (32);				/* command name */
dcl  line_length fixed bin;				/* number of characters in line  */
dcl  i fixed bin;
dcl  command_index fixed bin;				/* index to procedure ptr */
dcl  arg_length (max_num_args) fixed bin;		/* temporarily holds argument lengths */
dcl 1 descriptors (max_num_args) aligned based (addr (al.pointers (num_args + 1))),
    2 desc_pointers bit (18) unal,
    2 pad_pointers bit (18) unal,
    2 flag bit (1) unal,
    2 type bit (6) unal,
    2 packed bit (1) unal,
    2 ndims bit (4) unal,
    2 size bit (24) unal;
dcl 1 al aligned,
    2 dum_ptr ptr,
    2 num_args fixed bin (16) unaligned,
    2 tag bit (19) initial ("0000000000000000100"b) unaligned,
    2 ndescs fixed bin (16) unaligned,
    2 pad bit (19) unaligned,
    2 pointers (20) ptr;
dcl (addr, bin, bit, hbound, length, null, rel, search, substr, unspec, verify) builtin;
dcl  line char (256);
dcl  answer char (3) var;				/* 'yes' or 'no' for queries */
dcl 1 query_info aligned,
    2 version fixed bin init (2),
    2 yes_or_no_sw bit (1) unal init ("1"b),		/* must be yes or no */
    2 suppress_name_sw bit (1) unal init ("1"b),		/* don't print name */
    2 code fixed bin (35) init (0),
    2 query_code fixed bin (35) init (0);

dcl  quit condition;

/* internal static */

dcl  max_num_args fixed bin int static options (constant) init (10);
dcl  white_space char (2) int static options (constant) init ("	 "); /* TAB BLANK */

/* based */

dcl  proc_ptr ptr based (addr (entry_value));

/* external */

dcl  command_names (50) char (20) int static options (constant) init (
     "add_line_numbers", "aln",
     "add_name", "an",
     "basic", "",
     "copy", "cp",
     "delete", "dl",
     "delete_acl", "da",
     "delete_line_numbers", "dln",
     "delete_name", "dn",
     "dprint", "dp",
     "edm", "edm",
     "fortran", "ft",
     "help", "",
     "how_many_users", "hmu",
     "link", "lk",
     "list", "ls",
     "list_acl", "la",
     "logout", "logout",
     "rename", "rn",
     "set_acl", "sa",
     "set_tty", "stty",
     "truncate", "tc",
     "use_ep_basic", "",
     "use_sp_basic", "",
     "convert_numeric_file", "",
     "unlink", "ul");

dcl  cu_$gen_call entry (ptr, ptr);
dcl  command_query_ entry options (variable);
dcl  cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);
dcl  ioa_$ioa_switch entry options (variable);
dcl  iox_$user_output ext ptr;

dcl  entry_value entry variable options (variable);

/* */
	start = 1;
	line = arg_line;				/* setup for get_arg  */
	line_length = length (arg_line);
	command_index = 0;

	if get_arg () then do;
	     name = substr (line, start, num_chars);
	     start = start + num_chars;
	     unspec (al) = "0"b;
	     do command_index = hbound (command_names, 1) by -1 to 1
		while (command_names (command_index) ^= name); end;

	     if command_index > 0 then do;
		num_args = 0;

		do while (get_arg ());
		     if num_args < max_num_args then do;
			num_args = num_args + 1;
			al.pointers (num_args) = addr (substr (line, start, 1));
			arg_length (num_args) = num_chars;
			start = start + num_chars;
		     end;
		     else call abort ("maximum of 10 arguments was exceeded", substr (line, start, num_chars));
		end;
		al.tag = "0000000000000000100"b;
		al.ndescs = num_args;

		do i = 1 to num_args;
		     desc_pointers (i) = rel (addr (descriptors (i).flag));
		     descriptors (i).flag = "1"b;
		     descriptors (i).size = bit (bin (arg_length (i), 24));
		     descriptors (i).type = bit (bin (21, 6));
		     descriptors (i).packed = "1"b;
		end;

		if name = "edm" then on quit call edm_query;
		else if name = "logout" then call logout_query; /* check if editing will be lost */
		else if name = "help" then name = "fst_help_";
		else if name = "basic" then name = "fst_compile_$basic";
		else if name = "fortran" | name = "ft" then name = "fst_compile_$fortran";
		else if name = "use_ep_basic" then name = "fst_compile_$ep_basic";
		else if name = "use_sp_basic" then name = "fst_compile_$sp_basic";

		entry_value = cv_entry_ (name, null, code);
		if code ^= 0 then do;
		     call ioa_$ioa_switch (iox_$user_output,
			"fast:  ^a not an object segment.", name);
		     go to RETURN;
		end;

		call cu_$gen_call (proc_ptr, addr (al.num_args));
	     end;
	     else call abort ("unrecognized command", name);
	end;
RETURN:
	return;

/*  */
/* * This procedure gets the index of the next argument on the line.   It uses global variables:
   *
   *	line		user's command line
   *	start		(input) index to begin search
   *			(output) index of start of argument
   *	num_chars		(output) length of argument
   *
   *	"1"b		the argument was found
   *	"0"b		no arguments remain on the line
*/
get_arg:	proc () returns (bit (1));

dcl  i fixed bin;

	     if start <= line_length then do;
		i = verify (substr (line, start, line_length - start + 1), white_space);
		if i > 0 then do;
		     start = start + i -1;
		     num_chars = search (substr (line, start, line_length - start + 1), white_space) -1;
		     if num_chars = -1 then num_chars = line_length - start + 1;
		     return ("1"b);
		end;
	     end;

	     return ("0"b);

	end get_arg;


/* This procedure prints an error message and then returns from fst_command_processor_ */
abort:	proc (err_message, add_info);

dcl  err_message char (*);
dcl  add_info char (*);

	     call ioa_$ioa_switch (iox_$user_output, "fast:  ^a  ^a", err_message, add_info);

	     goto RETURN;

	end abort;

/*  */
/*  This procedure is called when the user has quit out of edm.  If he wants to continue editing, program
   interrupt is signaled.  Otherwise a non-local goto is made to return to command level.
*/
edm_query: proc;

dcl  program_interrupt condition;

	     call ioa_$ioa_switch (iox_$user_output, "QUIT");
	     call command_query_ (addr (query_info), answer, "edm", "Do you want to continue editing ?");
	     if answer = "yes" then signal program_interrupt;
	     else goto RETURN;

	end edm_query;

/*  This procedure is called when the user types logout.  If there is temporary text that has been modified
   since the last save, the user will be queried.  If he types 'yes' logout will be called.  If he types 'no'
   the process will return to command level.
*/
logout_query: proc;

	     if edit_changes then do;
		call command_query_ (addr (query_info), answer, "fast",
		     "Changes will be lost if you quit.  Do you want to quit ?");
		if answer = "no" then goto RETURN;
	     end;

	     return;

	end logout_query;

     end fst_command_processor_;



		    fst_compile_.pl1                08/06/87  1147.7r w 08/06/87  1047.1       70506


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

fst_compile_: proc;

/* This procedure contains two entry points to compile source programs.
   The source program must have the proper language suffix and the object segment is creatted in the working directory.

   basic	path	no options
   fortran  path  [-no_line_numbers]

   Written 3/76 by S.E. Barr
   Modified 12/76 by M. Weaver to use version 2 compiler_source_info
   Modified 02/80 by C R Davis to move fast_mask to include file.
   Modified 1 Nov 1983 by C Spitzer: add ep_basic and sp_basic entry points.
*/

/* automatic */

dcl  acl_info_ptr ptr;
dcl  arg_length fixed bin;
dcl  arg_ptr ptr;
dcl  code fixed bin (35);
dcl  i fixed bin;
dcl  nargs fixed bin;
dcl  object_length fixed bin;
dcl  object_ptr ptr;
dcl  path char (168) var;
dcl  proc_name char (7);				/* basic or fortran */
dcl 1 fort_opt aligned like fortran_options;
dcl 1 s aligned like compiler_source_info;
dcl  source_ptr ptr;				/* ptr to source segment */

/* based */

dcl  arg char (arg_length) based (arg_ptr);

dcl (addr, divide, fixed, length, null, reverse, substr, unspec, verify) builtin;

dcl  cleanup condition;

/* constant */

dcl  RE_ACCESS bit (36) aligned internal static options (constant) initial ("1100"b);

/* external  */

dcl  basic_$compile entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  basic_$precision_length ext fixed bin;
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  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$noarg fixed bin (35) ext;
dcl  error_table_$wrong_no_of_args fixed bin (35) ext;
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  fort_$compile entry (ptr, ptr, fixed bin, ptr, fixed bin (35));
dcl  get_wdir_ entry () returns (char (168));
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  tssi_$clean_up_segment entry (ptr);
dcl  tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
dcl  tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35));

/*  */
%include branch_status;
%include  compiler_source_info;
%include fort_options;

/*  */
basic:	entry;

	proc_name = "basic";
	call cu_$arg_count (nargs);
	if nargs = 1 then do;
	     call cu_$arg_ptr (1, arg_ptr, arg_length, code);
	     if code = 0 then do;

		source_ptr = null;
		if set_up (arg, ".basic") then do;

		     on cleanup call cleanup_handler;

		     call basic_$compile (addr (s), object_ptr, object_length, code);
		     if code ^= 0 then do;
			object_length = 0;
			call com_err_ (code, "basic");
		     end;
		     call tssi_$finish_segment (object_ptr, object_length*36, RE_ACCESS, acl_info_ptr, code);
		end;
		if source_ptr ^= null then call hcs_$terminate_noname (source_ptr, code);
	     end;
	     else call com_err_ (code, "basic");
	end;
	else call com_err_ (error_table_$wrong_no_of_args, "basic");

	return;

fortran: ft: entry;

	proc_name = "fortran";
	code = 0;
	call cu_$arg_count (nargs);
	if nargs > 0 then do;
	     path = "";
	     unspec (fort_opt) = fast_mask;
	     do i = 1 to nargs while (code = 0);
		call cu_$arg_ptr (i, arg_ptr, arg_length, code);
		if code = 0 then do;
		     if substr (arg, 1, 1) = "-" then do;
			if arg = "-nln" | arg = "-no_line_numbers" then fort_opt.has_line_numbers = "0"b;
			else code = error_table_$badopt;
		     end;
		     else if path = "" then path = arg;
		     else code = error_table_$badopt;
		end;
	     end;

	     if code = 0 then do;

		if path ^= "" then do;
		     source_ptr = null;
		     if set_up ((path), ".fortran") then do;
			on cleanup call cleanup_handler;

			call fort_$compile (addr (s), object_ptr, object_length, addr (fort_opt), code);
			if code ^= 0 then do;
			     object_length = 0;
			     call com_err_ (code, "fortran");
			end;
			call tssi_$finish_segment (object_ptr, object_length*36, RE_ACCESS, acl_info_ptr, code);
		     end;
		     if source_ptr ^= null then call hcs_$terminate_noname (source_ptr, code);
		end;
		else call com_err_ (error_table_$noarg, "fortran");
	     end;
	     else call com_err_ (code, "fortran", arg);
	end;
	else call com_err_ (error_table_$wrong_no_of_args, "fortran");

	return;

/*   */

ep_basic: entry;

	basic_$precision_length = 2;
	return;

sp_basic: entry;

	basic_$precision_length = 1;
	return;

/*   */
set_up:	proc (arg, suffix) returns (bit (1) unal);

dcl  arg char (*);
dcl  suffix char (*);

/* automatic */

dcl  i fixed bin;
dcl  len_suffix fixed bin;
dcl  object_name char (32);
dcl  bit_count fixed bin (24);
dcl  directory_name char (168);
dcl  entry_name char (32);
dcl  path char (168);


/* set path to arg and add suffix, if not present.  */

	     i = length (arg);
	     len_suffix = length (suffix);
	     if i <= len_suffix then path = arg || suffix;
	     else if substr (arg, i - len_suffix + 1, len_suffix) = suffix then path = arg;
	     else path = arg || suffix;
	     i = length (path) + 1 - verify (reverse (path), " ");

/* get source, and fill in compiler_info structure */

	     call expand_pathname_ (path, directory_name, entry_name, code);
	     if code = 0 then do;

		call hcs_$initiate_count (directory_name, entry_name, "", bit_count, 0, source_ptr, code);
		if source_ptr ^= null then do;	/* ignore code if have ptr */
		     call hcs_$status_long (directory_name, entry_name, 1, addr (branch_status), null, code);
		     if code = 0 then do;
			s.version = compiler_source_info_version_2;
			s.input_pointer = source_ptr;
			s.input_lng = divide (bit_count+8, 9, 21, 0);
			s.given_ename = substr (entry_name, 1, length (entry_name) + 1-verify (reverse (entry_name), " "));
			call hcs_$fs_get_path_name (source_ptr, directory_name, i, entry_name, code);
			s.dirname = substr (directory_name, 1, i);
			s.segname = substr (entry_name, 1, length (entry_name) + 1-verify (reverse (entry_name), " "));
			s.date_time_modified = fixed (branch_status.date_time_modified || (16) "0"b, 71);
			s.unique_id = branch_status.unique_id;
			object_name = substr (s.given_ename, 1, length (s.given_ename) - len_suffix);
			directory_name = get_wdir_ ();
			call tssi_$get_segment (directory_name, object_name, object_ptr, acl_info_ptr, code);
			if code = 0 then return ("1"b);
			call print_err (directory_name, object_name);
		     end;
		     else call print_err (directory_name, entry_name);
		end;
		else call print_err (directory_name, entry_name);
	     end;
	     else call print_err (path, "");

	     return ("0"b);

	end set_up;

/*  */
cleanup_handler: proc;

	     call tssi_$clean_up_segment (acl_info_ptr);
	     if source_ptr ^= null then call hcs_$terminate_noname (source_ptr, code);

	end cleanup_handler;

/* This procedure calls com_err_ and returns from fst_basic */

print_err: proc (directory, entry);

dcl  directory char (*);
dcl  entry char (*);

	     if directory = ">" | entry = "" then call com_err_ (code, proc_name, "^a^a", directory, entry);
	     else call com_err_ (code, proc_name, "^a>^a", directory, entry);

	end print_err;
     end fst_compile_;
  



		    fst_cv_line_num_.pl1            01/19/88  1505.6rew 01/19/88  1502.1       15471


/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1987 *
        *                                          *
        ******************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-12-03,TLNguyen), approve(87-12-03,MCR7806),
     audit(87-12-10,Lippard), install(88-01-19,MR12.2-1015):
     - Declare the length, substr, verify as builtin type because they
       are referenced within the source but they are not defined within it.
                                                   END HISTORY COMMENTS */


fst_cv_line_num_: proc (string, num, code) returns (bit (1) unal);
/* * This procedure converts a string to a line number.  Line numbers are positive numbers <= 99999.  It returns:
   *
   *	"1"b	the string was converted
   *	"0"b	a syntax error occurred.
*/

/* parameters */

dcl  string char (*);
dcl  num fixed bin;
dcl  code fixed bin (35);				/* error code */

/* automatic */

dcl  number_pic pic "zzzz9";				/* 00000X */
dcl  max_digits int static options (constant) init (5);
dcl  num_digits fixed bin;

/* builtin */
dcl (length, substr, verify) builtin;

%include dfast_error_codes;

dcl  DIGIT char (10) int static options (constant) init ("0123456789");

	     if verify (string, DIGIT) = 0 then do;
		num_digits = length (string);
		if num_digits <= max_digits then do;
		     number_pic = 0;
		     substr (number_pic, max_digits - num_digits + 1, num_digits) = string;
		     num = number_pic;
		     code = 0;
		     return ("1"b);
		end;
		else code = error_max_num;

	     end;

	     else code = error_bad_line;

	     return ("0"b);

	end fst_cv_line_num_;
 



		    fst_edit_.pl1                   01/19/88  1505.6rew 01/19/88  1459.5      321066


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


/****^  HISTORY COMMENTS:
  1) change(87-12-02,TLNguyen), approve(87-12-02,MCR7806),
     audit(87-12-10,Lippard), install(88-01-19,MR12.2-1015):
     Implementing SCP6357 and correct deviations from coding standards found
     while researching the problems.
     - fixed stringrange condition raised in the edit internal procedure
       and in the parse_pathname internal procedure.
     - replace the (get, release) temp_segments_ with (get, release) temp_
       segment_ system routines in the merge_add internal procedure.
     - replace the "Changes will be lost if you continue.  Do you want to
       continue?" queried message with "Changes will be lost if you quit.
       Do you want to quit?"
     - Remove the acode, ioa_$ioa_switch_nnl, iox_$get_line, iox_$user_input
       and len from the source because they are not referenced anywhere
       within it.
                                                   END HISTORY COMMENTS */


fst_edit_: proc (edit_ptr, line, continue, print_prompt_char);

/*  This procedure implements all the edit commands for FAST

   Written 3/76 by S.E. Barr
   Fix bug in save request that adds null chars 06/24/81 S. Herbst
   Fix bug in locate request, bad substr lengths phx12352 10/25/83 C Spitzer
	add cleanup of temp segments.
*/
/* parameters */

dcl  edit_ptr ptr;					/* ptr to edit_info structure */
dcl  line char (*);					/* input:  user input line */
dcl  continue fixed bin;				/* output:  -1 = quit;  0 = was edit;  1 = not edit  */
dcl  print_prompt_char bit (1) unal;			/* output:  ON = print;  OFF = don't print */

/* automatic */

dcl  arg char (150) var;				/* argument from command line */
dcl  code fixed bin (35);
dcl  end_line fixed bin;				/* last line number in text usually = f.end_line_number */
dcl  i fixed bin;
dcl  increment fixed bin;				/* used to derive numbers for resequencing */
dcl  input_line_length fixed bin;			/* length of command line:  get_arg */
dcl  input_line_start fixed bin;			/* index into input line of unparsed characters  */
dcl  message char (150);				/* error message */
dcl  seq_number fixed bin;				/* first number to be used in resequencing */
dcl  num fixed bin;					/* line number from command line */
dcl  path char (168) var;				/* pathname for OLD, SAVE, or RUN commands */
dcl  request fixed bin;				/* number of edit request */
dcl  seg_length fixed bin (21);
dcl  seg_ptr ptr;
dcl  t_length fixed bin (21);				/* length of text usually = text_length */
dcl  t_ptr ptr;					/* ptr to text usually = text_ptr */
dcl  temp_length fixed bin (21);			/* length of the buffer contianing modifications */
dcl  temp_ptr ptr;					/* ptr to edit buffer */
dcl  temp_ptr_is_temp_seg bit (1) aligned;

dcl (addr, addrel, divide, hbound, index, length, null, search, substr, reverse, verify) builtin;


/* constants */

dcl  ADD_TEXT fixed bin int static options (constant) init (0);
dcl  command_names (-1:32) char (11) int static options (constant) init (
     "fast", "",
     "change", "c",					/* 1 */
     "delete_text", "dt",				/* 2 */
     "info", "info",				/* 3 */
     "input", "input",				/* 4 */
     "locate", "l",					/* 5 */
     "merge_text", "mgt",				/* 6 */
     "move_text", "mt",				/* 7 */
     "new", "new",					/* 8 */
     "old", "old",					/* 9 */
     "print_text", "pt",				/* 10 */
     "quit", "q",					/* 11 */
     "ready_off", "rdf",				/* 12 */
     "ready_on", "rdn",				/* 13 */
     "resequence", "rsq",				/* 14 */
     "run", "run",					/* 15 */
     "save", "save");				/* 16 */
dcl  legal_path_chars char (65) int static options (constant) init ("0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ.>_");
dcl  DIGIT char (10) int static options (constant) init ("0123456789");
dcl  NEW_LINE char (1) int static options (constant) init ("
");
dcl  WHITE_SPACE char (2) int static options (constant) init ("	 "); /* tab blank */
dcl  SET bit (1) unal int static options (constant) init ("1"b); /* ON if should set end_line number */
dcl  QUERY int static options (constant) init (1);	/* query if changes will be lost */
dcl  NOT_EMPTY fixed bin int static options (constant) init (2); /* must have some text */
dcl  CREATE bit (1) unal int static options (constant) init ("1"b); /* ON if should create, if not found;  get_seg_ptr */
dcl  DEFAULT fixed bin int static options (constant) init (1); /* use entire text:  get_block */
dcl  NO_DEFAULT fixed bin int static options (constant) init (2); /* line must be specified:  get_block */
dcl  DEFAULT_LOC fixed bin int static options (constant) init (3); /* use end of text if last number not given:  get_block */
dcl  max_num_digits fixed bin int static options (constant) init (5); /* max number = 99999 */

/* based */

dcl  alt char (f.alt_length) based (f.alt_ptr);		/* buffer containing new text lines */
dcl 1 f aligned based (edit_ptr) like fst_edit_info;	/* per process data for editing */
dcl  text char (t_length) based (t_ptr);		/* text being modified */
dcl  seg char (seg_length) based (seg_ptr);		/* segment to add to  text  */
dcl  temp char (f.max_seg_size) based (temp_ptr);		/* new copy of text with modifications */

/* external */

dcl  command_query_ entry() options(variable);
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  fst_cv_line_num_ entry (char (*), fixed bin, fixed bin (35)) returns (bit (1) unal);
dcl  fst_info_ entry (ptr);
dcl  fst_info_$header entry (ptr, char (*) var);
dcl  fst_run_ entry (ptr, char (*) var);
dcl  fst_util_$change entry (ptr, fixed bin (21), fixed bin (21), char (*) var, char (*) var, fixed bin (21), fixed bin (35));
dcl  fst_util_$input entry (ptr, fixed bin (21), fixed bin, fixed bin, fixed bin, fixed bin (21), fixed bin (35));
dcl  fst_util_$merge entry (ptr, char (*), fixed bin (21), fixed bin, fixed bin (21), fixed bin (35));
dcl  fst_util_$move entry (ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, fixed bin (21), fixed bin (35));
dcl  fst_util_$resequence entry (ptr, fixed bin, fixed bin, fixed bin (21), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_$ioa_switch entry options (variable);
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$user_output ptr ext;
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));

%include fst_edit_info;
%include dfast_error_codes;
%include query_info;

/*  */

	message = "";
	code = 0;
	request = -1;

	input_line_length = length (line);
	if verify (substr (line, 1, 1), DIGIT) = 0 then request = ADD_TEXT;
	else do;
	     input_line_start = 1;
	     input_line_length = input_line_length - 1;
	     if get_arg (arg) then do;
		do i = 1 to hbound (command_names, 1) while (request = -1);
		     if arg = command_names (i) then request = divide (i + 1, 2, 17, 0);
		end;

		if request = -1 then do;
		     if arg = "logout" & ^f.subsystem then do;
			continue = 0;
			call ioa_$ioa_switch (iox_$user_output, "Use quit");
		     end;
		     else continue = 1;
		     return;
		end;
	     end;
	end;

	call edit (request);

	if request ^= ADD_TEXT then print_prompt_char = f.prompt;
	if code ^= 0 | message ^= "" then call dfast_error_ (code, command_names (request *2 -1), message);

	return;


/*  */
edit:	proc (request);

dcl  request fixed bin;

/* automatic */

dcl  done bit (1) unal;
dcl  i fixed bin;
dcl  string_found bit (1) unal;			/* ON if string was_found at least once */
dcl  k fixed bin (21);
dcl  input_length_save fixed bin;			/* length of user's command line */
dcl  target_index fixed bin (21);
dcl  num_chars fixed bin (21);
dcl  old_string char (150) var;
dcl  new_string char (150) var;
dcl  start fixed bin (21);
dcl  j fixed bin (21);
dcl  cleanup condition;

	     temp_ptr = f.alt_ptr;
	     temp_ptr_is_temp_seg = "0"b;
	     temp_length = 0;
	     t_ptr = f.text_ptr;
	     t_length = f.text_length;
	     end_line = f.end_line_number;

	     seg_ptr = null;
	     on cleanup call term_seg;

	     goto label (request);

/*   */
/* Line number text was input.  It is added to a temporary buffer to be processed laster.  If the line number
   is greater than 99999 then the code is set.
*/
label (0):

dcl next_position fixed bin;

	     next_position = 0;

	     i = verify (line, DIGIT) -1;
	     if i <= max_num_digits then do;
		next_position = f.alt_length + 1;
		f.alt_length = f.alt_length + input_line_length;
		substr (alt, next_position, input_line_length) = line;
	     end;
	     else code = error_max_num;

	     print_prompt_char = "0"b;
	     return;

/*  */

/*  *	change  /<old_string>/<new_string>/  <first>  [<last>]
   *
   *  If the string could not be replaced at least once, an error code is set by fst_util_.
   */
label (1):
	     if merge_add (NOT_EMPTY) then do;
		if parse_strings ("1"b, old_string, new_string) then do;
		     if get_block (NO_DEFAULT, start, num_chars) then do;

			call fst_util_$change (edit_ptr, start, num_chars, old_string, new_string, temp_length, code);
			if code = 0 then call switch_buffers (^SET);
			else message = old_string;
		     end;
		end;
	     end;

	     return;


/* *	delete_text  first  [last]
   *
   * This request deletes one or more lines from the temporary  text
*/
label (2):

dcl  num_left fixed bin (21);

	     if merge_add (NOT_EMPTY) then do;
		if get_block (NO_DEFAULT, start, num_chars) then do;
		     num_left = f.text_length - start - num_chars + 1;
		     if num_left > 0 then substr (text, start, num_left) = substr (text, start + num_chars, num_left);
		     f.text_length = f.text_length - num_chars;
		     f.text_modified = "1"b;
		     if num_left = 0 then if set_end_number () then;
		end;
	     end;

	     return;


/* Info prints the pathname of the segment being modified, quota and money spent */
label (3):
	     call fst_info_ (edit_ptr);

	     return;

/*  */
/* *	input  [<after_line>]  [<increment>]
   *
   *	num	is the line number of the line after which the input will be put.
   *		This also determines the first number  (num  + increment - mod (num, increment)  )
   *
   *	start	is the index for first new line.
   *
   *  These defaults are used:
   *	1.  If the increment is not given, it is 10.
   *	2.  If after_line is not given, input is at the end of the text and f.end_line_number is used.
   *	3.  If the buffer is empty and no arguments are specified the first number will be 100.
   */
label (4):
	     if merge_add (0) then do;
		start = f.text_length + 1;
		seq_number = f.end_line_number;
		increment = 10;
		if parse_number (seq_number) then do;
		     if find_first_line (1, "0"b, seq_number, start, num_chars) then do;
			start = start + num_chars;
			if parse_number (increment) then;
		     end;
		end;
		else if f.text_length = 0 then seq_number = 90;
		if start > f.text_length then num = 100000;
		else if get_number (start, num) then;

		if message = "" then do;
		     call fst_util_$input (edit_ptr, start, seq_number, increment, num, temp_length, code);
		     call switch_buffers (^SET);
		end;
	     end;

	     return;

/*   */
/* *locate  /<string>/ [<first>]  [<last>]
   *
   * This request prints out all lines containing a given string.  The entire line is scanned for the string,
   * including the line number.  It uses these defaults:
   *
   *	1.  If "last" is omitted, the text between "first" and the end of the text is used.
   *	2.  If both "first" and "last" are omitted, the entire text is used.
   *
   * If the string is not found at least once, an error message is printed.
   */
label (5):
	     if merge_add (NOT_EMPTY) then do;
		if parse_strings ("0"b, old_string, "") then do;
		     if get_block (DEFAULT_LOC, start, num_chars) then do;

			string_found = "0"b;
			do while (num_chars > 0);
			     k = index (substr (text, start, num_chars), old_string);
			     if k > 0 then do;
				j = index (reverse (substr (text, start, k)), NEW_LINE) -1;
				if j > 0 then do;
				     start = start + k - j;
				     num_chars = num_chars + j - k;
				end;

				j = index (substr (text, start, num_chars), NEW_LINE);
				if j = 0 then j = num_chars;
				call iox_$put_chars (iox_$user_output, addr (substr (text, start, 1)), j, code);
				if code ^= 0 then return;
				start = start + j;
				num_chars = num_chars - j;
				string_found = "1"b;
			     end;
			     else num_chars = 0;
			end;
			if ^string_found then message = "could not find " || old_string;
		     end;
		end;
	     end;

	     return;

/*  */
/*	merge_text  <path>	[<line_number>]
   *
   * This request merges the contents on an ascii segment into the temporary text after the line specified with
   * line_number.  If line_number is not given, the segment is appended to the end of the temporary text.
   * The segment specified will be resequenced so it must have line numbers.  The temporary text following the
   * the merged text may be resequenced.  This is only done in cases where overlap of line numbers would
   * have occured.
*/
label (6):
	     if merge_add (0) then do;
		if parse_pathname (NO_DEFAULT, path) then do;
		     if get_seg_ptr (^CREATE, path) then do;
			if parse_number (num) then do;
			     if find_first_line (1, "0"b, num, start, num_chars) then do;
				start = start + num_chars;
				seq_number = num;
			     end;
			end;
			else do;
			     start = f.text_length + 1;
			     if start = 1 then seq_number = 90;
			     else seq_number = f.end_line_number;
			end;

			if message = "" then do;
			     call fst_util_$merge (edit_ptr, seg, start, seq_number, temp_length, code);
			     call switch_buffers (SET);
			end;
			call term_seg;
		     end;
		end;
		else if message = "" then message = "no pathname given";
	     end;

	     return;

/*  */
/* *	move_text <first>  [<last>] ,  [<after_line>]
   *
   * The block of lines specified by first and last is moved to a location following the line specified by
   * after_line.  The lines that are moved are resequenced.
*/
label (7):
	     if merge_add (NOT_EMPTY) then do;
		i = index (line, ",");
		if i > 0 then do;
		     input_length_save = input_line_length;
		     input_line_length = i -1;
		     if get_block (NO_DEFAULT, start, num_chars) then do;
			input_line_length = input_length_save;
			input_line_start = i + 1;
			if parse_number (num) then do;
			     if find_first_line (1, "0"b, num, target_index, j) then do;
				target_index = target_index + j -1;
				if target_index < start | target_index >= start + num_chars - 1 then do;
				     call fst_util_$move (edit_ptr, start, num_chars, target_index,
					num, temp_length, code);
				     call switch_buffers (SET);
				end;
				else message = "target of move is inside range";
			     end;
			end;
			else message = "line number missing";
		     end;
		end;
		else message = "comma is missing";
	     end;
	     return;

/*  */
/* *	new  [<path>]
   *
   * This request causes the text to be truncated.  The merge_add procedure queries the user if this action
   * would cause changes made to the text to be lost.  If path is not given, the default path is set to null.
*/
label (8):
	     if merge_add (QUERY) then do;
		if parse_pathname (0, path) then do;
		     f.pathname = path;
		     call set_basic_source;
		     f.text_length = 0;
		     f.end_line_number = 0;
		end;
	     end;

	     return;


/* *	old  <path>
   *
   * This request causes text to be replaced with the contents of the segment specified. The merge_add
   * procedure queries the user if this action would cause changes made to the text to be lost.
   * The new text must be line numbered source code.
*/
label (9):
	     if merge_add (QUERY) then do;
		if parse_pathname (NO_DEFAULT, path) then do;
		     if get_seg_ptr (^CREATE, path) then do;
			f.text_length, t_length = seg_length;
			f.text_ptr -> text = seg_ptr -> text;
			call term_seg;
			f.pathname = path;
			call set_basic_source;

/*  This code sets the last line number for use later */

			if f.text_length <= 1 then f.end_line_number = 0;
			else if ^set_end_number () then do;
			     f.text_length = 0;
			     f.pathname = "";
			end;

		     end;
		end;
	     end;

	     return;

/*  */
/* *	print_text  [-pn]  [<path>]  [-nhe]   [<first>]  [<last>]
*/
label (10):

dcl  header bit (1) unal;				/* ON if should print header  (no line numbers given) */

/*  This code parses the arguments.  If the path is not given (path = "") then the temporary text is used */

	     header = "1"b;
	     path = "";
	     done = "0"b;
	     do while (^done & message = "");
		if get_arg (arg) then do;
		     if arg = "-pn" | arg = "-pathname" then do;
			if ^get_arg (path) then message = "pathname is missing";
		     end;
		     else if arg = "-nhe" | arg = "-no_header" then header = "0"b;
		     else if verify (substr (arg, 1, 1), DIGIT) > 0 then do;
			if path = "" then path = arg;
			else message = "syntax error in line number";
		     end;
		     else do;
			input_line_start = input_line_start - length (arg);
			done = "1"b;
		     end;
		end;
		else done = "1"b;
	     end;

	     if message = "" then do;

/* The segment is initiated and temp is changed to be new segment instead of temporary text for get_block
   and other search routines. If the segment doesn't have line numbers, it can be printed if no lines were
   specified.
*/

		if path ^= "" then do;
		     if verify (path, legal_path_chars) = 0 then do;
			if get_seg_ptr (^CREATE, path) then do;
			     t_ptr = seg_ptr;
			     t_length = seg_length;
			     if t_length = 0 then message = "segment is empty " || path;
			     else if t_length > 1 then do;
				j = index (reverse (substr (text, 1, t_length -1)), NEW_LINE);
				if j = 0 then j = 1;
				else j = t_length - j + 1;
				if ^get_number (j, end_line) then do;
				     if input_line_start > input_line_length | substr (line, input_line_start) = ""
				     then message = "";
				end;
			     end;
			end;
		     end;
		     else message = "illegal character in pathname " || path;
		end;
		else if merge_add (NOT_EMPTY) then;

		if message = "" then do;
		     if input_line_start <= input_line_length
		     then if substr (line, input_line_start) ^= "" then header = "0"b;
		     if get_block (DEFAULT, start, num_chars) then do;
			if path = "" then path = f.pathname;
			if header then call fst_info_$header (edit_ptr, path);;
			call iox_$put_chars (iox_$user_output, addr (substr (text, start, 1)), num_chars, code);
		     end;
		end;
		call term_seg;
	     end;

	     return;

/*  */
/*  The quit request is allowed for the FAST command, but not the subsystem.  It queries the user if the text has been 
   modified since the last save.  It sets the parameter continue to -1 which causes the caller of fst_edit_ to quit.
*/
label (11):

	     if ^f.subsystem then do;
		if merge_add (QUERY) then continue = -1;
	     end;

	     else message = "use logout";

	     return;


/* ready_off sets the parameter print_prompt_char so the listener will not prompt */
label (12):

	     f.prompt = "0"b;
	     return;

/* ready_on sets the parameter print_ready_char so the listener will prompt
*/
label (13):

	     f.prompt = "1"b;
	     return;

/*  */
/* *	resequence  [<seq_number>]  [<increment>]
*/
label (14):
	     if merge_add (NOT_EMPTY) then do;
		if parse_number (seq_number) then do;
		     if ^parse_number (increment) then increment = 10;
		end;
		else do;
		     seq_number = 100;
		     increment = 10;
		end;

		if message = "" then do;
		     call fst_util_$resequence (edit_ptr, seq_number, increment, temp_length, code);
		     call switch_buffers (SET);
		end;

	     end;

	     return;


/* *	run  [<path>]
   *
   * If path is not given, the temporary text is run
*/
label (15):

	     if parse_pathname (0, path) then;
	     if path = "" then if merge_add (NOT_EMPTY) then;

	     if message = "" then call fst_run_ (edit_ptr, path);

	     return;

/*  */
/* *	save	[<path>]
   *
   * This request causes text to be copied into the segment specified.  If the segment doesn't exist, it will
   * be created.  If path is not given, the default pathname is used.  If the request is successful,
   * the default pathname is changed.
*/
label (16):

dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (21), fixed bin (35));

	     if merge_add (NOT_EMPTY) then do;
		if parse_pathname (0, path) then do;
		     if path = "" then path = f.pathname;
		     if get_seg_ptr (CREATE, path) then do;
			seg_ptr -> text = f.text_ptr -> text;
			f.pathname = path;
			call set_basic_source;
			f.text_modified = "0"b;
			call hcs_$set_bc_seg (seg_ptr, f.text_length * 9, code);
			if code = 0 then call hcs_$truncate_seg
			     (seg_ptr, divide (f.text_length + 3, 4, 21, 0), code);
			call term_seg;
		     end;
		end;
	     end;

	     return;

	end edit;

/*  */
/* *  This procedure finds the next token on the line.  Tokens are separated by blanks or tabs.
   *  It uses the global variables:
   *
   *	line		parameter ;  user's input line
   *	input_line_start	index to begin searching
   *	input_line_length	number of characters in input line
   *
   *  If it finds a token, it returns "1"b after setting:
   *	arg		token
   *	input_line_start	index following token
   *
   *  Otherwise it returns "0"b
*/
get_arg:	proc (arg) returns (bit (1));

/* parameters */

dcl  arg char (*) var;

/* automatic */

dcl  i fixed bin;
dcl  len fixed bin;

	     len = input_line_length - input_line_start + 1;

	     if len > 0 then do;
		i = verify (substr (line, input_line_start, len), WHITE_SPACE);
		if i > 0 then do;
		     input_line_start = input_line_start + i -1;
		     len = len - i + 1;
		     i = search (substr (line, input_line_start, len), WHITE_SPACE);
		     if i = 0 then i = len;
		     else i = i - 1;
		     arg = substr (line, input_line_start, i);
		     input_line_start = input_line_start + i;
		     return ("1"b);
		end;
	     end;

	     return ("0"b);

	end get_arg;

/*  */
/* * This procedure gets the next tokens which should be first and last line numbers.  It returns an index into
   * text and the number of characters in the block covered by the range.  There must be at least one line in the
   * range.
   * Default actions depend on default_code as follows:
   *
   *	NO_DEFAULT	range specification must be present
   *	DEFAULT		use entire text
   *	DEFAULT_LOC	if last line is not specified then the end of the text is assumed.
*/
get_block: proc (default_code, block_start, block_length) returns (bit (1) unal);

/* parameters */

dcl  default_code fixed bin;
dcl  block_start fixed bin (21);
dcl  block_length fixed bin (21);

/* automatic */

dcl  equal bit (1) unal;
dcl  line_start fixed bin (21);			/* index in text of line being compared */
dcl  j fixed bin (21);
dcl  num fixed bin;
dcl  num_1 fixed bin;
dcl  num_2 fixed bin;

	     if parse_number (num_1) then do;
		if parse_number (num_2) then do;
		     equal = "0"b;
		     if num_1 > num_2 then do;
			message = "lines must be in increasing order";
			return ("0"b);
		     end;
		end;

		else if default_code = DEFAULT_LOC then do;
		     equal = "0"b;
		     num_2 = 99999;
		end;
		else equal = "1"b;

		if find_first_line (1, equal, num_1, block_start, block_length) then do;

		     if equal then return ("1"b);
		     if num_2 >= end_line then block_length = t_length - block_start + 1;
		     else do;
			line_start = block_start;
			block_length = 0;
			do while (block_length = 0 & message = "");

			     if get_number (line_start, num) then do;
				if num_2 < num then do;
				     block_length = line_start - block_start;
				     if block_length = 0 then message = "line not found in text";
				end;
			     end;
			     j = index (substr (text, line_start), NEW_LINE);
			     if j = 0 then j = t_length - line_start + 1;
			     line_start = line_start + j;
			end;
		     end;
		end;
	     end;

	     else if default_code ^= NO_DEFAULT then do;
		block_start = 1;
		block_length = t_length;
	     end;
	     else message = "line number must be given";

	     if message = "" then do;
		if block_length > 0 then return ("1"b);
		else message = "line not found in text";
	     end;

	     return ("0"b);

	end get_block;

/*  */
/* * This procedure gets the next token and converts it to a line number.  It returns:
   *
   *	"1"b	if the next token was a number.
   *	"0"b	if there was a syntax error or no more tokens.
*/
parse_number: proc (num) returns (bit (1) unal);

dcl  num fixed bin;					/* the number found */

	     if get_arg (arg) then do;
		if fst_cv_line_num_ ((arg), num, code) then return ("1"b);
		message = arg;
	     end;

	     return ("0"b);

	end parse_number;

/*  */
/* * This procedure is given a line number and it sets line start to the index in text of the line with taht line
   * number or the next higher line.  If the exact line is  found, line_length is set.  Otherwise
   * line_length is 0.
*/
find_first_line: proc (index_start, must_be_equal, line_number, line_start, line_length) returns (bit (1) unal);

/* parameters  */

dcl  index_start fixed bin (21);
dcl  must_be_equal bit (1) unal;
dcl  line_start fixed bin (21);
dcl  line_number fixed bin;
dcl  line_length fixed bin (21);

/* automatic */

dcl  num fixed bin;

	     line_start = index_start;

	     do while (line_start <= t_length & message = "");
		if get_number (line_start, num) then do;
		     line_length = index (substr (text, line_start), NEW_LINE);
		     if line_length = 0 then line_length = t_length - line_start + 1;
		     if line_number <= num then do;
			if line_number = num then return ("1"b);
			if ^must_be_equal then do;
			     line_length = 0;
			     return ("1"b);
			end;
			message = "line not found in text";
		     end;
		     line_start = line_start + line_length;
		end;
	     end;

	     line_length = 0;

	     if message = "" then do;
		if ^must_be_equal then return ("1"b);
		else message = "line not found in text";
	     end;

	     return ("0"b);

	end find_first_line;

/*   */
/* * This procedure is given an index into text and it sets the line number */
get_number: proc (start, line_number) returns (bit (1) unal);

dcl  start fixed bin (21);
dcl  line_number fixed bin;
dcl  i fixed bin (21);

	     i = verify (substr (text, start), DIGIT);
	     if i = 0 then i = t_length - start + 1;
	     else i = i - 1;
	     if i > 0 then do;
		if fst_cv_line_num_ (substr (text, start, i), line_number, code) then return ("1"b);
		message = substr (text, start, i);
	     end;
	     else message = "un-numbered line found in text";

	     return ("0"b);

	end get_number;

/*  */
/* * This procedure gets the next token from the command line and checks it for valid characters.
   * It returns "1"b if the path was given and is valid or there are no more tokens.
   * Otherwise it returns "0"b.
   */
parse_pathname: proc (default, path) returns (bit (1) unal);

dcl  default fixed bin;				/* 0 = OK  if path  not specified;  NO_DEFAULT = erorr */
dcl  path char (168) var;

	     path = "";

	     if get_arg (path) then do;
		if verify (path, legal_path_chars) = 0 then return ("1"b);
		message = "illegal character in pathname " || path;
	     end;
	     else if default ^= NO_DEFAULT then return ("1"b);

	     else message = "pathname is missing";

	     return ("0"b);

	end parse_pathname;


set_basic_source: proc;

dcl reverse_pathname char (168) varying;

dcl before builtin;

	     reverse_pathname = reverse (f.pathname);
	     if index (reverse_pathname, ".") > 1 then f.basic_source = (reverse (before (reverse_pathname, ".")) = "basic");
	     else f.basic_source = "0"b;
	     
	     return;

	end set_basic_source;


/* This procedure sets end_line_number to the number of the last line in the segment.  */
set_end_number: proc returns (bit (1) unal);

dcl  start fixed bin (21);

	     if f.text_length > 0 then do;
		start = index (reverse (substr (text, 1, f.text_length -1)), NEW_LINE);
		if start = 0 then start = 1;
		else start = f.text_length - start + 1;
		return (get_number (start, f.end_line_number));
	     end;

	     return ("0"b);

	end set_end_number;

/*   */
/*  This procedure is given a pathname and it gets a pointer to the segment.
   If create_if_not_found is set, it creates the segment.
   If it is not set, it assumes the segment exists and contains line numbered text.
   It returns "1"b if seg_ptr can be set and contains valid text.
   If an error occurs message is set.
*/
get_seg_ptr: proc (create_if_not_found, path) returns (bit (1));

dcl  create_if_not_found bit (1);			/* ON if should create if it doesn't exist */
dcl  path char (168) var;				/* path of the segment */

dcl  fst_get_segment_ entry (bit (1) unal, char (*) var, char (*) var, ptr, fixed bin (21), fixed bin (35));

	     if path ^= "" then do;
		call fst_get_segment_ (create_if_not_found, path, f.working_dir, seg_ptr, seg_length, code);
		if code = 0 then return ("1"b);
		else message = path;
	     end;
	     else message = "pathname missing";

	     return ("0"b);


	end get_seg_ptr;

/*  */
/* * This procedure merges the pending changes to the temporary text.  If check is set, and there
   * have been changes, since the last save, the user is queried, since editing will be lost.
   *
   * These conventions are followed in inserting the pending changes:
   *
   *	1.  If the new line appears in text, it replaces the old line.
   *	2.  If the new line has num_chars = 0, it causes the old line in text to be deleted.
   *	3.  If the new line does not appear in text, it is inserted.
*/
merge_add: proc (check) returns (bit (1) unal);

dcl  check fixed bin;

/* automatic */

dcl  answer char (20) var;				/* yes or no */
dcl  i fixed bin (21);
dcl  last_index fixed bin (21);
dcl  line_length fixed bin (21);
dcl  line_start fixed bin (21);
dcl  save_ptr ptr;
dcl  table_ptr ptr;

dcl 1 t aligned based (table_ptr) like dfast_line_table;


dcl  dfast_get_table_ entry (bit (1) unal, ptr, fixed bin (21), ptr, fixed bin (35));
%include dfast_line_table;

/*  */
	     if check = QUERY then do;
		if (f.text_modified & f.text_length > 0) | f.alt_length > 0 then do;
		     query_info.version = query_info_version_6;
		     query_info.yes_or_no_sw = "1"b;
		     query_info.suppress_name_sw = "1"b;
		     query_info.cp_escape_control = "10"b;
		     call command_query_ (addr (query_info), answer, "fast",
			"Changes will be lost if you quit.  Do you want to quit ? ");
		     if answer = "yes" then do;
			f.text_modified = "0"b;
			f.alt_length = 0;
			return ("1"b);
		     end;
		     else if answer = "no" then return ("0"b);
		end;
	     end;


	     if f.alt_length > 0 then do;
		table_ptr = addrel (f.alt_ptr, divide (f.alt_length + 3, 4, 21));
		t.table_length = 0;
		call dfast_get_table_ ("1"b, f.alt_ptr, f.alt_length, table_ptr, 0);
		temp_length = 0;
		temp_ptr = null;
		call get_temp_segment_ ("fast", temp_ptr, code);
		if code = 0 then do;
		     temp_ptr_is_temp_seg = "1"b;
		     last_index = 0;
		     do i = 1 to t.table_length while (message = "");
			if find_first_line (last_index + 1, "0"b, (t.line (i).number), line_start, line_length) then do;
			     if last_index < line_start -1 then call copy
				(substr (text, last_index + 1, line_start - 1 - last_index ));
			     if t.line (i).num_chars > 0 then call copy (substr (alt, t.line (i).start,
				t.line (i).num_chars));
			     last_index = line_start + line_length - 1;
			end;
		     end;
		     if message = "" then do;
			if last_index < f.text_length then
			     call copy (substr (text, last_index + 1, f.text_length - last_index));

/* Exchange ptrs so temp will become text.  temp_ptr is set so a buffer (previously text_ptr) can be freed. */

			save_ptr = f.text_ptr;
			f.text_ptr = temp_ptr;
			f.text_length = temp_length;
			temp_ptr = save_ptr;

			f.alt_length = 0;
			f.text_modified = "1"b;
			temp_length = 0;
			t_ptr = f.text_ptr;
			t_length = f.text_length;
			if t.line (t.table_length).number >= f.end_line_number then do;
			     if t.line (t.table_length).num_chars > 0 then f.end_line_number = t.line (t.table_length).number;
			     else if set_end_number () then;
			     end_line = f.end_line_number;
			end;
		     end;
		     if temp_ptr ^= null then call release_temp_segment_ ("fast", temp_ptr, code);
		     temp_ptr_is_temp_seg = "0"b;
		     temp_ptr = f.alt_ptr;
		end;
	     end;


	     if check = NOT_EMPTY then do;
		if t_length = 0 then do;
		     message = "buffer is empty";
		     return ("0"b);
		end;
	     end;
	     return ("1"b);

	end merge_add;

/*  */
/* This procedure switches the pointers so the temporary buffer becomes the temporary text.  The temp_ptr
   and the alter ptr are the same.
*/

switch_buffers: proc (set_last_number);

dcl  set_last_number bit (1) unal;			/* ON if should set the last number */

	     if code = 0 then do;
		f.alt_ptr = f.text_ptr;
		t_ptr, f.text_ptr = temp_ptr;
		t_length, f.text_length = temp_length;
		f.text_modified = "1"b;

		if set_last_number then if set_end_number () then;
	     end;

	     return;

	end switch_buffers;

/*  */
/* * This procedure parse two strings of the form:
   *
   *	/old_string/new_string/
   *
   *	where / can be any delimitor except blank or tab
*/
parse_strings: proc (two_strings, old_string, new_string) returns (bit (1) unal);

dcl  two_strings bit (1) unal;			/* ON if should set both strings */
dcl  old_string char (*) var;
dcl  new_string char (*) var;

dcl  delimitor char (1);
dcl  start fixed bin;
dcl  i fixed bin;

	     if input_line_start <= input_line_length then do;
		start = input_line_start;
		i = verify (substr (line, start, input_line_length-start+1), WHITE_SPACE) - 1;
		if i > -1 then do;
		     delimitor = substr (line, start + i, 1);
		     start = start + i + 1;
		     i = index (substr (line, start, input_line_length-start+1), delimitor) -1;
		     if i > 0 then do;
			old_string = substr (line, start, i);
			if two_strings then do;
			     start = start + i + 1;
			     i = index (substr (line, start, input_line_length-start+1), delimitor) -1;
			     if i>0 then new_string = substr (line, start, i);
			     else if i = 0 then new_string = "";
			     else message = "delimitor is missing  " || delimitor;
			end;
		     end;

		     else if i = 0 then message = "string is missing";
		     else message = "delimitor missing " || delimitor;
		end;
		else message = "string is missing";

		if message = "" then do;
		     input_line_start = start + i +1;
		     return ("1"b);
		end;
	     end;
	     else message = "string is missing";

	     return ("0"b);

	end parse_strings;

/*  */
copy:	proc (string);

dcl  string char (*);

	     if temp_length + length (string) <= f.max_seg_size then do;
		substr (temp, temp_length + 1, length (string)) = string;
		temp_length = temp_length + length (string);
	     end;
	     else message = "segment would exceed max segment size";

	     return;

	end copy;


term_seg: proc;

	if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, (0));
	if temp_ptr ^= null & temp_ptr_is_temp_seg then call release_temp_segment_ ("fast", temp_ptr, (0));

	end term_seg;

     end fst_edit_;
  



		    fst_get_segment_.pl1            03/23/76  1035.0r w 03/23/76  1030.1       23625


fst_get_segment_: proc (create_if_not_found, arg_pathname, working_dir, seg_ptr, seg_length, code);

/* This procedure returns a pointer to the segment specified with arg_pathname.
   If the segment is found, it must end with a new_line character.
   If the segment is not found, and the create_if_not_found switch is set, the segment will be created with re access.

   Written 3/76 by S.E. Barr
*/
/*  parameters */

dcl  create_if_not_found bit (1) unal;
dcl  arg_pathname char (*) var;
dcl  working_dir char (*) var;
dcl  seg_ptr ptr;
dcl  seg_length fixed bin (21);
dcl  code fixed bin (35);

/* automatic */

dcl  bit_count fixed bin (24);			/* length of segment */
dcl  i fixed bin (35);
dcl  directory_name char (168);
dcl  entry_name char (32);
dcl 1 o aligned like object_info;
dcl  pathname char (256) var;				/* complete pathname */

dcl  seg char (seg_length) based (seg_ptr);

dcl (addr, divide, index, length, max, null, reverse, substr) builtin;

/* external */

dcl  error_table_$noentry fixed bin (35) ext;
dcl  error_table_$segknown fixed bin (35) ext;
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (12), ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35));

/* constants */

dcl  NEW_LINE char (1) int static options (constant) init ("
");
dcl  RW_access fixed bin (5) int static init (01010b) options (constant);

/*  */
%include dfast_error_codes;
%include object_info;

/* */
	seg_ptr = null;

	if substr (arg_pathname, 1, 1) = ">" then pathname = arg_pathname;
	else pathname = working_dir || ">" || arg_pathname;
	i = length (pathname) - index (reverse (pathname), ">");
	directory_name = substr (pathname, 1, max (i,1));
	entry_name = substr (pathname, i + 2);

	call hcs_$initiate_count (directory_name, entry_name, "", bit_count, 1, seg_ptr, code);
	if code = error_table_$segknown then code = 0;
	if code = 0 then do;
	     seg_length = divide (bit_count + 8, 9, 21, 0);

/* Do not allow object segments to edited. */

	     if seg_length > 0 then if substr (seg, seg_length, 1) ^= NEW_LINE then do;
		call object_info_$display (seg_ptr, bit_count,  addr (o), code);
		if code = 0 then code = error_obj_nop;
		else code = error_no_new_line;
	     end;
	end;

	else if code = error_table_$noentry then do;
	     if create_if_not_found then do;
		call hcs_$make_seg (directory_name, entry_name, "", RW_access, seg_ptr, code);
		if code = 0 then seg_length = 0;
	     end;
	end;

	return;

     end fst_get_segment_;
   



		    fst_help_.pl1                   01/19/88  1505.6rew 01/19/88  1502.6       17253


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


/****^  HISTORY COMMENTS:
  1) change(87-12-03,TLNguyen), approve(87-12-03,MCR7806),
     audit(87-12-10,Lippard), install(88-01-19,MR12.2-1015):
     - Remove the null builtin type from the source because it is not
       referenced anywhere within the source.
                                                   END HISTORY COMMENTS */


fst_help_: proc;

/* This procedure prints FAST info segments */
/* Written 3/76 by S.E. Barr */
/* MCR 4267 Change help with no args to print list of topics 12/19/79 S. Herbst */
/* Changed to call system help command 06/24/81 S. Herbst */

dcl  arg_ptr ptr;
dcl  arg_length fixed bin;
dcl  code fixed bin (35);
dcl  i fixed bin;
dcl  nargs fixed bin;				/* number of arguments for command */

dcl  arg char (arg_length) based (arg_ptr);

dcl  rtrim builtin;

dcl  directory char (168) aligned int static options (constant) init (">doc>ss>fast");

/* external */

dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  help entry options (variable);

	call cu_$arg_count (nargs);

	if nargs = 0 then call help (rtrim (directory) || ">topics");

	else do i = 1 to nargs;
	     call cu_$arg_ptr (i, arg_ptr, arg_length, code);
	     if code = 0 then call help (rtrim (directory) || ">" || arg);
	     else call com_err_ (code, "help");
	end;

	return;

     end fst_help_;
   



		    fst_info_.pl1                   07/13/88  1120.3r w 07/13/88  0935.7       39132


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


/****^  HISTORY COMMENTS:
  1) change(87-12-03,TLNguyen), approve(87-12-03,MCR7806),
     audit(87-12-10,Lippard), install(88-01-19,MR12.2-1015):
     - Remove com_err_, get_group_id_, get_wdir_, ioa_$nnl, ioa_$rs,
       ioa_$rsnnl from the source because they are not referenced anywhere
       within it.
     - Declare the fixed, max, verify as builtin type because they are
       referenced but they are not defined anywhere within the source.
                                                   END HISTORY COMMENTS */


fst_info_: proc (edit_ptr);

/* This procedure prints accounting information, the user's name and project, and the default name (which may be null

   "program name"  HHH.M mst DDD  User_id.Project_id
   $XX.XX speXt/ XX.XX limit    XXX records used / XXX limit

   Written 3/76 by S.E. Barr
   Modified 1984-08-24 BIM for pit instead of pitmsg.
*/
/* parameters */

dcl  edit_ptr ptr;					/* prt to edit structure */
dcl  path char (*) var;

/* automatic */

dcl  code fixed bin (35);
dcl  quota fixed bin (18);
dcl  quota_used fixed bin (18);
dcl  pp ptr;
dcl  date_string char (24) aligned;
dcl  name char (168) var;

dcl (fixed, max, null, substr, length, index, verify) builtin;

dcl 1 f aligned based (edit_ptr) like fst_edit_info;

/* external */

dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  clock_ entry () returns (fixed bin (71));
dcl  date_time_ entry (fixed bin (71), char (*) aligned);
dcl  get_pdir_ entry () returns (char (168) aligned);
dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$quota_read entry (char (*), fixed bin (18), fixed bin (71), bit (36)aligned, fixed bin, fixed bin (1), fixed bin (18), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_$ioa_switch entry options (variable);
dcl  iox_$user_output ptr ext;

/*   */
%include user_attributes;
%include fst_edit_info;
%include pit;


	call hcs_$initiate ((get_pdir_ ()), "pit", "", 0, 1, pp, code);
	if pp ^= null then do;
	     call set_name_date (f.pathname);

	     call hcs_$quota_read ((f.working_dir), quota, (0), ("0"b), (0), (0), quota_used, code);

	     call ioa_$ioa_switch (iox_$user_output,
		"""^a""  ^a  ^a.^a^/$^7.2f spent/^a limit   ^d records used / ^d limit", name, date_string,
		pp -> pit.login_name, pp -> pit.project,
		pp -> pit.dollar_charge, (cv_limit (pp -> pit.dollar_limit)), quota_used, quota);
	     call hcs_$terminate_noname (pp, code);
	end;
	else call dfast_error_ (code, "info", "");

	return;

header:	entry (edit_ptr, path);

	call set_name_date (path);
	call ioa_$ioa_switch (iox_$user_output, "^/""^a""  ^a^/", name, date_string);

	return;

/*   */
cv_limit:	procedure (limit) returns (char (9) aligned);

/* procedure to convert a float bin $limit into either the string, "open", if $limit is >= 1e37,
   or to convert a float bin $limit into an integer $limit  */

dcl  limit float bin;
dcl  lim_pic pic "zzzzz9v.99";

	     if limit >= 1e36 then return ("open");
	     lim_pic = fixed (limit);
	     return (substr (lim_pic, max (verify (lim_pic, " "), 1)));

	end cv_limit;


/* This procedure sets path:  if the entry is in the working directory only the entry name will be printed;
   otherwise the entire path will be printed.  It is possible for the entryname to be null.
*/
set_name_date: proc (path);

dcl  path char (*) var;

	     if index (path, f.working_dir) = 1 then name = substr (path, length (f.working_dir) + 2);
	     else name = path;
	     call date_time_ (clock_ (), date_string);

	     return;

	end set_name_date;
     end fst_info_;



		    fst_process_overseer_.pl1       07/13/88  1120.3r w 07/13/88  0935.8      120816


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


/****^  HISTORY COMMENTS:
  1) change(87-12-02,TLNguyen), approve(87-12-02,MCR6357),
     audit(87-12-10,Lippard), install(88-01-19,MR12.2-1015):
     - Asign null to f.alt_ptr and "0"b to the f.flags.pad fields
       to meeting coding standards.
     - Remove the hcs_$get_system_search_rules from the source because
       it is not referenced anywhere within the source.
     - Declare the empty as builtin type because it is referenced
       within the source.
                                                   END HISTORY COMMENTS */


fst_process_overseer_: proc;

/* * This procedure is the listener for the FAST subsystem and the command fast.
   *  A line is read from user_input and leading blanks and tabs are ignored.
   *	1.  Blank lines are ignored.
   *	2.  The line is assumed to be an edit request and fst_edit_ is called.
   *	3.  If fst_edit_ sets continue to 1, then the command has not be processed and
   *	    fst_command_processor_ is called.
*/
/* Modified 1/77 by S.E. Barr to use FAST */
/* Modified 10/31/83 by C Spitzer to add cleanup handler, default to sp_basic if used as process_overseer_ */
/* Modified 1984-08-20 BIM for pit instead of pitmsg. */

/* automatic */

dcl  bit_count fixed bin (24);			/* bit coun of message of the day */
dcl  code fixed bin (35);				/* standard Multics code */
dcl  continue fixed bin;				/* 0= edit;  1= not edit;  -1= quit */
dcl  edit_ptr ptr;					/* ptr to edit_info structure */
dcl  entry_value entry init (cp_handler);		/* contrivance to get proc_ptr to cp_handler */
dcl 1 f aligned like fst_edit_info;
dcl  line char (150);				/* line typed by user */
dcl  line_length fixed bin (21);			/* number of characters in line */
dcl  line_start fixed bin;				/* index in line of first non blank */
dcl  pp ptr;
dcl  mothd_ptr ptr;
dcl  print_prompt_char bit (1) unal;
dcl  quit_prompt bit (1);
dcl  saved_precision_length fixed bin;
dcl 1 search_rules aligned,
    2 number fixed bin init (1),
    2 names (1) char (168) aligned init ("fast");
dcl 1 saved_search_rules aligned,			/* FAST as a command saves the old search rules */
	2 number fixed bin,
	2 names (21) char (168) aligned;
dcl  saved_cp_ptr ptr;			/* FAST as a command save the old value for cu_$cp */


dcl (addr, divide, empty, null, length, index, reverse, substr, verify) builtin;

dcl  proc_ptr ptr based (addr (entry_value));		/* contrivance to get proc_ptr to cp_handler */
dcl  ptr_array (2) ptr based;

dcl  (cleanup, quit) condition;

/* constants */

dcl  WHITE_SPACE char (2) int static options (constant) init ("	 "); /* blank tab */

/* external */

dcl  basic_$precision_length ext fixed bin;
dcl cu_$get_cp entry (ptr);
dcl  cu_$set_cp entry (ptr);
dcl  clock_ entry () returns (fixed bin (71));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  condition_ entry (char (*) aligned, entry);
dcl  hcs_$get_search_rules entry (ptr);
dcl  hcs_$initiate_search_rules entry (ptr, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$user_output ptr ext;
dcl  fast_related_data_$in_fast_or_dfast bit (1) aligned ext;
dcl  fast_related_data_$in_dfast bit (1) aligned ext;
dcl  fst_command_processor_ entry (char (*), bit (1)unal);
dcl  fst_edit_ entry (ptr, char (*), fixed bin, bit (1) unal);
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  get_wdir_ entry () returns (char (168));
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  ioa_$ioa_switch entry options (variable);
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$user_input ptr ext;
dcl  sys_info$max_seg_size fixed bin (35) ext;

/*  */
%include user_attributes;
%include pit;
%include fst_edit_info;

/*  */
/* print message of the day, if the user did not use the -brief option. */

	call hcs_$make_seg ("", "pit", "", 01000b, pp, code);
	if ^pp -> pit.at.brief then do;
	     call hcs_$initiate_count (">system_control_1", "message_of_the_day", "", bit_count, 1, mothd_ptr, code);
	     if mothd_ptr ^= null then do;
		call iox_$put_chars (iox_$user_output, mothd_ptr, divide (bit_count, 9, 21, 0), code);
		call hcs_$terminate_noname (mothd_ptr, code);
	     end;
	end;

/* setup quit and condition handler;  set default vaules for edit_info */

	f.working_dir = substr (pp -> pit.homedir, 1, length (pp -> pit.homedir) + 1 - verify (reverse (pp ->
	     pit.homedir), " "));
	call hcs_$terminate_noname (pp, code);

	f.subsystem = "1"b;
	basic_$precision_length = 1;

COMMON:
	f.text_ptr = null;
	f.alt_ptr = null;
	saved_precision_