


		    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_length = basic_$precision_length;
	on cleanup begin;
	     if f.text_ptr ^= null then call release_temp_segments_ ("fast", addr (f.text_ptr) -> ptr_array, (0));
	     basic_$precision_length = saved_precision_length;
	     end;

	call initial (code);
	if code ^= 0 & f.subsystem then goto RETURN;

	call condition_ ("any_other", any_other_handler);
	call cu_$set_cp (proc_ptr);		/* Prevent the execution of an E request in edm */

	on quit begin;
	     call iox_$control (iox_$user_input, "resetread", addr (line), code);
	     call ioa_$ioa_switch (iox_$user_output, "QUIT");
	     quit_prompt = "1"b;
	     goto READ_LOOP;
	end;

/* If the FAST search rules can't be set, then use the default ones. */
	call hcs_$initiate_search_rules (addr(search_rules), code);
	if code ^= 0 then do;
	     search_rules.names(1) = "default";
	     call hcs_$initiate_search_rules (addr(search_rules), code);
	end;
	if f.subsystem then call iox_$control (iox_$user_input, "quit_enable", addr (line), code);

/* When FAST is entered from command level, the loop terminates when the "quit" command sets continue to -1.
   When FAST is entered as a subsystem, the loop terminates when the user logs out.
   fst_edit_ is called with the entire line.  fst_command_processor_ is called without the new line character.
*/

READ_LOOP:
	continue = 0;
	do while (continue > -1);
	     continue = 0;

	     if print_prompt_char | quit_prompt then do;
		call date_time_ (clock_ (), line);
		call ioa_$ioa_switch (iox_$user_output, "r  ^a^/", substr (line, 11, 4));
		quit_prompt = "0"b;
	     end;
	     call iox_$get_line (iox_$user_input, addr (line), length (line), line_length, code);
	     if code = 0 then do;

		line_start = verify (substr (line, 1, line_length), WHITE_SPACE);
		if line_start < line_length then do;
		     line_length = line_length - line_start + 1;
		     call fst_edit_ (edit_ptr, substr (line, line_start, line_length), continue, print_prompt_char);
		     if continue = 1 then call fst_command_processor_ (substr (line, line_start, line_length - 1),
			(f.alt_length > 0 | f.text_modified));
		end;
		else print_prompt_char = "0"b;
	     end;
	     else call dfast_error_ (code, "fast", "");
	end;

RETURN:
	call release_temp_segments_ ("fast", addr (f.text_ptr) -> ptr_array, code);
	if code ^= 0 then call dfast_error_ (code, "fast", "Could not release temporary segments");
	fast_related_data_$in_dfast, fast_related_data_$in_fast_or_dfast = "0"b;
	call hcs_$initiate_search_rules (addr (saved_search_rules), code);
	call cu_$set_cp (saved_cp_ptr);
	if code ^= 0 then call dfast_error_ (code, "fast", "");
	basic_$precision_length = saved_precision_length;

	return;


/* FAST command.  The current search rules and command processor are saved, as FAST will change them. 
  The flag f.subsystem is set off, so the "quit" command will be allowed.
*/
fast:	entry;

	f.subsystem = "0"b;
	f.working_dir = get_wdir_ ();
	call hcs_$get_search_rules (addr (saved_search_rules));
	call cu_$get_cp (saved_cp_ptr);

	goto COMMON;

/*  */
/*  This procedure is called when the user attempts to execute a command line from edm.
   It prints an error message and returns to edm.
*/
cp_handler: proc;

	     call ioa_$ioa_switch (iox_$user_output, "Illegal entry to command level");

	     return;

	end cp_handler;


/*   */
initial:	proc (arg_code);

dcl  arg_code fixed bin (35);


	     arg_code = 0;
	     edit_ptr = addr (f);
	     fast_related_data_$in_dfast = "0"b;	/* switches for BASIC */
	     fast_related_data_$in_fast_or_dfast = "1"b;

	     print_prompt_char, f.prompt = "1"b;
	     quit_prompt = "0"b;
	     f.pathname = "";
	     f.text_length = 0;
	     f.alt_length = 0;
	     f.text_modified = "0"b;
	     f.basic_source = "0"b;
	     f.max_seg_size = sys_info$max_seg_size;
	     f.end_line_number = 0;
	     f.flags.pad = "0"b;
	     call get_temp_segments_ ("fast", addr (f.text_ptr) -> ptr_array, arg_code);
	     if arg_code ^= 0 then call dfast_error_ (arg_code, "fast", "temp segments");

	     return;

	end initial;


/*  */
any_other_handler: proc (mcptr, cond_name, wcptr, info_ptr, cont);

dcl  mcptr ptr,
     cond_name char (*),
     wcptr ptr,
     info_ptr ptr,
     cont bit (1) aligned;
dcl  area area (300);
dcl (i, l) fixed bin;
dcl  NEW_LINE char (1) init ("
");
dcl  message_len fixed bin (21);
dcl  message char (message_len) based (message_ptr);
dcl  message_ptr ptr;

dcl  condition_interpreter_ entry (ptr, ptr, fixed bin (21), fixed bin, ptr, char (*), ptr, ptr);

%include condition_info;
%include condition_info_header;

	     if cond_name = "command_error" |
	     cond_name = "command_question" | cond_name = "string_size" then return;

	     call condition_interpreter_ (addr (area), message_ptr, message_len, 1, mcptr, cond_name, wcptr, info_ptr);
	     if cond_name = "command_abort_" then goto READ_LOOP;
	     if message_len > 0 then do;

/* * This code modifies the error message to remove the shriek name and the phrase "(in process dir)"
   *
   *	Error: ... condition by !BBBJFbDjnMccfW.temp.0310$main_|50 (line 20) (in process dir)
   *
   *	Error: ... condition by main_|50 (line 20)
*/
		if substr (message, 2, 6) = "Error:" then do;
		     l = index (substr (message, 2), NEW_LINE);
		     if l > 0 then do;
			i = index (substr (message, 2, l), "by !");
			if i = 0 then i = index (substr (message, 2, l), "at !");
			if i > 0 then do;
			     i = i + 4;
			     if substr (message, i+15, 5) = ".temp" & substr (message, i + 25, 1) = "$" then do;
				substr (message, i) = substr (message, i+26, message_len - i -26+1);
				message_len = message_len - 26;
				i = index (substr (message, 1, l+1), "(in process dir)");
				if i > 0 then do;
				     substr (message, i) = substr (message, i+16);
				     message_len = message_len - 16;
				end;
			     end;
			end;
		     end;
		end;

		call iox_$put_chars (iox_$user_output, message_ptr, message_len, code);
	     end;

	     if cond_name = "finish" then return;

	     if info_ptr ^= null
	     then do;				/* can we see if it's eligable to restart? */
		condition_info_header_ptr = info_ptr -> condition_info.info_ptr;
		if condition_info_header.length > 0	/* is it filled in? */
		then if condition_info_header.default_restart | condition_info_header.quiet_restart
		     then return;			/* no further action besides printing error msg */
		     else if condition_info_header.cant_restart
			then goto READ_LOOP;	/* can't do anything further with error */
		          else if ask_for_continue ()
			     then return;
			     else goto READ_LOOP;
		else if ask_for_continue ()
		     then return;
		     else goto READ_LOOP;
		end;
	     else if ask_for_continue ()
		then return;
	          else goto READ_LOOP;


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

dcl  answer char (4) varying;
dcl  maxlength builtin;

dcl  command_query_ entry() options(variable);

dcl  EXPLAIN_MSG char (120) int static options (constant) init (
"If you answer ""yes"", the user program will be ""start""ed.
If you answer ""no"", the user program will be aborted.");

%include query_info;

	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;
	query_info.prompt_after_explanation = "1"b;
	query_info.explanation_ptr = addr (EXPLAIN_MSG);
	query_info.explanation_len = maxlength (EXPLAIN_MSG);
	call command_query_ (addr (query_info), answer, "fast", "Do you wish to continue the user program? ");
	if answer = "yes"
	then return ("1"b);				/* return to user program */
	else return ("0"b);				/* abort the user program */

	end ask_for_continue;

	end any_other_handler;

     end fst_process_overseer_;



		    fst_run_.pl1                    08/06/87  1147.7r w 08/06/87  1047.1       59103


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

fst_run_: proc (edit_ptr, arg_path);

/* * This procedure implements the run command.
   *
   *	1. If arg_path = null, the temporary text is used.
   *	2. Otherwise the segment specified by arg_path is used.
   *
   * If the segment is not an object segment, it is compiled.  The language suffix determines the compiler.  If the
   * compilation is successful, the object code is run.
   *
   * 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 10/25/83 by C Spitzer. remove call to basic_$precision_length.
*/
dcl  edit_ptr ptr;
dcl  arg_path char (*) var;

/* automatic */

dcl  bit_count fixed bin (24);
dcl  code fixed bin (35);
dcl  directory char (168);
dcl  directory_length fixed bin aligned;
dcl  entry char (32);
dcl 1 f aligned like fst_edit_info based (edit_ptr);
dcl 1 fort_opt aligned like fortran_options;
dcl  i fixed bin;
dcl  main_ename char (32) var;			/* main_ for FORTRAN or BASIC */
dcl  path char (168);
dcl 1 oi aligned like object_info;
dcl  object_length fixed bin;				/* word length from compilers */
dcl  object_bc fixed bin (24);			/* bit cound for run unit */
dcl  object_ptr ptr;
dcl 1 run_flags aligned,
    2 just_compiled bit (1) unal,
    2 brief bit (1) unal init ("0"b),
    2 probe bit (1) unal init ("0"b),
    2 pad bit (33) unal init ("0"b);
dcl 1 s aligned like compiler_source_info;
dcl  seg_ptr ptr;

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

dcl  cleanup condition;

/* external */

dcl  basic_$compile entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  fast_run_unit_manager_ entry (ptr, fixed bin (24), 1 aligned, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, 2 bit (33) unal, char (*) var, fixed bin (35));
dcl  fort_$compile entry (ptr, ptr, fixed bin, ptr, fixed bin (35));
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_$set_bc_seg entry (ptr, fixed bin (24), 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  hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));
dcl  object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));

%include fst_edit_info;
%include fort_options;
%include object_info;

%include branch_status;

%include compiler_source_info;


/*  */
	seg_ptr = null;

	on cleanup begin;
	     if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, code);
	end;

	if arg_path = "" then do;
	     path = f.pathname;
	     s.input_pointer = f.text_ptr;
	     s.input_lng = f.text_length;
	     i = index (reverse (f.pathname), ">");
	     if i = 0 then i = 1;
	     else i = length (f.pathname) - i+ 2;
	     call compile (substr (f.pathname, i));
	     object_bc = 36*object_length;
	end;
	else do;
	     path = arg_path;
	     call expand_pathname_ (path, directory, entry, code);
	     if code ^= 0 then call abort ("");
	     call hcs_$initiate_count (directory, entry, "", bit_count, 1, seg_ptr, code);
	     if seg_ptr ^= null then do;
		oi.version_number = object_info_version_2;
		call object_info_$brief (seg_ptr, bit_count, addr (oi), code);
		if code = 0 then do;
		     main_ename = substr (entry, 1, length (entry) + 1 - verify (reverse (entry), " "));
		     object_bc = bit_count;
		     run_flags.just_compiled = "0"b;
		     object_ptr = seg_ptr;
		end;
		else do;
		     s.input_pointer = seg_ptr;
		     s.input_lng = divide (bit_count, 9, 21, 0);
		     i = length (entry) + 1 - verify (reverse (entry), " ");
		     call compile (substr (entry, 1, i));
		     object_bc = 36*object_length;
		end;
	     end;
	     else do;
		i = index (directory, " ") -1;
		if i = -1 then i = length (directory);
		if directory = ">" then path = ">" || entry;
		else path = substr (directory, 1, i) || ">" || entry;
		call dfast_error_ (code, "run", path);
	     end;
	end;

	if code = 0 then call fast_run_unit_manager_ (object_ptr, object_bc, run_flags, main_ename, code);

RETURN:
	if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, code);
	return;

/*  */
abort:	proc (message);

dcl  message char (*);


	     i = index (path, " ") -1;
	     if i = -1 then i = length (path);
	     call dfast_error_ (code, "run", message || "  """|| substr (path, 1, i) || """");

	     goto RETURN;

	end abort;
						/*  */
compile:	proc (name);

dcl  name char (*);

	     code = 0;
	     s.version = compiler_source_info_version_2;
	     s.given_ename = name;
	     call hcs_$fs_get_path_name (s.input_pointer, directory, directory_length, entry, code);
	     s.dirname = substr (directory, 1, directory_length);
	     s.segname = substr (entry, 1, length (entry) + 1 - verify (reverse (entry), " "));
	     call hcs_$status_long (directory, entry, 1, addr (branch_status), null, code);
	     s.date_time_modified = fixed (branch_status.date_time_modified || (16) "0"b, 71);
	     s.unique_id = branch_status.unique_id;
	     run_flags.just_compiled = "1"b;
	     main_ename = "main_";
	     object_ptr = f.alt_ptr;
	     call hcs_$truncate_seg (object_ptr, 0, code);

	     if length (name) > 6 then do;
		if substr (name, length (name) - 5, 6) = ".basic" then do;
		     call basic_$compile (addr (s), object_ptr, object_length, code);
		     return;
		end;
		else do;
		     if length (name) > 8 & substr (name, length (name) -7, 8) = ".fortran" then do;
			unspec (fort_opt) = fast_mask;
			call fort_$compile (addr (s), object_ptr, object_length, addr (fort_opt), code);
			if code = 0 then call hcs_$set_bc_seg (object_ptr, object_length * 36, code);
			return;
		     end;
		end;
	     end;

	     call abort ("name must have a suffix of .basic or .fortran");

	end compile;

     end fst_run_;
 



		    fst_util_.pl1                   01/19/88  1505.6rew 01/19/88  1500.1      188721


/****^  ******************************************************
        *                                                    *
        * 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 subscript range condition occured in the fst_util_$merge entry.
      - Fixed substring range condition occured in the fst_util_$change entry.
      - Replace the num_lines subscript of the t array field in the
        basic_rsq_table based record with basic_rsq_table.num_lines as
        coding standards.
                                                   END HISTORY COMMENTS */


fst_util_: proc;

/*  This procedure implements the merge_text, move_text, change, input, and renumber commands.

   Written 3/76 by S.E. Barr
   Modified 11/76 by S.E. Barr to prevent change request from operationg on the entire text
   Bug fixed in merging of non-basic text 06/24/81 S. Herbst
   Modified 10/31/83 by C Spitzer. add cleanup handlers.
*/
/*   parameters */

dcl  arg_increment fixed bin;				/* increment for resequencing */
dcl  code fixed bin (35);				/* fast error code */
dcl  edit_ptr ptr;					/* ptr to structure with edit information */
dcl  next_number fixed bin;				/* numbers generated for input must be less than this */
dcl  new_string char (*) var;				/* replacement string for change entry */
dcl  num_chars fixed bin (21);			/* number of characters in block to be moved */
dcl  old_string char (*) var;				/* old string for change entry */
dcl  seg char (*);					/* contents of segment to be inserted */
dcl  seq_number fixed bin;				/* first vaule for renumbering */
dcl  start fixed bin (21);				/* index in text of block to be moved */
dcl  table_ptr ptr;					/* ptr to basic_rsq_table */
dcl  table_1_ptr ptr;				/* ptr to 1st table for MERGE */
dcl  table_2_ptr ptr;				/* ptr to  2nd table for MERGE */
dcl  target fixed bin (21);				/* index in text before the new location of block */
dcl  temp_length fixed bin (21);			/* number of characters in modified version of text */

/* automatic */

dcl  change_ok bit (1) unal;				/* ON if change is allowed */
dcl  check bit (1) unal;				/* ON to prevent substitution of line numbers */
dcl  check_null bit (1) unal;				/* ON to prevent forming a line number with a null string  */
dcl  done bit (1) unal;
dcl  i fixed bin (21);
dcl  increment fixed bin;
dcl  j fixed bin (21);
dcl  len_new_string fixed bin;			/* number of characters in newstring */
dcl  len_old_string fixed bin;			/* number  of characters in old_string */
dcl  last_index fixed bin (21);			/* index in text of last character copied into temp */
dcl  number_pic pic "99999";
dcl  number_pic_blank pic "99999vb";
dcl  temp_ptr ptr;

/* based */

dcl 1 basic_rsq_table aligned based (table_ptr),
    2 num_lines fixed bin,
    2 t (basic_rsq_table.num_lines) aligned,
      3 old_number fixed bin (17) unal,
      3 new_number fixed bin (17) unal;
dcl 1 f aligned based (edit_ptr) like fst_edit_info;
dcl  ptr_array (1) ptr based;
dcl  text char (f.text_length) based (f.text_ptr);
dcl  temp char (f.max_seg_size) based (temp_ptr);

/* constants */

dcl  check_line_number bit (1) unal int static options (constant) init ("1"b); /* ON if line numbers should be checked.
						   OFF if only line references are checked */
dcl  conditional bit (1) unal int static options (constant) init ("1"b); /* ON if renumber to prevent overlap.
						   OFF must renumber */
dcl  DIGIT char (10) int static init ("0123456789");
dcl  NEW_LINE char int static init ("
");
dcl  max_line_num fixed bin int static options (constant) init (99999);

dcl (addr, addrel, index, substr, verify, length, mod, null, reverse) builtin;
dcl  cleanup condition;

/* external */

dcl  dfast_basic_resequence_ entry (fixed bin (21), ptr, char (*), bit (1) unal, ptr, fixed bin (21), fixed bin (35));
dcl  fst_cv_line_num_ entry (char (*), fixed bin, fixed bin (35)) returns (bit (1));
dcl  ioa_ entry options (variable);
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$user_input ptr ext;
dcl  iox_$user_output ptr ext;
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));

/*  */
%include fst_edit_info;
%include dfast_error_codes;
/*  */
/*  This entry resequences the temporary text.
*/
resequence: entry (edit_ptr, seq_number, arg_increment, temp_length, code);

	temp_length = 0;
	increment = arg_increment;
	temp_ptr = f.alt_ptr;
	if f.basic_source then do;
	     table_ptr = null;

	     on cleanup begin;
		if table_ptr ^= null then call release_temp_segments_ ("fst_util_", addr (table_ptr) -> ptr_array, code);
		end;

	     call get_temp_segments_ ("fst_util_", addr (table_ptr) -> ptr_array, code);
	     if code = 0 then do;
		basic_rsq_table.num_lines = 0;
		call fill_basic_table (^conditional, text);
		if code = 0 then call dfast_basic_resequence_ (f.max_seg_size, table_ptr, text,
		     "1"b, temp_ptr, temp_length, code);
	     end;

	     if table_ptr ^= null then call release_temp_segments_ ("fst_util_", addr (table_ptr) -> ptr_array, (0));
	end;

	else call renumber (^conditional, text);

	return;

/*   */
/*  This entry inserts the segment "seg" into the temporary text after location start -1.  The segment to be
   inserted is resequenced beginning with seq_number and incrementing by 10 to derive subsequent numbers.  If
   the segment is inserted before the end of the temporary text, the text following seg will be resequenced, if
   necessary, to prevent overlap.
*/
merge:	entry (edit_ptr, seg, start, seq_number, temp_length, code);

	temp_ptr = f.alt_ptr;
	temp_length = 0;
	increment = 10;
	seq_number = seq_number + increment - mod (seq_number, increment);
	if f.basic_source then do;
	     table_ptr = null;

	     on cleanup begin;
		if table_ptr ^= null then call release_temp_segments_ ("fst_util_", addr (table_ptr) -> ptr_array, code);
		end;

	     call get_temp_segments_ ("fst_util_", addr (table_ptr) -> ptr_array, code);
	     if code = 0 then do;
		basic_rsq_table.num_lines = 0;

/* There is no temporary text or the new segment is put at the end so the temporary text doesn't need to be changed. */

		if f.text_length = 0 | start > f.text_length then do;
		     if f.text_length > 0 then call copy (text);
		     call fill_basic_table (^conditional, seg);
		     call copy_rsq (check_line_number, seg);
		end;

/* segment is inserted at the beginning. */

		else if start = 1 then do;
		     call fill_basic_table (^conditional, seg);
		     if code = 0 then do;
			call copy_rsq (check_line_number, seg);
			if code = 0 then do;
			     basic_rsq_table.num_lines = 0;
			     call fill_basic_table (conditional, text);
			     if code = 0 then call copy_rsq (check_line_number, text);
			end;
		     end;
		end;

/* segment is inserted in the middle. */

		else do;
		     table_1_ptr = table_ptr;
		     call fill_basic_table (^conditional, seg);
		     if code = 0 then do;
			table_2_ptr, table_ptr = addrel (addr (basic_rsq_table.t (basic_rsq_table.num_lines).old_number), 1);
			call fill_basic_table (conditional, substr (text, start, f.text_length - start + 1));

/* If the text didn't have to resequenced, it can be copied. */

			if table_2_ptr -> basic_rsq_table.num_lines = 0 then do;
			     call copy (substr (text, 1, start -1));
			     table_ptr = table_1_ptr;
			     call copy_rsq (check_line_number, seg);
			     call copy (substr (text, start, f.text_length - start + 1));
			end;

/* text has to edited for line number reference changes. */

			else do;
			     call copy_rsq (^check_line_number, substr (text, 1, start-1));
			     table_ptr = table_1_ptr;
			     call copy_rsq (check_line_number, seg);
			     table_ptr = table_2_ptr;
			     call copy_rsq (check_line_number, substr (text, start, f.text_length - start + 1));
			end;
		     end;
		end;
	     end;
	     if table_ptr ^= null then call release_temp_segments_ ("fst_util_", addr (table_ptr) -> ptr_array, (0));
	end;
	else do;
	     if start > 1 then call copy (substr (text, 1, start -1));
	     call renumber (^conditional, seg);
	     if code = 0 then do;
		if start <= f.text_length then call renumber (conditional, substr (text, start,
		     f.text_length - start + 1));
	     end;
	end;
	return;

/*  */
/* This entry moves a block of lines to a new location (target + 1) in the temporary text.  The block of lines
   that are moved are resequenced beginning with seq_number and incrementing by 10.  Lines following the new location
   of the moved lines will be resequenced, if necessary to prevent overlap
   The block is not empty and there is no overlap of the target and the block.
   *
   *
   *			___________			___________
   *		1	|	|		1	|	|
   *			|	|			|	|
   *			___________			___________
   *		target	|	|		start	|/////////|
   *			|	|			|/////////|
   *			___________			___________
   *		start	|/////////|	start+num_chars	|	|
   *			|/////////|			|	|
   *			___________			___________
   *	  start+num_chars	|	|		target	|	|
   *			|	|			|	|
   *			___________			___________
   *	  f.text_length			f.text_length
*/
move:	entry (edit_ptr, start, num_chars, target, seq_number, temp_length, code);

	temp_ptr = f.alt_ptr;
	temp_length = 0;
	increment = 10;
	seq_number = seq_number + increment - mod (seq_number, increment);
	if f.basic_source then do;
	     table_ptr = null;

	     on cleanup begin;
		if table_ptr ^= null then call release_temp_segments_ ("fst_util_", addr (table_ptr) -> ptr_array, code);
		end;

	     call get_temp_segments_ ("fst_util_", addr (table_ptr) -> ptr_array, code);
	     if code = 0 then do;
		call fill_basic_table (^conditional, substr (text, start, num_chars));
		if target < start then do;
		     if start - target - 1 > 0 then call fill_basic_table (conditional, substr (text, target+1,
			start - target - 1));
		     i = start + num_chars;
		     if i <= f.text_length then call fill_basic_table (conditional, substr (text, i,
			f.text_length - i + 1));

		     if target > 0 then call copy_rsq (^check_line_number, substr (text, 1, target));
		     call copy_rsq (check_line_number, substr (text, start, num_chars));
		     if start - target -1 > 0 then call copy_rsq (check_line_number, substr (text, target+1,
			start - target - 1));
		     if i <= f.text_length then call copy_rsq (check_line_number, substr (text, i, f.text_length - i + 1));
		end;
		else do;
		     if target < f.text_length then
			call fill_basic_table (conditional, substr (text, target+1, f.text_length - target));

		     if start > 1 then call copy_rsq (^check_line_number, substr (text, 1, start -1));
		     i = start + num_chars;
		     if i <= target then call copy_rsq (^check_line_number, substr (text, i, target - i + 1));
		     call copy_rsq (check_line_number, substr (text, start, num_chars));
		     if target < f.text_length then call copy_rsq (check_line_number, substr (text, target + 1,
			f.text_length - target));
		end;

		if table_ptr ^= null then call release_temp_segments_ ("fst_util_", addr (table_ptr) -> ptr_array,
		     (0));
	     end;
	end;

	else do;
	     if target < start then do;
		if target > 0 then call copy (substr (text, 1, target));
		call renumber (^conditional, substr (text, start, num_chars));
		if start - target - 1 > 0 then call renumber (conditional, substr (text, target +1, start - target - 1));
		i = start + num_chars;
		if i <= f.text_length then call renumber (conditional, substr (text, i, f.text_length - i + 1));
	     end;
	     else do;
		if start > 1 then call copy (substr (text, 1, start - 1));
		i = start + num_chars;
		if i <= target then call copy (substr (text, i, target - i +1));
		call renumber (^conditional, substr (text, start, num_chars));
		if target < f.text_length then call renumber (conditional, substr (text, target+1, f.text_length - target));
	     end;
	end;

	return;

/*  */
/* * This entry replaces old_string with new_string within a block of lines.  A check to prevent changing line
   * number is made if:
   *
   *	1.  old_string begins with a digit:
   *		c/20/y/
   *		20 x = 20 	->	20 x = y
   *
   *	2.  new_string begins with a digit:
   *		c/ x/0/
   *		20 x = x		->	20 x =0
   *
   *	3.  new_string is null:
   *		c/  //
   *		20  40  50	->	20  4050
*/
change:	entry (edit_ptr, start, num_chars, old_string, new_string, temp_length, code);

	len_new_string = length (new_string);
	len_old_string = length (old_string);
	temp_ptr = f.alt_ptr;

/* set up checks if old_string or new_string begins with a digit or new_string is null. */

	change_ok = "1"b;
	
	if len_new_string = 0 then do;
	     if len_old_string = 0 then check = "0"b;
	     else  check = (verify (substr (old_string, 1, 1), DIGIT) = 0);
	end;
          else if len_old_string ^= 0 then check = (verify (substr (old_string, 1, 1), DIGIT) = 0) | (verify (substr (new_string, 1, 1), DIGIT) = 0);
	else check = (verify (substr (new_string, 1, 1), DIGIT) = 0);

	check_null = (len_new_string = 0);


	last_index = 0;
	do while (num_chars > 0);
	     i = index (substr (text, start, num_chars), old_string) -1;
	     if i > -1 then do;

/* The check verifies back for the first non-digit.  If this is a new_line character or the start of the text,
   the change is not allowed.  In the following case replacement is not allowed.
   *
   *	c /25/30/		abcdefgh(nl)1025 abc	(nl) = new line  character
   *			|
   *			start		(i = 12, j = 4)
*/
		if check | check_null then do;
		     j = verify (reverse (substr (text, 1, start+ i -1)), DIGIT);
		     if j > 0 then do;
			change_ok = (substr (text, start + i - j, 1) ^= NEW_LINE);
		     end;
		     else change_ok = "0"b;		/* all characters were digits (1st line) */

/* This check overrides the previous one, if: 1) the second string was null, 2) the first string did not begin
   with a digit and 3) the concationation will not form a line number.
   *
   *	c /ab//	 for "20abc"	-> "20c"		overrides
   *		 for "20ab7"	-> "20ab7"	doesn't override previous check
*/
		     if check_null & ^check then do;
			if verify (substr (text, start + i + len_old_string, 1), DIGIT) > 0 then change_ok = "1"b;
		     end;
		end;

		if change_ok then do;
		     num_chars = num_chars - i - len_old_string;
		     i = start + i -1;
		     if i > last_index then call copy (substr (text, last_index + 1, i - last_index));
		     if temp_length + len_new_string <= f.max_seg_size then do;
			substr (temp, temp_length + 1, len_new_string) = new_string;
			temp_length = temp_length + len_new_string;
			last_index = i + len_old_string;
			start = last_index + 1;
		     end;
		     else code = error_max_size;
		end;
		else do;
		     change_ok = "1"b;
		     start = start + i + 1;
		     num_chars = num_chars - i - 1;
		end;
	     end;

	     else num_chars = 0;
	end;

	if last_index = 0 then code = error_no_string;
	else if last_index < f.text_length then call copy (substr (text, last_index+1, f.text_length - last_index));

	return;

/*   */
/* * This entry implements input mode:  a line number is printed and the user completes the line.
   * This mode is terminated when:
   *
   *	1.  The user types a line with only the new_line character.
   *	2.  The next input line number would be equal or exceed next_number.
*/
input:	entry (edit_ptr, start, seq_number, arg_increment, next_number, temp_length, code);

	temp_ptr = f.alt_ptr;
	increment = arg_increment;
	seq_number = seq_number + increment - mod (seq_number, increment);


	if start > 1 then call copy (substr (text, 1, start -1));

	done = "0"b;
	do while (seq_number < next_number & ^done);
	     number_pic_blank = seq_number;
	     call iox_$put_chars (iox_$user_output, addr (number_pic_blank), length (number_pic_blank), code);
	     call copy ((number_pic_blank));
	     call iox_$get_line (iox_$user_input, addr (substr (temp, temp_length + 1, 1)), 150, i, code);
	     if code = 0 then do;
		if i = 1 then do;
		     temp_length = temp_length - 6;	/* remove last number and blank */
		     seq_number = seq_number - increment;
		     done = "1"b;
		end;
		else temp_length = temp_length + i;
	     end;
	     else done = "0"b;
	     seq_number = seq_number + increment;
	end;

	if code = 0 then do;
	     if start <= f.text_length then call copy (substr (text, start, f.text_length - start + 1));
	     else f.end_line_number = seq_number - increment;
	     if ^done then call ioa_ ("end of input mode.  Next line number is  ^d", next_number);
	end;

	return;


/*  */
/*  This procedure copies text from seg into the temporary buffer temp.  It renumbers the lines.

   1.  If the line begins with a number, the number is replaced.
   2.  If the line does not begin with a number, a number is added.
*/

renumber:	proc (conditional, seg);


dcl  conditional bit (1) unal;			/* ON if renumber only if necessary */
dcl  seg char (*);


dcl  line_start fixed bin (21);			/* index of line to be copied */
dcl  num_chars fixed bin (21);			/* length of line without number */
dcl  i fixed bin (21);
dcl  len fixed bin (21);
dcl  num fixed bin;


	     len = length (seg);
	     line_start = 1;

	     do while (line_start <= len & code = 0);
		i = verify (substr (seg, line_start), DIGIT) - 1;
		if i = -1 then line_start = len + 1;
		else do;
		     if conditional & i > 0 then do;
			if fst_cv_line_num_ (substr (seg, line_start, i), num, code) then do;
			     if num > seq_number then do;
				call copy (substr (seg, line_start, len - line_start + 1));
				return;
			     end;
			end;
		     end;
		     line_start = line_start + i;
		     num_chars = index (substr (seg, line_start), NEW_LINE);
		     if num_chars = 0 then num_chars = len - line_start + 1;
		     if seq_number <= max_line_num then do;
			number_pic = seq_number;
			call copy ((number_pic));
			call copy (substr (seg, line_start, num_chars));
			line_start = line_start + num_chars;
			seq_number = seq_number + increment;
		     end;
		     else code = error_edit_max_num;
		end;
	     end;

	     return;
	end renumber;


/*  */
/* This procedure copies the segment into the temporary buffer.
*/
copy:	proc (seg);

dcl  seg char (*);

dcl  i fixed bin (21);

	     i = length (seg);
	     if i > 0 then do;
		if temp_length + i <= f.max_seg_size then do;
		     substr (temp, temp_length + 1, i) = seg;
		     temp_length = temp_length + i;
		end;
		else code = error_max_size;
	     end;

	     return;

	end copy;


/* *  This procedure calls dfast_basic_resequence_ which edits seg to use the new line numbers in the table.
   *  The output is is stored in temp.
   *
   *	check_line_numbers	= "1"b	ON if line numbers should be edited also.
   *			= "0"b	OFF if only line number references are changed.
*/
copy_rsq:	proc (check_line_numbers, seg);

dcl  check_line_numbers bit (1) unal;
dcl  seg char (*);

	     call dfast_basic_resequence_ (f.max_seg_size, table_ptr, seg, check_line_numbers, temp_ptr, temp_length,
		code);

	     return;

	end copy_rsq;

/*  */
/* * This procedure adds to a table to be used to resequence a basic source segment.  It uses these global variables:
   *
   *	table_ptr		ptr to table
   *	num_lines		number of lines in table
   *	seq_number	new_number
   *	increment		value to derive subsequent numbers
   *
   * If conditional is set, it puts the number in the table only if it is less than the seq_number.
*/
fill_basic_table: proc (conditional, seg);

dcl  conditional bit (1) unal;
dcl  seg char (*);

/* automatic */

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

	     start = 1;
	     do while (start <= length (seg) & code = 0);
		i = verify (substr (seg, start), DIGIT) - 1;
		if i > 0 then do;
		     if fst_cv_line_num_ (substr (seg, start, i), old_num, code) then do;

/* conditional test.  If the next number is greater or equal to the sequence number, no more lines need to be added to
   the table.
*/
			if conditional then if old_num >= seq_number then return;

			basic_rsq_table.num_lines = basic_rsq_table.num_lines + 1;

			basic_rsq_table.t (basic_rsq_table.num_lines).old_number = old_num;
			basic_rsq_table.t (basic_rsq_table.num_lines).new_number = seq_number;
			seq_number = seq_number + increment;
			start = start + i;
			i = index (substr (seg, start), NEW_LINE);
			if i = 0 then i = length (seg) - start + 1;
			start = start + i;
		     end;
		end;
		else code = error_un_num_text;
	     end;

	     return;

	end fill_basic_table;

     end fst_util_;


		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved