



		    dfast_.pl1                      11/05/82  1316.6rew 11/04/82  1552.0      236079



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
dfast_: proc (person_id, arg_home_dir, project_id, tty_line_id, logout_arg);

/*  This procedure is the listener for DFAST as well as the  parser for edit commands.  */

dcl  arg_home_dir char (*);				/* home directory from pit */
dcl  project_id char (*);				/* project_id for tty command */
dcl  tty_line_id char (*);				/* tty line */
dcl  logout_arg char (*);				/* = "hold" for HELLO */
dcl  person_id char (*);				/* name at login */


/* constants */

dcl  command_names char (148) int static options (constant) init
    ("com,edi,lis,tty,bri,nbr,sor,ren,new,uns,sav,rep,old,bui,app,ign,scr,use,bye,goo,hel,PUN,bil,len,sys,exp,ful,hal,one,two,TAP,KEY,DIR,typ,run");

/* *   1   2   3   4   5   6   7   8   9   10  11  12  13  14  15  16  17  18  19  20  21  22  23  24  25  26  27  28  29 30  31  32  33  34  35 */

dcl  READ fixed bin init (1) int static options (constant); /* directory_:  read into the current segment. */
dcl  SAVE fixed bin init (2) int static options (constant); /* directory_:  store only if the segment does not exist. */
dcl  REPLACE fixed bin init (3) int static options (constant); /* directory_:  store only if the segment does exist. */
dcl  DELETE fixed bin init (4) int static options (constant); /* directory_:  delete the segment */
dcl  TRUNCATE fixed bin init (6) int static options (constant); /* directory_:  truncate the segment. */
dcl  APPEND fixed bin init (1) int static options (constant); /* edit_:  append alter to current segment */
dcl  SORT fixed bin init (2) int static options (constant); /* edit_:  merge alter and current and sort */
dcl  BUILD fixed bin int static options (constant) init (5); /* edit_:  append to current segment */
dcl  ALTER fixed bin int static options (constant) init (6); /* edit_:  append to alter segment */
dcl  LENGTH fixed bin int static options (constant) init (7); /* edit_:  merge temporary segments and give length */
dcl  arg_delimit char (4) int static options (constant) init ("	 ,;"); /* tab blank comma semi-colon */
dcl  dfast_name char (5) int static options (constant) init ("dfast");
dcl  white_space char (2) int static options (constant) init ("	 "); /* tab blank */
dcl  character_set char (68) int static options (constant) init (">._-0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 	");
dcl  digit char (10) defined (character_set) pos (5);	/* digits */
dcl  letter char (52) defined (character_set) pos (15);	/* letters */
dcl  name_char char (68) defined (character_set) pos (1);	/* legal segment name characters */
dcl  lowercase_letters char (26) defined (character_set) pos (15);
dcl  uppercase_letters char (26) defined (character_set) pos (41);

/* automatic */

dcl  input char (256);
dcl  input_length fixed bin;				/* line length without the new-line */
dcl  arg char (256) var;
dcl  ready bit (1);					/* ON if ready message should be printed */
dcl (length, index, verify, substr, addr, divide, search, null, translate) builtin;
dcl (i, num_1, request) fixed bin;
dcl  header bit (1) unal;				/* ON = list with header  */
dcl  sort bit (1) unal;				/* dfast_line_edit_: ON sort; OFF no sort */
dcl  string char (256) var;
dcl  code fixed bin (35);

dcl  quit condition;


/* external */

dcl  clock_ entry () returns (fixed bin (71));
dcl  condition_ entry (char (*), entry);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  error_table_$long_record fixed bin (35) ext;
dcl  dfast_command_processor_ entry (ptr, char (*), char (*), fixed bin (35));
dcl  dfast_compile_ entry (ptr, fixed bin (35));
dcl  dfast_directory_ entry (fixed bin, char (*), ptr, ptr, fixed bin (35));
dcl  dfast_edit_ entry (fixed bin, char (*),  ptr, fixed bin (35));
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  dfast_explain_ entry (char (*) var, char (*), fixed bin (35));
dcl  dfast_line_edit_ entry (char (256) var, ptr, bit (1) unal, fixed bin (35));
dcl  dfast_list_ entry (ptr, char (*), fixed bin, bit (1) unal, bit (1) unal, fixed bin (35));
dcl  dfast_merge_ entry (bit (1), ptr, fixed bin (35));
dcl  fast_related_data_$in_fast_or_dfast bit (1) aligned ext;
dcl  fast_related_data_$in_dfast bit (1) aligned ext;
dcl  dfast_run_ entry (ptr, fixed bin (35));
dcl  dfast_set_system_ entry (char (256) var, bit (1) unal, char (*), fixed bin (35));
dcl  dfast_terminal_control_ entry (fixed bin, char (*), ptr, fixed bin (35));
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  hmu entry options (variable);
dcl  ioa_$ioa_switch entry options (variable);
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin, 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_input ptr ext static;
dcl  iox_$user_output ptr ext static;
dcl  resource_usage entry ();

dcl  sys_info$max_seg_size fixed bin (35) ext;

dcl  edit_info_ptr ptr;
dcl 1 f aligned like dfast_edit_info;
%include dfast_edit_info;
%include dfast_error_codes;
/*  */

	call initial;
	if code ^= 0 then return;
	on quit begin;
	     ready = "1"b;
	     call iox_$control (iox_$user_input, "resetread", addr (input), code);
	     call ioa_$ioa_switch (iox_$user_output, "QUIT^/");
	     goto READY;
	end;
	call condition_ ("any_other", any_other_handler);

/* * This  loop prints the ready message and reads a line from the terminal.  These conventions are used:
   *
   *	1.  Special case the BUILD mode.
   *		a.  If the line contains only a new_line character, BUILD  mode is terminated.
   *		b.  Otherwise the line is appended to the end of the current_file.
   *	2.  Blank lines are ignored.
   *	3.  Text lines begin with a digit  and are stored in temporary segment alt to  be merged later.
   *	4.  Command lines:
   *		a.  Single command lines begin with an alphabetic character.  Only the first three characters
   *		    are used.
   *		b.  Multi-command lines begin with any character except a digit or an alphabetic charcter.
   *		    (ie.  /tty/run/lis  )
*/

READY:
	do while ("1"b);
	     if ready then do;
		call date_time_ (clock_ (), input);
		call ioa_$ioa_switch (iox_$user_output, "ready  ^a^/", substr (input, 11, 4));
	     end;
	     ready = "0"b;

	     call iox_$get_line (iox_$user_input, addr (input), 256, input_length, code);

	     if code ^= 0 then do;
		if code = error_table_$long_record then call dfast_error_ (error_long_rec, "", "");
	     end;

	     else if f.build_mode then do;
		if input_length = 1 then do;
		     f.build_mode = "0"b;
		     ready = "1"b;
		end;

		else call dfast_edit_ (BUILD, substr (input, 1, input_length), edit_info_ptr, code);
	     end;

	     else do;
		i = verify (substr (input, 1, input_length -1), white_space);

		if i > 0 then do;
		     if index (digit, substr (input, i, 1)) > 0
		     then call dfast_edit_ (ALTER, substr (input, i, input_length - i + 1), edit_info_ptr, code);

		     else do;			/* command */
			if ^f.brief_mode then ready = "1"b;

			if index (letter, substr (input, i, 1)) > 0
			then call command (substr (input, i, input_length - i), code);
			else call multi_command ((i));
		     end;
		end;
	     end;

	end;

RETURN:	return;

/*  */

/*   This procedure is used to find the next argument on the line.  It expects the form:

   [blank | tab] [argument] [blank | tab | comma | semi-colon]

   Any of the fields may be null.  If no argument and no delimitor is found, then the procedure returns "0"b.
   Otherwise "1"b is returned.
*/
get_arg:	proc (line, argument) returns (bit (1));

dcl  argument char (256) var;				/* next argument (output) */

dcl  line char (256) var;				/* input buffer */
dcl  line_length fixed bin;				/* length of line on input */
dcl  argument_length fixed bin;			/* length of argument */
dcl  start fixed bin;				/* index in line of start of argument */

	     line_length = length (line);

	     if line_length > 0 then do;

		start = verify (line, white_space);
		if start > 0 then do;
		     argument_length = search (substr (line, start), arg_delimit);

		     if argument_length = 0 then argument_length = line_length - start + 1;
		     else argument_length = argument_length - 1;
		     argument = substr (line, start, argument_length);
		     start = start + argument_length + 1; /* move beyond the argument delimitor */
		     if start > line_length then line = "";
		     else line = substr (line, start, line_length - start + 1);

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

/*  */
line_number: proc (string, num) returns (bit (1));
dcl  string char (*) var;
dcl  num fixed bin;

	     num = cv_dec_check_ ((string), code);
	     if code = 0 then do;
		if num > 0 then return ("1"b);
		else call dfast_error_ (error_bad_line, "", (arg));
	     end;
	     else return ("0"b);
	end line_number;


/*  */
/*  This procedure parses the line for a pathname and verifies that it contains legal characters.
   If the name is not found and request is set, the user is queried for a name.
   *
   *	Code	     Pathname	Explaination
   *
   *	0	     ^= ""	A legal pathname was found and is returned.
   *	0	     = ""		No pathname was given and the query was not requested.
   *	bad_name	     (not set)	The pathname given contained one or more illegal characters.
   *	name_miss      (not set)	The name was not given on the line or with the query and request was set.
*/
get_name:	proc (line, name, request, code);

dcl  line char (256) var;
dcl  name char (*) var;				/* pathname (output) */
dcl  request bit (1);				/* ON if should request name (input) */
dcl  code fixed bin (35);

	     if ^get_arg (line, arg) then do;
		if ^request then do;
		     name = "";
		     return;
		end;

		call get_user_response ("0"b, "enter name: ", arg);
		if arg = "" then code = error_name_miss;
	     end;

	     if code = 0 then do;
		if verify (arg, name_char) > 0 then code = error_bad_name;
		else name = arg;
	     end;

	     if code ^= 0 then if code ^= error_name_miss then call dfast_error_ (code, dfast_name, (arg));

	     return;

	end get_name;

/*  */
/*  This command parses the command line for a command and executes it.  It returns code:

   *	   code = 0	The command was successfully completed or was a null command.
   *	   code ^= 0	An error prevented the command from being completed.
*/
command:	proc (line, code);

dcl  line char (256) var;
dcl  code fixed bin (35);

	     if get_arg (line, arg) then do;
		arg = translate (arg, lowercase_letters, uppercase_letters);
		if length ((arg)) > 2 then do;
		     request = index (command_names, substr (arg, 1, 3));
		     if request ^= 0 then do;
			request = divide (request +3, 4, 17);
			goto command_label (request);
		     end;
		end;
		call dfast_command_processor_ (edit_info_ptr, (arg), (line), code);
	     end;

	     return;


/*  */
/* *	compile	[fortran | basic]
*/
command_label (1):

	     if get_arg (line, arg) then call set_system (code);
	     if code = 0 then call dfast_compile_ (edit_info_ptr, code);
	     return;

/* *	edit	<request>		[<request argument>]
*/

command_label (2):
	     if arg = "editns" | arg = "edins" then sort = "0"b;
	     else sort = "1"b;

	     call dfast_line_edit_ (line, edit_info_ptr, sort, code);
	     return;


/* list:  omit header if user is in brief_mode or request was lisn, lisnh, listnh
   [alt | cur] [<line no.>] [<line no.>]
*/
command_label (3):

	     if f.brief_mode then header = "0"b;
	     else if substr (arg, length (arg), 1) = "n" then header = "0"b;
	     else if substr (arg, length (arg) -1, 2) = "nh" then header = "0"b;
	     else header = "1"b;

	     call parse_list_punch (line, header, "0"b);

	     return;

/* tty */
command_label (4):

	     if f.basic_system then if f.dbasic then string = "dbasic";
		else string = "basic";
	     else string = "fortran";
	     call ioa_$ioa_switch (iox_$user_output, "name = ^a,  system = ^a,  user = ^a.^a,  line = ^a",
		f.current_name, string, person_id, project_id, tty_line_id);

	     return;

/* brief */
command_label (5):
	     f.brief_mode = "1"b;
	     ready = "0"b;

	     return;

/* nbrief */
command_label (6):

	     f.brief_mode = "0"b;
	     return;

/* sort */
command_label (7):

	     call dfast_edit_ (SORT, "", edit_info_ptr, code);
	     return;

/* *	rename	[<name>]
   *	new	[<name>]
*/
command_label (8):
command_label (9):

	     call get_name (line, string, "1"b, code);
	     if code = 0 then do;
		if index (string, ">") = 0 then do;
		     f.current_name = string;
		     call dfast_set_system_ (f.current_name, f.basic_system, "", 0); /* ignore code:  OK if no suffix */
		end;
		else do;
		     code = error_bad_name;
		     call dfast_error_ (code, "name", (string));
		end;
	     end;
	     else if code = error_name_miss then code = 0; /* ignore a chage of mind by user */
	     if request = 9 then call reset_edit_info;

	     return;



/* *	unsave	[<pathname>]
*/
command_label (10):

	     call segment_control (line, DELETE);
	     return;

/*	save	[<pathname>]
*/
command_label (11):

	     call segment_control (line, SAVE);
	     return;

/* *	replace	[<pathname>]
*/
command_label (12):

	     call segment_control (line, REPLACE);
	     return;

/* *	old	[<pathname>]          [<system name>]
*/
command_label (13):

	     call segment_control (line, READ);
	     if code = 0 then do;
		if f.source_segment then do;
		     call dfast_set_system_ (f.current_name, f.basic_system, "", code);
		     if code ^= 0 then do;
			code = 0;
			if get_arg (line, arg) then call set_system (code);
			else do;
			     call get_user_response ("0"b, "enter system name: ", arg);
			     call set_system (code);
			     do while (code ^= 0);
				call get_user_response ("1"b, "answer 'basic', 'dbasic', or 'fortran': ", arg);
				call set_system (code);
			     end;
			end;
		     end;
		end;
	     end;
	     return;

/* build */
command_label (14):

	     if ^f.source_segment then call dfast_error_ (error_obj_nop, "build", "");
	     else do;
		if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code);
		if code = 0 then f.build_mode = "1"b;
	     end;

	     return;

/*  append */
command_label (15):

	     call dfast_edit_ (APPEND, "", edit_info_ptr, code);
	     return;

/* ignore */
command_label (16):

	     f.alter_length = 0;
	     return;

/* scratch */
command_label (17):

	     if verify (line, white_space) = 0 then call reset_edit_info;
	     else call segment_control (line, TRUNCATE);

	     return;


/*  user */
command_label (18):

	     call hmu ();
	     return;

/* bye and goodbye */
command_label (19):
command_label (20):

	     logout_arg = "";
	     call bye_request;
	     return;


/* *	hello
   *
   *	help
*/
command_label (21):

	     if arg = "hello" then do;
		logout_arg = "-hold";
		call bye_request;
		return;
	     end;

	     else call dfast_explain_ ("", "help", code);
	     return;

/* punch */
command_label (22):

	     call parse_list_punch (line, "0"b, "1"b);
	     return;


/* bill */
command_label (23):

	     call resource_usage;
	     return;

/* length */
command_label (24):

	     call dfast_edit_ (LENGTH, "", edit_info_ptr, code);
	     return;

/* *	system	[fortran | basic]
*/
command_label (25):

	     if ^get_arg (line, arg) then call get_user_response ("1"b, "enter system: ", arg);

	     call set_system (code);

	     return;

/* *	explain	<topic>
*/
command_label (26):

	     call dfast_explain_ (line, "explain", code);
	     return;

/*  These commands change the input/output mode of the terminal.  The order is important.
   *
   *	(27)	fullduplex
   *	(28)	halfduplex
   *	(29)	one_case
   *	(30)	two_case
   *	(31)	tape
   *	(32)	keyboard
   *	(33)	direct
*/
command_label (27):
command_label (28):
command_label (29):
command_label (30):
command_label (31):
command_label (32):
command_label (33):

	     call dfast_terminal_control_ (request - 26, "", edit_info_ptr, code);
	     if request = 33 then ready = "1"b;
	     return;

/* *	type	<terminal_type>
   *
   *		<terminal_type>  ::=  tn300 | tty37 | tty33
*/
command_label (34):

	     if ^get_arg (line, arg) then arg = "";
	     call dfast_terminal_control_ (request - 26, (arg), edit_info_ptr, code);
	     return;

/* *	run	[fortran | basic]
*/
command_label (35):

	     if get_arg (line, arg) then call set_system (code);
	     if code = 0 then call dfast_run_ (edit_info_ptr, code);
	     return;

	end command;

/*  */
/*  This procedure is used to read into or store from the current segment and to delete segments
   If a pathname is given on the line, it is used.  Otherwise the current name is used.
   If no pathname is given and the current name is "no name", then and error message is printed and an error
   code is returned.
*/

segment_control: proc (line, action);

dcl  line char (256) var;
dcl  action fixed bin;				/* directory_: read, save, replace, delete */
dcl  request bit (1);				/* get_name: ON if should request name */

	     if f.current_name = "no name" then request = "1"b;
	     else request = "0"b;

	     call get_name (line, string, request, code);

	     if code = error_name_miss then call dfast_error_ (code, dfast_name, "");
	     else if code = 0 then do;
		if string = "" then string = f.current_name;
		call dfast_directory_ (action, (string), edit_info_ptr, null, code);
		if action ^= DELETE then f.edit_done = "0"b;
	     end;

	     return;

	end segment_control;

/*  */
/* *  This procedure prints a message and then reads one line from user_input.  If the line contains
   *  at least one non_blank character, response is set and the procedure returns.  If a blank
   *  line is input, there are two actions depending on repeat:
   *
   *	"1"b	the message is printed again.
   *	"0"b	response is set to "" and the procedure returns
*/
get_user_response: proc (repeat, message, response);

dcl  repeat bit (1);				/* ON if should repeat for blank lines */
dcl  message char (*);
dcl  response char (*) var;				/* the response enterred by the user */

dcl  temp_buffer char (256);
dcl  amt_read fixed bin;				/* num_characters read */
dcl  start fixed bin;				/* index of start of response */
dcl  num_chars fixed bin;				/* number of characters in response */

	     response = "";

	     do while ("1"b);
		call iox_$put_chars (iox_$user_output, addr (message), length (message), code);
		call iox_$get_line (iox_$user_input, addr (temp_buffer), 256, amt_read, code);
		amt_read = amt_read - 1;
		if amt_read > 0 then do;
		     start = verify (substr (temp_buffer, 1, amt_read), white_space);
		     if start > 0 then do;
			num_chars = index (substr (temp_buffer, start, amt_read), white_space) -1;
			if num_chars = -1 then num_chars = amt_read - start + 1;
			response = substr (temp_buffer, start, num_chars);
			return;
		     end;
		end;

		if ^repeat then return;
	     end;

	end get_user_response;

/*  */
/* *	This procedure parses arg for a system name.  Only the first three letters are used.
   *	The system may be fortran or basic or dbasic.  The system can not be changed:
   *	     1.  If the current segment is object code.
   *	     2.  If the system would conflict with the current name.
*/
set_system: proc (code);

dcl  code fixed bin (35);
dcl  tag char (7);

	     string = substr (arg, 1, 3);
	     if f.source_segment then do;
		call dfast_set_system_ (f.current_name, f.basic_system, tag, (0));
		if string = "bas" | string = "dba" then do;
		     if tag = "fortran" then code = error_name_sys;
		     if code = 0 then do;
			f.basic_system = "1"b;
			if string = "dba" then f.dbasic = "1"b;
			else f.dbasic = "0"b;
		     end;
		end;

		else if string = "for" then do;
		     if tag = "basic" then code = error_name_sys;
		     if code = 0 then f.basic_system, f.dbasic = "0"b;
		end;
		else code = error_unkn_sys;
	     end;

	     else do;				/* Can't override system in object segment */
		if string = "bas" & f.basic_system & ^f.dbasic then;
		if string = "dba" & f.basic_system & f.dbasic then;
		else if string = "for" then if ^f.basic_system then;
		     else code = error_obj_nop;
	     end;

	     if code ^= 0 then do;
		if code = error_name_sys then arg = f.current_name;
		call dfast_error_ (code, "system", (arg));
	     end;

	     return;

	end set_system;

/*  */
/*  This procedure parses an input line with more than one command.  The first character
   on the line is the delimitor.  Null commands are legal.
*/

multi_command: proc (start);

dcl  start fixed bin;				/* index of input of command delimitor character */
dcl  command_delimitor char (1);			/* command delimitor character */
dcl  len fixed bin;					/* length of command */

	     command_delimitor = substr (input, start, 1);
	     start = start + 1;
	     input_length = input_length - 1;		/* drop the new-line character */

	     code = 0;
	     do while (start <= input_length & code = 0);

		len = index (substr (input, start, input_length - start + 1), command_delimitor);
		if len = 0 then len = input_length - start +2;
		call command (substr (input, start, len -1), code);

		start = start + len;
	     end;

	     return;

	end multi_command;

/*  */
/*  This code clears the edit info for the initialization and the scratch and new commands.
*/
reset_edit_info: proc;

	     f.current_length = 0;
	     f.alter_length = 0;
	     f.edit_done = "0"b;
	     f.source_segment = "1"b;

	     return;

	end reset_edit_info;

/*  */
/*  This procedure parses the arguments for the list and the punch commands.
   *
   *	list	<temporary segment id>	<line number>
   *	punch	<temporary segment id>	<line number>
   *
   *	     temporary segment id	= alt	list the alter file.
   *				= cur	list the current file.
   *				= ""	Merge the alter and current files and then list.
   *
   *	     line number n			List the file beginning with the line number n.
*/
parse_list_punch: proc (line, header, punch);

dcl  line char (256) var;
dcl  header bit (1) unal;				/* ON if should print header */
dcl  punch bit (1) unal;				/* ON if should punch;  OFF if should list */

	     num_1 = -1;				/* default is entire segment */
	     string = "";				/* default is merge with alter and then list */
	     if get_arg (line, arg) then do;
		string = substr (arg, 1, 3);
		if string = "cur" | string = "alt" then do;
		     if get_arg (line, arg) then do;
			if ^line_number (arg, num_1) then code = error_unknown_arg;
		     end;
		end;
		else do;
		     string = "";
		     if ^line_number (arg, num_1) then code = error_unknown_arg;
		end;

	     end;

	     if code = 0 then call dfast_list_ (edit_info_ptr, (string), num_1, header, punch, code);

	     else do;
		if punch then string = "punch";
		else string = "list";
		call dfast_error_ (code, (string), (arg));
	     end;

	     return;

	end parse_list_punch;

/*  */
bye_request: proc;


	     if f.edit_done | f.alter_length > 0 then do;
		call get_user_response ("0"b, "editing will be lost if you quit.  Do you want to quit ? ", arg);
		do while ("1"b);
		     if arg = "yes" | arg = "YES" then goto RETURN;
		     if arg = "no" | arg = "NO" then return;
		     call get_user_response ("1"b, "answer 'yes' or 'no': ", arg);
		end;
	     end;
	     goto RETURN;


	end bye_request;

/*  */
/*  This procedure sets up the PI handler and gets two scratch buffers in the process directory. */

initial:	proc;

dcl  ptr_array (2) ptr based;

	     code = 0;
	     edit_info_ptr = addr (f);
	     f.home_dir = arg_home_dir;
	     f.current_ptr = null;
	     call get_temp_segments_ (dfast_name, addr (f.current_ptr) -> ptr_array, code);
	     if code ^= 0 then call dfast_error_ (code, dfast_name, "current_segment");
	     f.max_seg_size = sys_info$max_seg_size;

	     f.current_name = "no name";
	     f.basic_system = "1"b;
	     f.brief_mode, f.build_mode = "0"b;
	     call reset_edit_info;

	     fast_related_data_$in_fast_or_dfast = "1"b;	/* switches for BASIC */
	     fast_related_data_$in_dfast = "1"b;


	     ready = "1"b;

	     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);

	     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 READY;
	     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 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;

	     goto READY;

	end any_other_handler;

     end dfast_;




		    dfast_command_processor_.pl1    11/05/82  1316.6rew 11/04/82  1644.1       95697



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
dfast_command_processor_: proc (edit_info_ptr, name, arg_line, code);

/* * This procedure is given a command name and a command line.  If the command is one of the Multics commands
   * allowed, a descriptor list is filled in and the command is called.
   *
   * Special casing is done for:
   *
   *	catalog	     This is mapped into a call to "list" and the error message is changed to use "catalog"
   *
   *	dprint	     If the -map options is dprinted, the uppercase segment name.map is created and dprinted.
*/

/* parameters */

dcl  edit_info_ptr ptr;
dcl  name char (*);					/* command name */
dcl  arg_line char (*);				/* user's command line */
dcl  code fixed bin (35);				/* error code */

/* automatic */
dcl  seg_ptr ptr;					/* pointer to original segment  for dprint_map problem */
dcl (start, num_chars) fixed bin;			/* start and number of characters in argument */
dcl  line_length fixed bin;				/* number of characters in line  */
dcl  i fixed bin;
dcl  command_index fixed bin;				/* index to procedure ptr */
dcl  delete_orig_segment bit (1);
dcl  arg_length (10) fixed bin;			/* temporarily holds argument lengths */
dcl 1 descriptors (10) aligned based (addr (al.pointers)),
    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, hbound, length, mod, null, rel, search, substr, verify) builtin;
dcl (bin, bit, divide, index, reverse, unspec) builtin;
dcl  dprint_change bit (1);
dcl  line char (256);
dcl  skip bit (1);
dcl  command_error condition;

/* internal static */

dcl  white_space char (2) int static options (constant) init ("	 ");		/* TAB BLANK */
dcl  command_names (14) char (15) int static options (constant) init ("catalog", "cat", "dprint", "dp", "set_tty", "stty", "delete_acl",
     "da", "set_acl", "sa", "list_acl", "la", "dpunch", "dpn");

/* based */

dcl  proc_ptr (14) ptr based (addr (entry_value (1)));

/* external */

dcl  cu_$gen_call entry (ptr, ptr);
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));
dcl  entry_value (7) entry init (list, dprint, set_tty, delete_acl, set_acl, list_acl, dpunch);
dcl (list, dprint, set_tty, delete_acl, set_acl, list_acl, dpunch) entry;
%include dfast_error_codes;

	code = 0;
	unspec (al) = "0"b;
	command_index = 0;
	do i = 1 to hbound (command_names, 1) while (command_index = 0);
	     if name = command_names (i) then command_index = i - mod (i+1, 2);
	end;

	if command_index > 0 then do;
	     num_args = 0;
	     line = arg_line;
	     line_length = length (arg_line);

	     delete_orig_segment = "0"b;
	     if command_names (command_index) = "dprint" then call dprint_map;

	     start = 1;

	     do while (get_arg (start, num_chars) & code = 0);
		if num_args < 10 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 code = error_max_args;
	     end;

	     if code = 0 then do;

		al.tag = "0000000000000000100"b;
		al.ndescs = num_args;

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

		if command_names (command_index) = "catalog" then on command_error call reformat;
		if command_names (command_index) = "dprint" then on command_error delete_orig_segment = "0"b;
		call cu_$gen_call (proc_ptr (command_index), addr (al.num_args));

	     end;
	end;
	else do;
	     code = error_bad_req;
	     call dfast_error_ (code, "", name);
	     return;
	end;

	if code ^= 0 & command_names (command_index) ^= "dprint" then call dfast_error_ (code, name, "");

	if delete_orig_segment then do;
	     if code = 0 then call hcs_$delentry_seg (seg_ptr, code);
	end;
RETURN:
	return;

/*  */
/*  This procedure gets the index of the next argument on the line.
   *
   *	"1"b	the argument was found
   *	"0"b	no arguments remain on the line
*/
get_arg:	proc (start, num_chars) returns (bit (1));

dcl  start fixed bin;				/* index on line of start of argument */
dcl  num_chars fixed bin;				/* number of characters */

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;
		start = line_length + 1;
		num_chars = 0;
	     end;

	     return ("0"b);

	end get_arg;

/*  */
/* This procedure reformats an error message for LIST so that FAST users think they are using a command called
   CATALOG */
reformat:	proc;

dcl  i fixed bin;
dcl  acode fixed bin (35);
dcl  length builtin;

dcl 1 cond_info aligned,
%include cond_info;
     dcl 1 info_structure aligned based (infoptr),
%include cond_info_structure;
    2 name_ptr ptr,
    2 name_lth fixed bin,
    2 err_mess_ptr ptr,
    2 err_mess_lth fixed bin,
    2 max_err_mess_lth fixed bin,
    2 print_sw bit (1);

dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));

	     cond_info.version = 1;
	     call find_condition_info_ (null, addr (cond_info), acode);
	     i = index (info_string, ":");
	     info_string = "catalog" || substr (info_string, i);
	     err_mess_lth = length (info_string);
	     err_mess_ptr = addr (substr (info_string, 1, 1));

	end reformat;

/*  */
/* *  If dprint is called with the -map option, the command line is reformated.  The new line
   *  has these changes:
   *
   *	seg_name		seg_name.map
   *	-map		""
   *	""		"-dl"
   *
   *  The original segment is copied and converted into an uppercase segment is the user's home directory.
   *  If the user requested deletion of the original segment, the segment is deleted after the dprint
   *  request is made.  (If dprint calls com_err_ then the segment is not deleted.)
*/
dprint_map: proc;

/* automatic */

dcl  temp_ptr ptr;					/* pointer to copy of segment */
dcl  seg_length fixed bin (21);			/* no. of characters in original segment */
dcl  pathname char (168) var;
dcl  directory char (168);
dcl  entry_name char (32);
dcl  bit_count fixed bin (24);
dcl  arg char (158) var;
dcl  new_line char (256);
dcl  new_line_length fixed bin ;
dcl  i fixed bin;
dcl  num_print fixed bin;

dcl (translate, substr, index) builtin;

/* constants */

dcl  RW_access fixed bin (5) int static options (constant) init (01010b) options (constant);
dcl  UPPERCASE char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") options (constant);
dcl  LOWERCASE char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz") options (constant);
dcl  options (8) char (10)  init  ("-copy", "-cp", "-queue", "-q", "-header", "-he", "-destination", "-ds");

/* external */

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  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  error_table_$entlong ext static fixed bin (35);

/* based */

dcl  seg_string char (seg_length) based;
dcl 1 f aligned based like dfast_edit_info based (edit_info_ptr);

%include dfast_edit_info;

/*  */
	     num_print = 0;
	     i = index (line, "-map");
	     if i > 0 then do;

		new_line_length = 0;
		start = 1;
		skip = "0"b;
		do while (code = 0 & get_arg (start, num_chars));
		     arg = substr (line, start, num_chars);
		     if substr (arg, 1, 1) ^= "-" then do;
			if ^skip then do;
			     if num_print = 0 then do;
				if substr (arg, 1, 1) = ">" then pathname = arg;
				else pathname = f.home_dir || ">" || arg;
				i = index (reverse (pathname), ">");
				directory = substr (pathname, 1, length (pathname) -i);
				if i <= 29 then do;
				     entry_name = substr (pathname, length (pathname) -i + 2, i-1);
				     call hcs_$initiate_count (directory, entry_name, "", bit_count, 0, seg_ptr, code);
				     if seg_ptr ^= null then do;
					call hcs_$make_seg ((f.home_dir), substr (entry_name, 1, i -1) || ".map", "", RW_access, temp_ptr, code);
					if temp_ptr ^= null then do;
					     code = 0;
					     seg_length = divide (bit_count, 9, 17, 0);
					     temp_ptr -> seg_string = translate (seg_ptr -> seg_string, UPPERCASE, LOWERCASE);
					     substr (new_line, new_line_length + 1, num_chars + 5) = arg || ".map ";
					     new_line_length = new_line_length + num_chars + 5;
					     call hcs_$set_bc_seg (temp_ptr, bit_count, code);
					     num_print = num_print + 1;
					end;
					call hcs_$terminate_noname (temp_ptr, (0));
				     end;
				end;
				else code = error_table_$entlong;
			     end;
			     else code = error_dprint_map;
			end;
			else do;
			     substr (new_line, new_line_length + 1, num_chars + 1) = arg || " ";
			     new_line_length = new_line_length + num_chars + 1;
			     skip = "0"b;
			end;
		     end;
		     else do;
			if arg = "-dl" | arg = "-delete" then delete_orig_segment = "1"b;
			else if arg ^= "-map" then do;
			     substr (new_line, new_line_length + 1, num_chars + 1) = arg || " ";
			     new_line_length = new_line_length + num_chars + 1;
			     skip = "0"b;
			     do i = 1 to 8;
				if arg = rtrim(options (i)) then skip = "1"b;
			     end;
			end;
		     end;
		     start = start + num_chars;
		     if code ^= 0 then call dfast_error_ (code, "dprint", (pathname));
		end;
		if code = 0 then do;
		     line_length = new_line_length + 4;
		     line = "-dl " || new_line;
		end;
	     end;

	     return;

	end dprint_map;
     end dfast_command_processor_;




		    dfast_compile_.pl1              08/06/87  1149.6r w 08/06/87  1047.0       40446



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


dfast_compile_: proc (edit_info_ptr, code);

/* coded 12/75 by S. E. Barr */
/* modified 12/76 by M. Weaver to use version 2 compiler_source_info structure */
/* Modified 28 Feb 1980 by C R Davis for new fort_options include file. */

/*  This procedure executes COMPILE command for Fortran and Basic.
   *
   *     1.  If the following conditions are met, the segment is compiled:
   *           a.  The source_segment flag is on.
   *           b.  The edit_done flag is off.
   *
   *     2.  If the compilation is successful, these changes are made:
   *           a.  The current_segment is replaced with the object code.
   *           b.  The current_name is set:
   *		1)  Multics convention:  If the source name has a language tag, then
   *		    the object name drops the language tag.  ("test.basic" becomes "test")
   *		2)  If the source name did not have a language suffix, the name is set to "object".
   *		    ("test" becomes "object")
*/
dcl  edit_info_ptr ptr;
dcl  code fixed bin (35);

/* automatic */

dcl 1 fort_opt aligned like fortran_options;
dcl  i fixed bin;
dcl  object_length fixed bin (21);
dcl  temp_ptr ptr;

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

/* constant */


/* external */


dcl  basic_$compile entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  fort_$compile entry (ptr, ptr, fixed bin (21), ptr, fixed bin (35));
dcl  basic_$precision_length fixed bin ext ;
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));

/* based */

dcl 1 f aligned based (edit_info_ptr) like dfast_edit_info;
dcl 1 c aligned like compiler_source_info;
dcl 1 b aligned like branch_status;

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

/*  */
	if ^f.source_segment then code = error_obj_nop;
	else do;
	     if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code);

	     if code = 0 then do;
		if f.edit_done then code = error_sav_cur;
		else do;
		     call hcs_$status_long ((f.source_directory), (f.source_entryname), 1, addr (b), null, code);
		     if code = 0 then do;
			call hcs_$truncate_seg (f.alter_ptr, 0, code);
			if code = 0 then do;
			     c.version = compiler_source_info_version_2;
			     c.input_pointer = f.current_ptr;
			     c.input_lng = f.current_length;
			     c.dirname = f.source_directory;
			     c.segname = f.source_entryname;
			     c.given_ename = f.source_entryname;
			     c.date_time_modified = fixed (b.date_time_modified || (16) "0"b, 71);
			     c.unique_id = b.unique_id;
			     if f.basic_system then do;
				if f.dbasic then basic_$precision_length = 2;
				else basic_$precision_length = 1;
				call basic_$compile (addr (c), f.alter_ptr, object_length, code);
				call switch_buffers (".basic");
			     end;
			     else do;
				unspec (fort_opt) = dfast_mask;
				call fort_$compile (addr (c), f.alter_ptr, object_length, addr( fort_opt), code);
				call switch_buffers (".fortran");
			     end;
			end;
		     end;
		end;
	     end;
	end;

	if code ^= 0 then call dfast_error_ (code, "compile", (f.current_name));

	return;

/* */
switch_buffers: proc (language);

dcl  language char (*);

dcl  len fixed bin;					/* length of language */

	if code = 0 then do;
	     temp_ptr = f.alter_ptr;
	     f.alter_ptr = f.current_ptr;
	     f.current_ptr = temp_ptr;
	     len = length (language);
	     i = length (f.current_name);
	     f.current_name = "object";
	     if i >= len + 1 then do;
	     if substr (c.segname, i-len+1,len) = language
		then f.current_name = substr (c.segname, 1, i-len);
	     end;
	     f.current_length = object_length * 4;
	     f.source_segment = "0"b;
	end;

	return;

	end switch_buffers;

     end dfast_compile_;




		    dfast_directory_.pl1            11/05/82  1316.6rew 11/04/82  1552.2       77526



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
dfast_directory_: proc (action, arg_pathname, edit_info_ptr, copy_info_ptr, code);

/*  This procedure is used to read and write the current segment and to delete segments.
   *
   *	(1)  read		Read into the current segment.  If successful, it sets:
   *
   *			basic_system	ON	Basic source or object code.
   *					OFF	Fortran source or object code.
   *					(not set)	Could not tell type of segment or segment was neither
   *						Fortran nor Basic.
   *
   *			source_segment	ON	Segment is not an object segment.
   *					OFF	Segment is an object segment.
   *
   *			current_length	Number of characters in new current segment.
   *
   *			current_name	Set to the entry name.  If pathname contained an absolute pathname
   *					on entry, current_name will contain just the entry name on exit.
   *
   *	(2)  save		Store only if the segment does not exist.
   *
   *	(3)  replace	Store only if the segment does exist.
   *
   *	(4)  delete	Delete the segment.
   *
   *	(5)  copy		Add the segment onto the end of a segment supplied with the copy_info structure
   *
   *	(6)  truncate	Truncate the segment.  (scratch request)
   *
*/
/*  parameters */

dcl  action fixed bin;				/* requested action: save, old etc. */
dcl  arg_pathname char (*);				/* pathname */
dcl  edit_info_ptr ptr;				/* ptr to dfast_edit_info structure */
dcl  copy_info_ptr ptr;				/* ptr to copy_info structure (for COPY request only) */
dcl  code fixed bin (35);

/* automatic */
dcl  line char (256) var;				/* TEST */

dcl  bit_count fixed bin (24);			/* length of segment */
dcl  i fixed bin (35);
dcl  directory_name char (168);
dcl  access fixed bin (5);
dcl  entry_name char (32);
dcl  seg_ptr ptr;					/* ptr. to segment in directory */
dcl  system bit (1) unal;
dcl  system_name char (7);
dcl  pathname char (256) var;				/* complete pathname */
dcl  program_header_pt ptr;				/* ONLY to prevent warn. (%include basic_program_header) */
dcl  message char (256) var;


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

/* external */

dcl  iox_$user_output ptr ext;
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$noentry fixed bin (35) ext;
dcl  error_table_$segknown fixed bin (35) ext;
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (12), ptr, fixed bin (35));
dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));
dcl  ioa_$ioa_switch entry options (variable);
dcl  com_err_$convert_status_code_ entry (fixed bin (35), char (*) aligned, char (*) aligned);
dcl  object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35));

/* constants */

dcl  READ fixed bin int static init (1) options (constant);
dcl  SAVE fixed bin int static init (2) options (constant);
dcl  REPLACE fixed bin int static init (3) options (constant);
dcl  DELETE fixed bin int static init (4) options (constant);
dcl  COPY fixed bin int static init (5) options (constant);
dcl  TRUNCATE fixed bin int static init (6) options (constant);
dcl  MERGE fixed bin int static init (9) options (constant);
dcl  RW_access fixed bin (5) int static init (01010b) options (constant);
dcl  REW_access fixed bin (5) int static init (01110b) options (constant);
dcl  request_id (6) char (7) int static init ("old", "save", "replace", "unsave", "edit", "scratch") options (constant);

/* based */

dcl  cur_seg char (f.current_length) based;
dcl  string char (f.max_seg_size) based;
						/* based */

dcl 1 oi like object_info aligned;
dcl 1 f aligned based (edit_info_ptr) like dfast_edit_info;
dcl 1 copy_info aligned based (copy_info_ptr),
    2 copy_ptr ptr,					/* ptr to base of target segment */
    2 old_length fixed bin (21),			/* length of segment before the copy */
    2 new_length fixed bin (21);			/* length of segment after the copy */

/* include files */

%include dfast_error_codes;
%include basic_program_header;
%include dfast_edit_info;
%include object_info;

/*  */
	seg_ptr = null;
	if substr (arg_pathname, 1, 1) = ">" then pathname = arg_pathname;
	else pathname = f.home_dir || ">" || arg_pathname;
	i = length (pathname) - index (reverse (pathname), ">");
	directory_name = substr (pathname, 1, i);
	message = pathname;
	entry_name = substr (pathname, i + 2);

	if action ^= SAVE then do;			/* SAVE requires hcs_$make_seg */
	     call hcs_$initiate_count (directory_name, entry_name, "", bit_count, 0, seg_ptr, code);

	     if code = error_table_$segknown then code = 0;
	end;

	if code = 0 then do;
	     if action = READ then do;


/*  If the segment is object, the f.source_segment and f.basic_system can be set with assurance.
   If the segment is not object, it is assumed to be a source segment.
*/
		oi.version_number = 2;
		call object_info_$display (seg_ptr, bit_count, addr (oi), code);
		if code = 0 then do;
		     if oi.compiler = "basic" then do;
			system = "1"b;

/* version is -1 if the language is dbasic (extended precision basic) */

			if oi.textp -> basic_program_header.version_number = -1 then f.dbasic =  "1"b;
		     end;
		     else if oi.compiler = "fortran2" then system = "0"b;
		     else do;
			code = error_unkn_sys;
			message = oi.compiler;
		     end;
		     if code = 0 then do;
			if system ^= f.basic_system then do;
			     system_name = oi.compiler;	/* 'fortran2' gets shortened to 'fortran' */
			     call ioa_$ioa_switch (iox_$user_output, "system changed to ^a", system_name);
			     f.basic_system = system;
			end;
			f.source_segment = "0"b;
		     end;
		end;
		else do;
		     code = 0;
		     f.source_segment = "1"b;
		end;

		if code = 0 then do;
		     i = divide (bit_count, 9, 17, 0);
		     if i > f.max_seg_size then code = error_max_size;
		     else do;
			f.current_length = i;
			f.current_ptr -> cur_seg = seg_ptr -> cur_seg;
			i = index (entry_name, " ");	/* ignore trailing blanks */
			f.current_name = substr (entry_name, 1, i -1);
			f.alter_length = 0;		/* ignore previous edit */
			f.edit_done = "0"b;
		     end;
		end;
	     end;

	     else if action = DELETE then do;
		call hcs_$delentry_seg (seg_ptr, code);
		seg_ptr = null;
	     end;

	     else if action = TRUNCATE then do;
		call hcs_$truncate_seg (seg_ptr, 0, code);
		if code = 0 then call hcs_$set_bc_seg (seg_ptr, 0, code);
	     end;

	     else if action = COPY then do;
		i = divide (bit_count, 9, 17, 0);
		if i + copy_info.old_length > f.max_seg_size then code = error_max_size;

		else do;
		     substr (copy_info.copy_ptr -> string, copy_info.old_length +1, i) =
			substr (seg_ptr -> string, 1, i);
		     copy_info.new_length = copy_info.old_length +i;
		end;
	     end;

	     else do;
		if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code);
		if code = 0 then do;
		     if action = SAVE then do;
			if f.source_segment then access = RW_access;
			else access = REW_access;
			call hcs_$make_seg (directory_name, entry_name, "", access, seg_ptr, code);
			if code = error_table_$segknown then code = error_name_dup;
		     end;

		     if code = 0 then do;
			seg_ptr -> cur_seg = f.current_ptr -> cur_seg;
			bit_count = f.current_length * 9;
			call hcs_$set_bc_seg (seg_ptr, bit_count, code);
			if code = 0 then call hcs_$truncate_seg (seg_ptr, divide (f.current_length + 3, 4, 18), code);
		     end;
		end;
	     end;
	end;


	if code ^= 0 then do;
	     if code = error_table_$noentry then code = error_not_saved;
	     i = index (directory_name, " ");
	     if i = 0 then i = length (directory_name) +1;
	     call dfast_error_ (code, request_id (action), (message));
	end;

/*  This code keps track of the pathname of the last OLD, SAVE, REPLACE for use with COMPILE command */

	else if action = READ | action = SAVE | action = REPLACE then do;
	     f.source_directory = directory_name;
	     f.source_entryname = entry_name;
	end;

	if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, i);

	return;

     end dfast_directory_;




		    dfast_edit_.pl1                 11/05/82  1316.6rew 11/04/82  1552.3       53460



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
dfast_edit_: proc (request, arg_string, edit_info_ptr, code);

/*  This procedure handles all the command level edit functions.  It uses these values for request:
   *
   *   (1)  append		Append the alter segment onto the end of the current segment (no sort)
   *   (2)  sort		Merge the alter and current segment and sort.
   *   (3)  list		List the alter or current segments, or merge and then list
   *   (4)  list (no header)  Same as list, except the header is not printed.
   *   (5)  build		Add the string to the current segment.
   *   (6)  alter		Add the string to the alter segment.
   *   (7)  length		Merge the temporary segments and print the length.
   *   (9)  merge		Merge current and alter segments.
*/

dcl  request fixed bin;
dcl  arg_string char (*);
dcl  edit_info_ptr ptr;				/* ptr to FAST data base */
dcl  code fixed bin (35);				/* error code */

dcl  len fixed bin (21);
dcl  buffer char (max_seg_size) based;			/* for moving segments */
dcl  s char (1);					/* for length message */

dcl (divide, length, substr) builtin;

/*  constants */

dcl  edit_name (9) char (6) int static options (constant) init (
     "append",
     "sort",
     "list",
     "list",
     "build",
     "alter",
     "length",
     "edit",
     "merge");
dcl  APPEND fixed bin int static options (constant) init (1);
dcl  SORT fixed bin int static options (constant) init (2);
dcl  LIST fixed bin int static options (constant) init (3);
dcl  LISTNH fixed bin int static options (constant) init (4);
dcl  BUILD fixed bin int static options (constant) init (5);
dcl  ALTER fixed bin int static options (constant) init (6);
dcl  LENGTH fixed bin int static options (constant) init (7);
dcl  MERGE fixed bin int static options (constant) init (9);

/* external */

dcl  iox_$user_output ptr ext static;
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35));
dcl  dfast_header_ entry (char (*), char (*));
dcl  message_ entry (fixed bin (35), char (*), char (*));
dcl  ioa_ entry options (variable);
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));

%include dfast_edit_info;

%include dfast_error_codes;
/*  */
	if ^source_segment & request ^= LENGTH then code = error_obj_nop;

	else do;

/* append:  The alter segment is appended to the end of the current segment.  No editing is done.  */

	     if request = APPEND then do;
		if alter_length = 0 then code = error_alt_empty;
		else do;
		     len = current_length + alter_length;
		     if len > max_seg_size then code = error_max_size;
		     else do;
			substr (current_ptr -> buffer, current_length + 1, alter_length) = alter_ptr -> buffer;
			current_length = len;
			alter_length = 0;
			edit_done = "1"b;
		     end;
		end;
	     end;

	     else if request = SORT then do;
		call dfast_merge_ ("1"b, edit_info_ptr, code);
	     end;

/* list:  If no segment is specified, then the current and alter segment are merged and the resultant
   current segment is listed.  If a line number was given, the segment is listed beginning with the first line
   equal or greater than that line.
*/
	     else if request = LIST | request = LISTNH then do;
		if arg_string = "alt" then do;
		     if alter_length = 0 then code = error_alt_empty;
		     else do;
			if request = LIST then call dfast_header_ ("alter", "");
			call iox_$put_chars (iox_$user_output, alter_ptr, alter_length, code);
		     end;
		end;

		else do;
		     if arg_string ^= "cur" then do;
			if alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code);
			if code ^= 0 then return;
		     end;
		     if current_length = 0 then code = error_cur_empty;
		     else do;
			if request = LIST then call dfast_header_ ((current_name), "");
			call iox_$put_chars (iox_$user_output, current_ptr, current_length, code);
		     end;
		end;
	     end;

/* build:  The line is appended to the current segment.  No editing is done.  */

	     else if request = BUILD then do;
		len = length (arg_string);
		if len + current_length > max_seg_size then do;
		     build_mode = "0"b;
		     code = error_max_size;
		end;
		else do;
		     substr (current_ptr -> buffer, current_length + 1, len) = arg_string;
		     current_length = current_length + len;
		     edit_done = "1"b;
		end;
	     end;

/* alter:  the line is appended to the alter file.  No editing is done.  */

	     else if request = ALTER then do;
		len = length (arg_string);
		if alter_length + len > max_seg_size then code = error_max_size;
		else do;
		     substr (alter_ptr -> buffer, alter_length + 1, len) = arg_string;
		     alter_length = alter_length + len;
		end;
	     end;

/* length:  If the alter segment is not empty, the current and alter segments are merged.  The length of the resultent
   segment is printed.  If the segments can't be merged, an error
   message is printed and an error return is made.
*/
	     else if request = LENGTH then do;
		if alter_length > 0 then do;
		     call dfast_merge_ ("0"b, edit_info_ptr, code);
		     if code ^= 0 then return;
		end;
		if current_length = 0 then s = "s";
		else if current_length <= 4096 then s = ""; /* no. of characters in one record */
		else s = "s";
		call ioa_ ("""^a"" length = ^d words  (^d record^a)", current_name, divide (current_length, 4, 17),
		     divide (current_length + 4095, 4096, 17, 0), s);
	     end;

	     else if request = MERGE then do;
		if alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code);
	     end;
	end;

	if code ^= 0 then call dfast_error_ (code, edit_name (request), (current_name));
	return;
     end dfast_edit_;




		    dfast_explain_.pl1              11/05/82  1316.6rew 11/04/82  1552.3       25191



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* *  This procedure prints out the explain segments for dfast.
   *  The default is to print all info segments in short form.  If the key word
   *  is -long then arguments following are printed in long form.
   *
   *  The info segments are stored in a special directory with these conventions:
   *	topic.info		The short info segment about topic
   *	topic_l.info		The long info segment about topic
   *	edit_topic.info		The short info segment about the topic request that is part of edit.
   *				(line was:    edit explain topic )
   *	edit_topic_l.info		The long info segment about the topic request that is part of edit.
*/
dfast_explain_: proc (line, caller, code);

/* parameters */

dcl  line char (*) var;				/* user input line */
dcl  caller char (*);				/* calling program  */
dcl  code fixed bin (35);				/* FAST or Multics code */

dcl  directory char (18) int static options (constant) init (">doc>ss>dfast");
dcl  topic_length fixed bin (24);
dcl  topic_ptr ptr;
dcl  arg char (256) var;
dcl  num_topics fixed bin;				/* topics requested */
dcl  prefix char (5) var;
dcl  suffix char (7);				/*  ".info" for short   "_l.info" for long */
dcl (divide, null) builtin;

/* external */

dcl  iox_$user_output ptr ext;
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  dfast_get_arg_ entry (char (*) var, char (*) var) returns (bit (1));
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (12), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));

%include dfast_error_codes;

/*  */

	if caller = "edit" then prefix = "edit_";
	else prefix = "";
	suffix = ".info";
	num_topics = 0;
	do while (dfast_get_arg_ (line, arg));
	     if arg = "-long" then suffix = "_l.info";
	     else do;
		call print ((arg));
		num_topics = num_topics + 1;
	     end;
	end;

	if num_topics = 0 then call print (caller);

	code = 0;

	return;




print:	proc (topic);

dcl  topic char (*);

	     call hcs_$initiate_count (directory, prefix || topic || suffix, "", topic_length, 0, topic_ptr, code);
	     if topic_ptr ^= null then do;
		topic_length = divide (topic_length, 9, 17, 0);
		call iox_$put_chars (iox_$user_output, topic_ptr, (topic_length), code);
		call hcs_$terminate_noname (topic_ptr, code);
	     end;

	     else call dfast_error_ (error_no_expl, caller, topic);

	     return;

	end print;


     end dfast_explain_;




		    dfast_get_arg_.pl1              11/05/82  1316.6rew 11/04/82  1552.4       16785



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
dfast_get_arg_: proc (line, argument) returns (bit (1));

/*   This procedure is used to find the next argument on the line.  It expects the form:
   *
   *	[blank | tab] [argument] [blank | tab | comma | semi-colon]
   *
   * Any of the fields may be null.  If no argument and no delimitor is found, then the procedure returns "0"b.
   * Otherwise "1"b is returned.
*/

dcl  argument char (256) var;				/* next argument (output) */

dcl  line char (256) var;				/* input buffer */
dcl  line_length fixed bin;				/* length of line on input */
dcl  argument_length fixed bin;			/* length of argument */
dcl  start fixed bin;				/* index in line of start of argument */

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

/* constants */

dcl  white_space char (2) int static options (constant) init ("	 "); /* <tab> <blank> */
dcl  arg_delimit char (4) int static options (constant) init ("	 ,;"); /* <tab> <blank> <,> <;> */

	line_length = length (line);

	if line_length > 0 then do;

	     start = verify (line, white_space);
	     if start > 0 then do;
		argument_length = search (substr (line, start), arg_delimit);

		if argument_length = 0 then argument_length = line_length - start + 1;
		else argument_length = argument_length - 1;
		argument = substr (line, start, argument_length);
		start = start + argument_length + 1;	/* move beyond the argument delimitor */
		if start > line_length then line = "";
		else line = substr (line, start, line_length - start + 1);

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



		    dfast_header_.pl1               11/05/82  1316.6rew 11/04/82  1552.4        8064



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
dfast_header_: proc (message_1, message_2);

dcl  message_1 char (*);
dcl  message_2 char (*);

dcl  date_number fixed bin (71);			/* clock time */
dcl  date_string char (24);				/* time in English */
dcl  iox_$user_output ptr ext;

dcl  ioa_$ioa_switch entry options (variable);
dcl  clock_ entry returns (fixed bin (71));
dcl  date_time_ entry (fixed bin (71), char (*));

	date_number = clock_ ();
	call date_time_ (date_number, date_string);
	call ioa_$ioa_switch (iox_$user_output, "^/^a  ^a  ^a  ^/", message_1, message_2, date_string);

	return;

     end dfast_header_;




		    dfast_line_edit_.pl1            11/05/82  1316.6rew 11/04/82  1552.4      415386



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


dfast_line_edit_: proc (line, arg_edit_info_ptr, sort, code);

dcl  line char (256) var;				/* input line with edit request */
dcl  arg_edit_info_ptr ptr;				/* ptr to edit_info structure */
dcl  sort bit (1) unal;				/* ON for edit; OFF for editns */
dcl  code fixed bin (35);				/* fast error code */

/* automatic */

dcl  edit_info_ptr ptr;				/* ptr to edit_info structure */
dcl  start_index fixed bin (21);			/* index in the line table "t" to first number in block */
dcl  num_1 fixed bin (21);
dcl  num_2 fixed bin (21);
dcl  end_index fixed bin (21);			/* index in the line table "t" to last number in block */
dcl  line_start fixed bin (21);
dcl  line_end fixed bin (21);
dcl  num_3 fixed bin (21);
dcl  t_index fixed bin (21);				/* index into line table */
dcl  seq_number fixed bin (21);			/* sequence number for move, sequence, and resequence commands */
dcl  line_number fixed bin (21);
dcl  string char (10);
dcl  line_length fixed bin (21);			/*  length of the line */
dcl  last_index fixed bin (21);
dcl  block_length fixed bin (21);			/* number of characters in the block */
dcl  block_start fixed bin (21);
dcl  block_end fixed bin (21);
dcl  basic_resq_tbl_ptr ptr ;
dcl  temp_ptr ptr;
dcl  cur_ptr ptr;
dcl  cur_length fixed bin (21);
dcl  request char (3);				/* EDIT request */
dcl  arg char (256) var;				/* argument for dfast_get_arg_ */
dcl  num_pic pic "zzzzz9";
dcl  temp_length fixed bin (21);
dcl (i, j) fixed bin (21);
dcl  k fixed bin (21);				/* temporary used in request routines: list, move, etc. */
dcl  print_message bit (1) unal;			/* ON if the error message should be printed */
dcl  increment fixed bin (21);

dcl  old_string char (256) var;
dcl  new_string char (256) var;
dcl  length_old_string fixed bin (21);
dcl  length_new_string fixed bin (21);
dcl  check bit (1);					/* ON To prevent substitution of line number */
dcl  replace_OK bit (1);				/* ON if replace is allowed;  OFF if replace would
						   change the line number */


dcl 1 block (16),
    2 start fixed bin (21),
    2 end fixed bin (21);

dcl 1 seq (16),
    2 number fixed bin (21),
    2 incr fixed bin (21);
dcl  num_blocks fixed bin (21);

dcl 1 copy_info aligned,
    2 copy_ptr ptr,					/* ptr to base of target segment */
    2 old_length fixed bin (21),			/* length of segment before the copy */
    2 new_length fixed bin (21);			/* length of segment after the copy */

dcl  cleanup condition;


/* constants */

dcl  max_digits_line_num fixed bin int static options (constant) init (5); /* must match number_pic */
dcl  number_pic pic "99999";				/* used to convert number strings to fixed binary */
dcl  new_line char (1) int static options (constant) init ("
");
dcl  white_space char (2) int static options (constant) init ("	 "); /* tab & blank */
dcl  arg_delimiter char (4) int static options (constant) init ("	 ,;"); /* tab & blank & comma & semi-colon */
dcl  digit char (10) int static options (constant) init ("0123456789");
dcl  blank char (1) int static options (constant) init (" ");
dcl  COPY fixed bin int static options (constant) init (5);
dcl  REPLACE fixed bin int static options (constant) init (0); /* replace:  simple replace */
dcl  PREFIX fixed bin int static options (constant) init (1); /* replace:  prefix request */
dcl  SUFFIX fixed bin int static options (constant) init (2); /* replace:  suffix request */

/* based */

dcl 1 f aligned based (edit_info_ptr) like dfast_edit_info;
dcl  temp_seg char (f.max_seg_size) based (temp_ptr);
dcl  cur_seg char (cur_length) based (cur_ptr);
dcl 1 basic_resq_tbl aligned based (basic_resq_tbl_ptr),
    2 num_lines fixed bin (21),
    2 t (2) aligned,
      3 old_number fixed bin (17) unal,
      3 new_number fixed bin (17) unal;
dcl  based_arr (1) ptr based;

dcl (addr, divide, index, length, null, ptr, reverse, search, substr, translate, verify) builtin;

/* external */

dcl  iox_$user_output ptr ext;

dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  ioa_$rsnnl entry options (variable);
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  dfast_directory_ entry (fixed bin, char (*), ptr, ptr, fixed bin (35));
dcl  dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35));
dcl  dfast_explain_ entry (char (*) var, char (*), fixed bin (35));
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  dfast_get_arg_ entry (char (256) var, char (256) var) returns (bit (1) unal);
dcl  dfast_basic_resequence_ entry (fixed bin (21), ptr, char (*), bit (1), ptr, fixed bin (21), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));

/* include files */

%include dfast_error_codes;
%include dfast_edit_info;
/*  */

	edit_info_ptr = arg_edit_info_ptr;
	print_message = "1"b;
	basic_resq_tbl_ptr = null;

	if dfast_get_arg_ (line, arg) then do;
	     request = arg;
	     request = translate (request, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");

	     if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code);

	     if code = 0 then do;
		cur_ptr = f.current_ptr;
		cur_length = f.current_length;


		if request = "loc" then call locate;
		else if request = "lis" then call list;
		else if request = "exp" then call dfast_explain_ (line, "edit", code);
		else do;
		     temp_length = 0;
		     temp_ptr = f.alter_ptr;
		     on cleanup begin;
			if basic_resq_tbl_ptr ^= null then call free_buffers;
		     end;
		     if request = "joi" then call join ("0"b);
		     else if request = "mer" then call merge;
		     else if request = "app" then call append;
		     else if cur_length > 0 then do;	/* following request edit current segment */
			if request = "ins" then call insert;
			else if request = "rep" then call replace (REPLACE);
			else if request = "pre" then call replace (PREFIX);
			else if request = "suf" then call replace (SUFFIX);
			else if request = "des" then call desequence;
			else if request = "del" then call delete;
			else if request = "ext" then call extract;
			else if request = "mov" then call move;
			else if request = "res" then call resequence;
			else if request = "seq" then call sequence;
			else if request = "str" then call string_request;
			else code = error_unknown_arg;
			if code = 0 then f.edit_done = "1"b;
		     end;
		     else code = error_cur_empty;
		end;
	     end;
	end;
	else do;
	     code = error_request_miss;
	     arg = "";
	end;

	if code ^= 0 then if print_message then do;
		if code = error_no_num then arg = "";
		call dfast_error_ (code, "edit", (arg));
	     end;

	if basic_resq_tbl_ptr ^= null then call free_buffers;
	return;

/*  */
free_buffers: proc;

dcl  acode fixed bin (35);

	     if basic_resq_tbl_ptr ^= null then call release_temp_segments_ ("fast", addr (basic_resq_tbl_ptr) -> based_arr, acode);
	     if acode ^= 0 then call dfast_error_ (acode, "edit", "resequence_table");

	     return;

	end free_buffers;

/*  */
/* * This procedure deletes lines from the current segment.  The current segment is copied in portions (excluding
   * the line blocks)  into a temporary segment.
   *
   *	delete [<line list>]
   *
   *	code = 0		Lines were deleted.
   *	code ^= 0		Error code from parse_block_spec
   *
   * In case of error, the current segment is not changed.
*/
delete:	proc;

	     call parse_line_list;
	     if code = 0 then do;
		if num_blocks > 0 then do;
		     last_index = 0;
		     do k = 1 to num_blocks ;
			call copy_block (last_index + 1, block (k).start - 1);
			last_index = block (k).end;
		     end;
		     if code = 0 then do;
			call copy_block (last_index + 1, f.current_length);
			call switch_buffers;
		     end;
		end;
	     end;
	     else code = error_no_num;

	     return;

	end delete;

/*  */
/*  * This procedure extracts lines from the current segment.  The lines to be extracted are copied into a temporary
   *  buffer which becomes the current buffer if there are no errors.
   *
   *	extract [<line list>]
   *
   *	code = 0			Lines were extracted.
   *	code = error_no_num		No lines were requested.
   *	code ^= 0			Error code from parse_block_spec
   *
   *
*/
extract:	proc;

	     call parse_line_list;
	     if code ^= 0 then return;
	     if num_blocks > 0 then do;
		do k = 1 to num_blocks;

		     call copy_block ((block (k).start), (block (k).end));
		     if code ^= 0 then return;
		end;

		call switch_buffers;
	     end;

	     else code = error_line_miss;

	     return;

	end extract;

/*  */
/* * This procedure lists the lines requested.
   *
   *	list	[<line list>]
   *
   *	code = 0		Lines were printed
   *	code ^= 0		Error code from parse_block_spec
   *
   * Lines will be listed until the line list is exhausted or until the first error.
   *
*/

list:	proc;

	     if cur_length > 0 then do;

		call parse_line_list;
		if code ^= 0 then return;
		if num_blocks = 0 then do;
		     num_blocks = 1;
		     block (1).start = 1;
		     block (1).end = cur_length;
		end;

		do k = 1 to num_blocks;

		     call iox_$put_chars (iox_$user_output, addr (substr (cur_seg, block (k).start, 1)), block (k).end -
			block (k).start + 1, code);
		     call iox_$put_chars (iox_$user_output, addr (new_line), 1, code);
		end;
	     end;
	     else code = error_cur_empty;

	     return;

	end list;

/*  */
/* *  This procedure parses a list of segment pathnames and appends the segments onto the end of the current segment.
*/
join:	proc (fill_block_table);

dcl  fill_block_table bit (1) unal;			/* ON if should fill in block structure */

	     copy_info.copy_ptr = temp_ptr;
	     copy_info.old_length = 0;
	     num_blocks = 0;

	     do while (copy_seg ());
		if fill_block_table then do;
		     if num_blocks < 16 then do;
			num_blocks = num_blocks + 1;
			block (num_blocks).start = copy_info.old_length + 1;
			block (num_blocks).end = copy_info.new_length;
		     end;
		     else do;
			code = error_max_lines;
			return;
		     end;
		end;
		copy_info.old_length = copy_info.new_length;
	     end;

	     if code = 0 then do;
		temp_length = copy_info.old_length;
		call switch_buffers;
	     end;

	     return;

	end join;

/*  */
/* *  The append command reads one or more segments and resequences them.
   *
   *	append	seg_1 [, seg_2>] . . .
*/
append:	proc;

	     call join (f.basic_system);
	     if code = 0 then do;
		temp_length = 0;
		seq_number = 100;
		increment = 10;

		cur_ptr = f.current_ptr;		/* re-initialize, since JOIN called switched buffers */
		temp_ptr = f.alter_ptr;
		cur_length = f.current_length;
		if ^f.basic_system then do;
		     call renumber (1, cur_length, seq_number, increment);
		     if code = 0 then call switch_buffers;
		end;
		else do;
		     call get_temp_segments_ ("fast", addr (basic_resq_tbl_ptr) -> based_arr, code);
		     if code = 0 then do;
			do i = 1 to num_blocks while (code = 0);
			     num_lines = 0;
			     call fill_basic_tbl (basic_resq_tbl_ptr, "0"b, block (i).start, block (i).end, seq_number, increment);
			     if code = 0 then call copy_resq ("1"b, block (i).start, block (i).end);
			end;
			if code = 0 then call switch_buffers;
		     end;
		end;
	     end;

	     return;

	end append;

/*  */
/*  This procedure merges one or more segments.  The segments are copied into a tempory buffer and then sorted
   using the edit rules of dfast_merge_.
*/
merge:	proc;

	     call join ("0"b);

	     if code = 0 then call dfast_merge_ ("1"b, edit_info_ptr, code);

	     return;

	end merge;

/*  */
/* This procedure copies all the segments into the current segment.  It then copies and renumbers the entire segment.
   *
   *	insert	seg_name [;seg_name, line_number]
*/
insert:	proc;

dcl  index_arr (16) fixed bin (21);
dcl  second_tbl_ptr ptr;

dcl  k fixed bin (21);
dcl 1 second_tbl aligned based (second_tbl_ptr) like basic_resq_tbl;

	     call get_temp_segments_ ("fast", addr (basic_resq_tbl_ptr) -> based_arr, code);
	     seq_number = 100;
	     increment = 10;
	     num_blocks = 0;
	     basic_resq_tbl.num_lines = 0;
	     last_index = 0;
	     copy_info.copy_ptr = cur_ptr;
	     copy_info.old_length = 0;

	     if copy_seg () then do;
		cur_length, copy_info.old_length = copy_info.new_length;

		do while (copy_seg () & code = 0);
		     if num_blocks < 16 then do;
			num_blocks = num_blocks + 1;
			if find_line ((0), index_arr (num_blocks)) then do;
			     if index_arr (num_blocks) >= last_index then do;
				block (num_blocks).start = copy_info.old_length + 1;
				block (num_blocks).end = copy_info.new_length;
				copy_info.old_length = copy_info.new_length;
				if f.basic_system then do;
				     call fill_basic_tbl (basic_resq_tbl_ptr, "0"b, last_index + 1, index_arr (num_blocks),
					seq_number, increment);

				     seq (num_blocks).number = seq_number;
				     i = block (num_blocks).start;
				     do while (i <= block (num_blocks).end);
					j = index (substr (cur_seg, i, block (num_blocks).end - i + 1), new_line);
					if j > 0 then do;
					     seq_number = seq_number + increment;
					     i = i + j;
					end;
					else i = block (num_blocks).end + 1;
				     end;
				end;
				last_index = index_arr (num_blocks);
			     end;
			     else code = error_line_order;
			end;
		     end;
		     else code = error_max_lines;
		end;
		if num_blocks = 0 then code = error_request_miss;

	     end;
	     else code = error_request_miss;
	     if code ^= 0 then return;

	     if f.basic_system then call fill_basic_tbl (basic_resq_tbl_ptr, "0"b, last_index + 1, cur_length, seq_number, increment);
	     k = cur_length;
	     cur_length = block (num_blocks).end;
	     last_index = 0;

/* If the system is not basic the segment is just copied and renumbered */

	     if ^f.basic_system then do;
		do i = 1 to num_blocks while (code = 0);
		     call renumber (last_index + 1, index_arr (i), seq_number, increment);
		     call renumber (block (i).start, block (i).end, seq_number, increment);
		     last_index = index_arr (i);
		end;
		call renumber (last_index + 1, k, seq_number, increment);
		if code = 0 then call switch_buffers;
		return;
	     end;


	     second_tbl_ptr = addr (basic_resq_tbl_ptr -> basic_resq_tbl.t (basic_resq_tbl.num_lines + 1).old_number);
	     second_tbl.num_lines = 0;
	     do i = 1 to num_blocks while (code = 0);
		if last_index < index_arr (i) then call copy_resq ("1"b, last_index + 1, index_arr (i));
		last_index = index_arr (i);
		second_tbl.num_lines = 0;
		call fill_basic_tbl (second_tbl_ptr, "0"b, block (i).start, block (i).end, seq (i).number, increment);
		call dfast_basic_resequence_ (f.max_seg_size, second_tbl_ptr, substr (cur_seg, block (i).start, block (i).end - block (i).start + 1),
		     "1"b, temp_ptr, temp_length, code);
	     end;

	     if code = 0 then do;
		if last_index < k then call copy_resq ("1"b, last_index + 1, k);
		if code = 0 then call switch_buffers;
	     end;

	     return;

	end insert;

/*  */
/* This procedure moves one block of lines to a position following a given line number
   *
   *	move	num_1 - num_2, num_3
   *
   * If line_num is not present, the block is moved to a position following the logical spot for line_num.
   * The block that was moved is resequence with an initial value of line_num + 1 and  an increment of 1.
   * Lines following the block are resequenced if the block renumbering caused duplicate line numbers.
   *
   *	code = 0			successful
   *				line_num is within the range of the block.
   *	     = error_block_spec	the block contains no numbers
*/
move:	proc;

	     if parse_block_spec (1, start_index, end_index) then do;
		if find_line (line_start, line_end) then do;

		     seq_number = num_3 +1;

		     if f.basic_system then call basic_move;
		     else do;
			if num_3 < num_1 then do;
			     call copy_block (1, line_end);
			     call renumber (start_index, end_index, seq_number, 1);
			     call renumber_if_necessary (line_end + 1, start_index -1, seq_number);
			     call renumber_if_necessary (end_index +1, cur_length, seq_number);
			end;

			else if num_2 < num_3 then do;
			     call copy_block (1, start_index -1);
			     call copy_block (end_index + 1, line_end);
			     if end_index > start_index then call renumber (start_index, end_index, seq_number, 1);
			     call renumber_if_necessary (line_end + 1, cur_length, seq_number);
			end;

			else code = error_block_spec;
		     end;
		     if code = 0 then call switch_buffers;
		end;
		else code = error_no_num;
	     end;
	     else code = error_request_miss;

	     return;

	end move;

/*  */
/* *  This procedure resequences the file and edits the source code to reflect the new numbers.
   *  There are two types of editing done.
   *	"0"b	the line keeps its line number, but line references are changed.
   *	"1"b	both the line and any line  references are changed.
*/
basic_move: proc;


	     call get_temp_segments_ ("fast", addr (basic_resq_tbl_ptr) -> based_arr, code);
	     if code ^= 0 then return;
	     num_lines = 0;

	     call fill_basic_tbl (basic_resq_tbl_ptr, "0"b, start_index, end_index, seq_number, 1);

	     if num_3 < num_1 then do;
		call fill_basic_tbl (basic_resq_tbl_ptr, "1"b, line_end +1, start_index -1, seq_number, 1);
		call fill_basic_tbl (basic_resq_tbl_ptr, "1"b, end_index + 1, cur_length, seq_number, 1);

		if sort then do;
		     call copy_resq ("0"b, 1, line_end);
		     call copy_resq ("1"b, start_index, end_index);
		     call copy_resq ("1"b, line_end + 1, start_index -1);
		     call copy_resq ("1"b, end_index +1, cur_length);
		end;

		else call copy_resq ("1"b, 1, cur_length);
	     end;

	     else if num_2 < num_3 then do;
		call fill_basic_tbl (basic_resq_tbl_ptr, "1"b, line_end + 1, cur_length, seq_number, 1);

		if sort then do;
		     call copy_resq ("0"b, 1, start_index -1);
		     call copy_resq ("0"b, end_index + 1, line_end);
		     if end_index > start_index then call copy_resq ("1"b, start_index, end_index);
		     call copy_resq ("1"b, line_end + 1, cur_length);
		end;

		else call copy_resq ("1"b, 1, cur_length);
	     end;

	     else code = error_block_spec;


	     return;

	end basic_move;

/*   */
/* *  This procedure calls dfast_basic_resequence_.  It operates in two ways.
   *
   *	"1"b	Both the line number and any line references are changed.
   *	"0"b	Just the line references are changed.
*/
copy_resq: proc (resequence_lines, start, end);

dcl  resequence_lines bit (1);
dcl  start fixed bin (21);
dcl  end fixed bin (21);

	     call dfast_basic_resequence_ (f.max_seg_size, basic_resq_tbl_ptr, substr (cur_seg, start, end - start + 1),
		resequence_lines, temp_ptr, temp_length, code);

	     return;
	end copy_resq;

/*  */
/* This procedure prints all lines that contain the given string.
   *
   *	locate /old_string/  [<line list>]
   *
   *	(Any character except blank or tab may be used as a delimiter.)
   *
   *	code = 0			At least one string found.
   *	     = error_no_string	String was not found.
   *	     = error_no_nl		Segment does not end in a new_line.  (presumably not source)
*/
locate:	proc;

dcl  string_found bit (1) unal;			/*  ON if string was found at least once */

	     if cur_length > 0 then do;
		if parse_string_args ("1"b) then do;

		     string_found = "0"b;
		     do k = 1 to num_blocks;
			start_index = block (k).start;
			block_length = block (k).end - block (k).start + 1;

			do while (block_length > 0 & code = 0);
			     i = index (substr (cur_seg, start_index, block_length), old_string);
			     if i > 0 then do;
				j = index (reverse (substr (cur_seg, start_index, i)), new_line);
				if j > 0 then do;
				     block_length = block_length +j -i -1;
				     start_index = start_index +i -j +1;
				end;
				j = index (substr (cur_seg, start_index, block_length), new_line);
				if j > 0 then do;
				     call iox_$put_chars (iox_$user_output, addr (substr (cur_seg, start_index, 1)), j, code);
				     start_index = start_index + j;
				     block_length = block_length - j;
				     string_found = "1"b;
				end;
				else code = error_no_nl;
			     end;
			     else block_length = 0;

			end;
		     end;

		     if code = 0 then if ^string_found then code = error_no_string;
		end;
	     end;
	     else code = error_cur_empty;

	     return;

	end locate;



/*  */
/* *  This procedure replaces old_string with new_string for a given block of lines.
   *  The line numbers can not be changed.
   *
   *	replace	/<old string>/<new string>/ [<line list>]	(REPLACE)
   *
   *	prefix	/<old string>/<new string>/ [<line list>]	(PREFIX)
   *
   *	suffix	/<old string>/<new string>/ [<line list>]	(SUFFIX)
   *
   *		(Any character except blank or tab may be used as a delimiter)
*/
replace:	proc (replace_type);

dcl  replace_type fixed bin;

	     if parse_string_args ("0"b) then do;
		if replace_type ^= REPLACE then do;
		     length_new_string = length_new_string + length_old_string;
		     if length_new_string <= 256 then do;
			if replace_type = PREFIX then new_string = new_string || old_string;
			else new_string = old_string || new_string;
		     end;
		     else do;
			code = error_string_size;
			return;
		     end;
		end;


/*  Search through blocks of lines and replace  the string.  The new code is stored in temp_seg */

		last_index = 0;
		do k = 1 to num_blocks;
		     start_index = block (k).start;
		     block_length = block (k).end - block (k).start;
		     do while (block_length > 0);
			i = index (substr (cur_seg, start_index, block_length), old_string) -1;
			if i > - 1 then do;

/*  This check is done if old_string begins with a digit.  It searches back for the first non-digit.
   * It sets replace_OK = 1, if the replacement would not change a line number.
   *
   *	j = 0				A line number at the start of a block.
   *	j > 0 & character = new_line		The first non-digit is new_line.
   *	j > 0 & character ^= new_line		A string inside a line.
*/

			     if check then do;
				j = verify (reverse (substr (cur_seg, 1, start_index + i -1)), digit);
				if j > 0 then do;
				     if substr (cur_seg, start_index + i - j, 1) = new_line then replace_OK = "0"b;
				     else replace_OK = "1"b;
				end;
				else replace_OK = "0"b;
			     end;

			     if replace_OK then do;
				i = start_index + i - 1;
				call copy_block (last_index + 1, i);
				substr (temp_seg, temp_length +1, length_new_string) = new_string;
				temp_length = temp_length + length_new_string;
				last_index = i + length_old_string;
				block_length = block_length - last_index + start_index - 1;
				start_index = last_index + 1;
			     end;
			     else do;
				replace_OK = "1"b;
				start_index = start_index + i + length_old_string;
				block_length = block_length - i - length_old_string + 1;
			     end;
			end;
			else block_length = 0;
		     end;
		end;

		if last_index ^= 0 then do;
		     call copy_block (last_index + 1, cur_length);
		     call switch_buffers;
		end;

		else do;
		     code = error_no_string;
		     arg = old_string;
		end;

	     end;

	     return;

	end replace;

/*  */
/* *  This procedure parses the argument list for LOCATE, REPLACE, PREFIX, SUFFIX
   *
   *	/old_string/new_string/ line_list
   *
   *  If line_list is missing, LOCATE uses the entire text.  The line_list must be  present for
   *  REPLACE, PREFIX and SUFFIX.  These global variables are set:
   *
   *	old_string
   *	old_string_length
   *	new_string
   *	new_string_length
   *	num_blocks
   *	block (1, num_block)
   */
parse_string_args: proc (one_string_sw) returns (bit (1));

dcl  one_string_sw bit (1) unal;			/* ON if only one string is expected -- LOCATE */

dcl (i, j) fixed bin;
dcl  delimiter char (1);

	     i = verify (line, white_space);
	     if i > 0 then do;
		delimiter = substr (line, i, 1);
		arg = delimiter;
		j = index (substr (line, i + 1), delimiter);
		if j > 1 then do;
		     old_string = substr (line, i +1, j - 1);
		     arg = old_string;		/* for error message */
		     length_old_string = j -1;
		     i = i + j + 1;
		     if one_string_sw then line = substr (line, i);
		     else do;
			j = index (substr (line, i), delimiter);
			if j > 0 then do;
			     new_string = substr (line, i, j-1);
			     length_new_string = j -1;
			     line = substr (line, i +j);
			end;
			else code = error_delimiter_miss;
		     end;
		end;
		else if j = 1 then code = error_syntax_string;
		else code = error_delimiter_miss;
	     end;
	     else do;
		code = error_delimiter_miss;
		arg = "";
	     end;

	     if code = 0 then do;
		call parse_line_list;
		if code = 0 then do;

		     if index (digit, substr (old_string, 1, 1)) ^= 0 then check = "1"b;
		     else if index (digit, substr (new_string, 1, 1)) ^= 0 then check = "1"b;
		     else check = "0"b;
		     replace_OK = "1"b;

		     if num_blocks > 0 then return ("1"b);
		     else if request = "loc" then do;
			num_blocks = 1;
			block (1).start = 1;
			block (1).end = cur_length;
			return ("1"b);
		     end;
		     else code = error_no_num;
		end;
	     end;
	     return ("0"b);

	end parse_string_args;

/*  */
/* * This procedure removes a number followed by a blank on each line.  If there is no number present, the
   * line is copied as is.  If there is no blank following the number, just the number is removed.
   *
   *	desequence
   *
*/
desequence: proc;

	     start_index = 1;

	     do while (start_index <= cur_length & code = 0);

		i = verify (substr (cur_seg, start_index), digit) -1;
		if i > -1 then do;
		     if i > 0 then if substr (cur_seg, start_index + i, 1) = blank then i = i + 1;
		     start_index = start_index + i;

		     j = index (substr (cur_seg, start_index), new_line);
		     if j > 0 then do;
			call copy_block (start_index, start_index + j -1);
			start_index = start_index + j;
		     end;

		     else code = error_no_nl;
		end;
		else code = error_no_nl;
	     end;

	     if code = 0 then call switch_buffers;

	     return;

	end desequence;

/*  */
/* * This procedure adds a sequence number and one blank to each line.  It uses new_number for the first line
   * and adds increment to get the next line number.  The default is to start with 100 and increment
   * by 10.
   *
   *	sequence	new_number,  increment
   *
*/

sequence:	proc;

	     seq_number = 100;
	     increment = 10;

	     if parse_number (seq_number) then if parse_number (increment) then;

	     if code = 0 then do;
		if cur_length > 0 then do;

		     start_index = 1;

		     do while (start_index <= cur_length);

			i = index (substr (cur_seg, start_index), new_line);
			if i > 0 then do;
			     call ioa_$rsnnl ("^d ", string, j, seq_number);
			     if temp_length + j + i <= f.max_seg_size then do;

				substr (temp_seg, temp_length + 1, j) = string;
				temp_length = temp_length + j;
				substr (temp_seg, temp_length + 1, i) = substr (cur_seg, start_index, i);
				temp_length = temp_length + i;
				start_index = start_index + i;
				seq_number = seq_number + increment;
			     end;

			     else do;
				code = error_max_size;
				return;
			     end;
			end;
			else code = error_no_nl;
		     end;
		     if code = 0 then call switch_buffers;
		end;
		else code = error_cur_empty;
	     end;

	     return;

	end sequence;

/*  */
/*  This procedure has an optional argument list:
   *
   *	resequence  [<new number>]  [,<line_number>] [,<increment>]
   *
   *		new number	Line number to use for the resequencing.
   *		line_number	Line at which to begin resequencing.
   *		increment		Increment added each time to new_number.
   *
*/
resequence: proc;

	     call resequence_args;

	     last_index = 0;

	     if f.basic_system then do;
		call get_temp_segments_ ("fast", addr (basic_resq_tbl_ptr) -> based_arr, code);
		if code ^= 0 then return;
		num_lines = 0;

		do k = 1 to num_blocks;
		     call fill_basic_tbl (basic_resq_tbl_ptr, "0"b, block (k).start, block (k).end, seq (k).number, seq (k).incr);
		end;

		do k = 1 to num_blocks while (code = 0);

		     call copy_resq ("0"b, last_index + 1, block (k).start -1);
		     call copy_resq ("1"b, block (k).start, block (k).end);

		     last_index = block (k).end;
		end;

		if code = 0 then call copy_resq ("0"b, last_index + 1, cur_length);

	     end;

	     else do;
		do k = 1 to num_blocks while (code = 0);

		     if block (k).start > last_index then do;
			call copy_block (last_index + 1, block (k).start -1);
			call renumber (block (k).start, block (k).end, seq (k).number, seq (k).incr);
			last_index = block (k).end;
		     end;
		     else code = error_line_order;
		end;

		if code = 0 then call copy_block (last_index + 1, cur_length);

	     end;

	     if code = 0 then do;
		call switch_buffers;
		if sort then call dfast_merge_ ("1"b, edit_info_ptr, code);
	     end;

	     return;

	end resequence;

/*  */
/*  This procedure parses the user's input line for a resequence spceifcation.
   It returns "1"b if some of the block specification was found  and returns "0"b if the argument list
   is exhausted.  If errors occur code is set and "0"b is returned.

*/
resequence_args: proc ();

	     num_blocks = 0;
	     do while (code = 0);
		if parse_number (seq_number) then do;
		     if get_numbers (num_1, num_2) then do;
			if get_equal_lower_line (1, num_1, block_start, block_end) then do;
			     if block_start = 0 then block_start = 1;
			     if num_1 = num_2 then block_end = cur_length;
			     else if ^get_equal_lower_line (1, num_2, block_start, block_end) then code = error_line_miss;
			     if ^parse_number (increment) then increment = 10;

			end;
			else code = error_line_miss;
		     end;
		     else do;
			if num_blocks = 0 then block_start = 1;
			else block_start = block_end + 1;
			block_end = cur_length;
			increment = 10;
		     end;
		end;

		else do;
		     if num_blocks > 0 then return;
		     block_start = 1;
		     block_end = cur_length;
		     seq_number = 100;
		     increment = 10;
		end;

		num_blocks = num_blocks + 1;
		if num_blocks <= 16 then do;
		     block (num_blocks).start = block_start;
		     block (num_blocks).end = block_end;
		     seq (num_blocks).number = seq_number;
		     seq (num_blocks).incr = increment;
		end;
	     end;

	     return;

	end resequence_args;

/*  */
/* *  This request converts the segment into fixed record format.
   *
   *	string	<record length>
*/
string_request: proc;

dcl  bit_count fixed bin (24);
dcl  directory char (168) ;
dcl  directory_length fixed bin;
dcl  entry_name char (32) ;
dcl  iocb_ptr ptr;					/* ptr to iocb in creating blocked file */
dcl  record_length fixed bin (21);			/* length of records in new file */

dcl  cleanup condition;
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));

	     arg = "";

	     if parse_number (record_length) then do;
		if record_length ^= 0 then do;
		     call hcs_$fs_get_path_name (temp_ptr, directory, directory_length, entry_name, code);
		     if code = 0 then do;
			call hcs_$set_bc_seg (temp_ptr, 0, code);
			if code ^= 0 then call dfast_error_ (code, "string","");
			num_pic = record_length;
			iocb_ptr = null;
			on cleanup call cleanup_iocb (iocb_ptr);
			call iox_$attach_ioname ("string", iocb_ptr, "vfile_ " || substr (directory, 1, directory_length)
			     || ">" || entry_name || " -blocked " || num_pic || " -ssf", code);
			if code = 0 then do;
			     call iox_$open (iocb_ptr, 5, "0"b, code);

			     start_index = 1;
			     do while (start_index <= cur_length & code = 0);
				i = index (substr (cur_seg, start_index), new_line) -1;
				if i >= 0 then do;
				     if i <= record_length then do;
					call iox_$write_record (iocb_ptr, addr (substr (cur_seg, start_index,1)),
					     i, code);
					start_index = start_index + i +1;
				     end;
				     else do;
					code = error_size_fixed_record;
					num_pic = i;
					arg = num_pic;
				     end;
				end;
				else code = error_no_nl;
			     end;
			     call cleanup_iocb (iocb_ptr);
			     if code = 0 then do;
				call hcs_$status_mins (temp_ptr, 0, bit_count, code);
				temp_length = divide (bit_count + 8, 9, 21, 0);
			     end;
			end;
		     end;
		end;

		else code = error_bad_rec_len;
	     end;
	     else code = error_bad_rec_len;

	     if code = 0 then call switch_buffers;

	     return;

	end string_request;

cleanup_iocb: proc (iocb_ptr);

dcl  iocb_ptr ptr;

dcl  code fixed bin (35);

dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));

%include iocb;

/*  */

	code = 0;
	     if iocb_ptr ^= null then do;
		if iocb_ptr -> iocb.open_descrip_ptr ^= null then call iox_$close (iocb_ptr, code);
		if code = 0 then do;
		     call iox_$detach_iocb (iocb_ptr, code);
		     call iox_$destroy_iocb (iocb_ptr, code);
		end;
	     end;

	     if code ^= 0 then call dfast_error_ (code, "string","");

	     return;


	end cleanup_iocb;

/*  */
/*  This procedure copies a block of characters from the current segment into the temporary segment.
   If the procedure is called with end_index > start_index no coping is done.
*/
copy_block: proc (start_index, end_index);

dcl  start_index fixed bin (21);
dcl  end_index fixed bin (21);

dcl  block_length fixed bin (21);

	     if start_index <= end_index then do;
		block_length = end_index - start_index + 1;
		if temp_length + i <= f.max_seg_size then do;
		     substr (temp_seg, temp_length + 1, block_length) =
			substr (cur_seg, start_index, block_length);
		     temp_length = temp_length + block_length;
		end;

		else code = error_max_size;
	     end;

	     return;

	end copy_block;

/*  */
/* This procedure renumbers a block of lines and copies the lines into the temporary segment.
*/
renumber:	proc (start_index, end_index, new_number, increment);

dcl  start_index fixed bin (21);
dcl  end_index fixed bin (21);
dcl  new_number fixed bin (21);
dcl  increment fixed bin (21);

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

	     t_index = start_index;
	     do while (t_index <= end_index);

		line_length = index (substr (cur_seg, t_index, end_index - t_index + 1), new_line);
		if line_length > 0 then do;
		     i = verify (substr (cur_seg, t_index, line_length), digit);
		     call ioa_$rsnnl ("^d", string, j, new_number);
		     line_length = line_length - i + 1;
		     substr (temp_seg, temp_length + 1, j) = string;
		     temp_length = temp_length + j;
		     substr (temp_seg, temp_length + 1, line_length) =
			substr (cur_seg, t_index + i -1, line_length);
		     temp_length = temp_length + line_length;
		     new_number = new_number + increment;
		     t_index = t_index + line_length + i;
		end;
	     end;

	     return;

	end renumber;

/*  */
renumber_if_necessary: proc (start_index, end_index, new_number);

dcl  start_index fixed bin (21);
dcl  end_index fixed bin (21);
dcl  new_number fixed bin (21);
	     t_index = start_index;
	     do while (t_index <= end_index);
		i = verify (substr (cur_seg, t_index, end_index - t_index + 1), digit);
		if i > 1 then do;
		     num_1 = cv_dec_check_ (substr (cur_seg, t_index, i-1), code);
		     if code = 0 then do;
			line_length = index (substr (cur_seg, t_index, end_index - t_index + 1), new_line);
			if num_1 < new_number then call renumber (t_index, line_length, new_number, 1);

			else do;
			     call copy_block (t_index, end_index);
			     return;
			end;
			t_index = t_index + line_length;
		     end;
		end;
	     end;

	     return;

	end renumber_if_necessary;

/*  */
/* This procedure switches the pointers so that the temporary buffer becomes the current segment */

switch_buffers: proc;

	     f.current_ptr = temp_ptr;
	     f.current_length = temp_length;
	     f.alter_ptr = cur_ptr;

	     return;

	end switch_buffers;

/*  */
/* * The procedure parses the line for a line number or block specification.
   * There are two forms:
   *
   *	1.  One line number:  [<line>]
   *	    block_start, block_end = the index in the line.
   *
   *	2.  Block specification:   [<line> - <line>]
   *
   *	    block_start	The index of the line OR the next higher line that is <= the block_end.
   *	    block_end	The index of the end of the line OR the next lower line that is >= block_start.
   *
   *	code = 0			The line index was found.
   *	     = error_line_miss	The line could not be found.
   *	     = error_bad_line	Format error in line specification.
   */

parse_block_spec: proc (search_start, block_start, block_end) returns (bit (1));

dcl  search_start fixed bin (21);
dcl  block_start fixed bin (21);
dcl  block_end fixed bin (21);

dcl  line_start fixed bin (21);			/* beginning of line being looked at */
dcl  num_chars fixed bin (21);			/* num characters  in line */

	     arg = line;
	     if ^parse_two_numbers (num_1, num_2) then return ("0"b);

	     line_start = search_start;
	     do while (line_start <= cur_length);
		call get_line_number (line_start, num_chars, line_number);
		if num_1 <= line_number then do;
		     block_start = line_start;
		     block_end = line_start + num_chars -1;
		     if num_1 = num_2 then do;
			if num_1 = line_number then return ("1"b);
			else code = error_line_miss;
		     end;
		     if line_number <= num_2 then do;
			if get_equal_lower_line (block_end + 1, num_2, (0), block_end) then return ("1"b);
			if code = 0 then return ("1"b);
		     end;
		     else code = error_line_miss;
		     return ("0"b);
		end;
		line_start = line_start + num_chars;
	     end;

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

	end parse_block_spec;

/*  */
parse_two_numbers: proc (num_1, num_2) returns (bit (1) unal);

dcl  num_1 fixed bin (21);
dcl  num_2 fixed bin (21);

	     if parse_number (num_1) then do;
		line_start = verify (line, white_space);
		if line_start > 0 then do;
		     if substr (line, line_start, 1) = "-" then do;
			if line_start < length (line) then do;
			     line = substr (line, line_start + 1);
			     if parse_number (num_2) then do;
				if num_1 > num_2 then code = error_block_spec;
			     end;
			     else code = error_block_spec;
			end;
			else code = error_block_spec;
		     end;
		     else num_2 = num_1;
		end;
		else num_2 = num_1;
	     end;
	     else return ("0"b);

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

	end parse_two_numbers;


/*  */
get_equal_lower_line: proc (search_start, num, line_start, line_end) returns (bit (1) unal);

dcl  search_start fixed bin (21);
dcl  num fixed bin (21);
dcl  line_start fixed bin (21);
dcl  line_end fixed bin (21);

	     i = search_start;

	     do while (i <= cur_length);
		call get_line_number (i, j, line_number);
		if code = 0 then do;
		     if line_number > num then do;
			if i = search_start then return ("0"b);
			line_start, line_end = i -1;
			return ("1"b);
		     end;

		     else if line_number = num then do;
			line_start = i;
			line_end = i + j -1;
			return ("1"b);
		     end;
		     i = i + j;
		end;

		else return ("0"b);
	     end;

	     line_start, line_end = cur_length;

	     return ("1"b);

	end get_equal_lower_line;


/*  */
/* * This procedure parses the input line for a line number.  It returns the indices of the start and end of
   * of the line.
   *
   *	1.  The line exists:
   *		line_start	index of start of the line.
   *		line_end		index of end of the line.
   *
   *	2.  The line does not exits:
   *		line_start	the index of the end of the line which would logically preceed the
   *				missing line.
   *		line_end		= line_start
*/
find_line: proc (line_start, line_end) returns (bit (1));

dcl  line_start fixed bin (21);
dcl  line_end fixed bin (21);

	     if parse_number (num_3) then do;
		if get_equal_lower_line (1, num_3, line_start, line_end) then return ("1"b);

		else if code = 0 then do;
		     line_start, line_end = 0;
		     return ("1"b);
		end;
	     end;

	     else if code = 0 then code = error_request_miss;

	     return ("0"b);

	end find_line;

/*  */
/*  After the first number is found, a search is made for a minus sign preceeded by blanks or tabs.
   *
   *	1.  Minus sign is found:  The next item must be a valid number or an error code is returned.
   *
   *	2.  Minus sign is not found:  The first number is returned.
*/
get_numbers: proc (num_1, num_2) returns (bit (1));

dcl  num_1 fixed bin (21);
dcl  num_2 fixed bin (21);

/*  Save the current argument for an error message */

	     i = search (line, ",;");
	     if i = 0 then i = length (line);
	     arg = substr (line, 1, i);

	     if parse_number (num_1) then do;
		num_2 = num_1;
		i = verify (line, white_space);
		if i = 0 then return ("1"b);
		if substr (line, i, 1) ^= "-" then return ("1"b);

		if length (line) > i then do;
		     line = substr (line, i+1);
		     if parse_number (num_2) then return ("1"b);
		end;
		else code = error_bad_line;
	     end;

	     return ("0"b);

	end get_numbers;

/*  */
/*  This procedure parses a line in the current segment and returns its line number.

   *	code = 0		Line begins with a positive or 0 number.
   *	       no_nl	Segment does not end with a new_line.
   *	       bad_sort	Line has no number,  editing can't continue.
*/
get_line_number: proc (start, num_chars, line_number);

/* parameters */

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


	     num_chars = verify (substr (cur_seg, start), digit) - 1;
	     if num_chars > 0 then do;
		if num_chars <= max_digits_line_num then do;
		     number_pic = 0;
		     substr (number_pic, max_digits_line_num - num_chars + 1, num_chars) =
			substr (cur_seg, start, num_chars);
		     line_number = number_pic;
		end;
		else do;
		     code = error_max_line_number;
		     arg = substr (cur_seg, start, num_chars);
		end;
	     end;
	     else code = error_bad_sort;
	     num_chars = index (substr (cur_seg, start), new_line);
	     if num_chars = 0 then code = error_no_nl;

	     return;
	end get_line_number;

/*  */
/* This procedure parses the line for a number of the form:
   *	[blank]... [<unsigned number>]
*/

parse_number: proc (num) returns (bit (1));

dcl  num fixed bin (21);

dcl (start, num_chars) fixed bin (21);
dcl  num_string char (10);

	     start = verify (line, white_space);
	     if start > 0 then do;
		num_chars = verify (substr (line, start), digit);
		if num_chars = 0 then num_chars = length (line) - start +1;
		else num_chars = num_chars -1;

		if num_chars > 0 then do;
		     if num_chars <= max_digits_line_num then do;
			num_string = substr (line, start, num_chars);
			number_pic = 0;
			substr (number_pic, max_digits_line_num - num_chars + 1, num_chars) =
			     substr (line, start, num_chars);
			num = number_pic;
			start = num_chars + start;
			if start <= length (line) then do;
			     num_chars = verify (substr (line, start), arg_delimiter);
			     if num_chars > 0 then start = start+num_chars-1;
			end;
			line = substr (line, start);
			return ("1"b);
		     end;
		     else code = error_max_line_number;
		end;

		else code = error_bad_line;
	     end;

	     return ("0"b);

	end parse_number;

/*  */
/*  This procedure parses the user input line for a pathname and copies the segment onto the end of the current
   segment.
*/

copy_seg:	proc () returns (bit (1));

	     if dfast_get_arg_ (line, arg) then do;
		call dfast_directory_ (COPY, (arg), edit_info_ptr, addr (copy_info), code);
		if code = 0 then return ("1"b);
		print_message = "0"b;
	     end;

	     return ("0"b);

	end copy_seg;


/*  */
parse_line_list: proc;

dcl  search_start fixed bin (21);			/* index in cur_seg to begin search */
dcl  last_num fixed bin (21);				/* highest number so far in the line list */

	     num_blocks = 0;
	     search_start = 1;
	     last_num = -1;

	     do while (parse_block_spec (search_start, block_start, block_end));

		if num_blocks < 16 then do;
		     if num_1 > last_num then do;
			num_blocks = num_blocks + 1;
			block (num_blocks).start = block_start;
			block (num_blocks).end = block_end;
		     end;
		     else code = error_line_order;
		end;

		else code = error_max_lines;
		if code ^= 0 then return;

		search_start = block_end + 1;
		last_num = num_2;
	     end;

	     if code = error_line_miss then if last_num > num_1 then code = error_line_order;

	     return;

	end parse_line_list;


/*  */
fill_basic_tbl: proc (table_ptr, conditional, start, end, seq_number, increment);

dcl  table_ptr ptr;					/* ptr to structure to be filled in */
dcl  conditional bit (1);				/* ON set entry only if number < seq_number */
dcl  start fixed bin (21);				/* index on current_segment of start of block being checked */
dcl  end fixed bin (21);				/* index on current_segment of end of block */
dcl  seq_number fixed bin (21);			/* new sequence number to use  */
dcl  increment fixed bin (21);			/* increment for sequence number */

dcl  index fixed bin (21);


dcl 1 tbl aligned based (table_ptr) like basic_resq_tbl;
	     index = start;

	     do while (index < end & code = 0);
		call get_line_number (index, j, line_number);
		if conditional then if line_number >= seq_number then return;
		num_lines = num_lines + 1;
		t (num_lines).old_number = line_number;
		t (num_lines).new_number = seq_number;
		seq_number = seq_number + increment;
		index = index + j;
	     end;

	     return;

	end fill_basic_tbl;

     end dfast_line_edit_;




		    dfast_list_.pl1                 11/05/82  1316.6rew 11/04/82  1659.2       48690



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
dfast_list_: proc (arg_edit_info_ptr, temp_seg_id, line_number, header, punch, code);

/*  This procedure lists or punches the current or the alter segment.
   *
   *	temp_seg_id	= alt	List the alter segment.
   *			= cur	List the current segment.
   *			= ""	Merge the alter and current segments and then list the current segment.
   *
   *	line_number	= -1	List the entire segment.
   *			= n	List the segment beginning with line "n".  If "n" is greater than the highest
   *				line number, then the last line will be listed.
   *
   *	code		= bad_sort	The current segment is out of order so that the merge can't be completed.
   *			= alt_empty	The alter segment is empty.
   *			= cur_empty	The current segment is empty.
*/
/* parameters */

dcl  arg_edit_info_ptr ptr;				/* ptr. to dfast_edit_info_ */
dcl  temp_seg_id char (*);				/* temporary seg. to list: alt, cur, "" */
dcl  line_number fixed bin (21);			/* line at which to begin printing */
dcl  header bit (1) unal;				/* ON if header should be printed. */

/* automatic */

dcl  edit_info_ptr ptr;				/* ptr to dfast_edit_info */
dcl  start fixed bin (21);				/* character index at which to begin printing */
dcl  name char (32);				/* name for error message OR name for header */
dcl  punch bit (1) unal;				/* ON if the output should be punched. */
dcl  code fixed bin (35);				/* Multics OR fast error code */

dcl  old_modes char (132);				/* old modes for restore */
						/* external */

dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  dfast_header_ entry (char (*), char (*));
dcl  dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (21));
dcl  iox_$user_output ptr ext static;

/* constants */

dcl  punch_header char (16) int static options (constant) init (""); /* CTRL-R   (15) \177 */
dcl  punch_trailer char (17) int static options (constant) init (""); /* CTRL-S  (15) \177  CTRL-T */
dcl  new_line char (1) int static options (constant) init ("
");
dcl  digit char (10) int static options (constant) init ("0123456789");

/* based */

dcl 1 f aligned like dfast_edit_info based (edit_info_ptr);

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

%include dfast_edit_info;
%include dfast_error_codes;

/*  */
	edit_info_ptr = arg_edit_info_ptr;

	if f.source_segment then do;
	     if temp_seg_id = "alt" then do;
		name = "alter";
		if f.alter_length > 0 then call list (f.alter_ptr, f.alter_length);
		else code = error_alt_empty;
	     end;

	     else do;
		if temp_seg_id ^= "cur" then do;
		     if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code);
		     if code ^= 0 then return;
		     name = f.current_name;
		end;
		else name = "current";

		if f.current_length > 0 then call list (f.current_ptr, f.current_length);
		else code = error_cur_empty;
	     end;
	end;
	else code = error_obj_nop;

	if code ^= 0 then do;
	     if punch then name = "punch";
	     else name = "list";

	     call dfast_error_ (code, name, "");
	end;

	return;

/*  */
list:	proc (temp_ptr, temp_length);

/* parameters */

dcl  temp_ptr ptr;					/* ptr. to segment to list */
dcl  temp_length fixed bin (21);			/* number of characters in segment */

dcl  temp_seg char (temp_length) based (temp_ptr);

	     if line_number < 0 then start = 1;
	     else do;

		call find_line (temp_ptr, temp_length, start, code);
		if code ^= 0 then return;
	     end;

	     if punch then call output_special_chars (punch_header);

	     else if header then call dfast_header_ (name, "");

	     call iox_$put_chars (iox_$user_output, addr (substr (temp_seg, start, 1)), temp_length - start + 1, code);
	     if punch then call output_special_chars (punch_trailer);

	     return;

	end list;

find_line: proc (temp_ptr, temp_length, start, code);

dcl  temp_ptr ptr;
dcl  temp_length fixed bin (21);
dcl  start fixed bin (21);
dcl  code fixed bin (35);

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

dcl  temp_seg char (temp_length) based (temp_ptr);

	     start = 1;

	     do while (start <= temp_length & code = 0);
		i = verify (substr (temp_seg, start), digit);

		if i > 1 then do;
		     j = cv_dec_check_ (substr (temp_seg, start, i), code);
		     if code = 0
		     then if j >= line_number then return;
			else;
		     else code = error_bad_sort;
		end;
		i = index (substr (temp_seg, start), new_line);
		if i > 0
		then start = start + i;
		else code = error_no_nl;
	     end;

	     if code = 0 then start = start - i;

	     return;

	end find_line;

/*  */
output_special_chars: proc (string);

dcl  string char (*);
dcl  acode fixed bin (35);

	     old_modes = "";
	     call iox_$modes (iox_$user_output, "rawo", old_modes, acode);
	     call iox_$put_chars (iox_$user_output, addr (string), length (string), acode);
	     call iox_$modes (iox_$user_output, old_modes, "", code);

	     return;

	end output_special_chars;

     end dfast_list_;




		    dfast_merge_.pl1                01/19/88  1507.0rew 01/19/88  1459.5       67671



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


/****^  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 "table_ptr pointer" as a result of changing the include file
       named dfast_line_table.incl.pl1.  See that include file for more
       details.
     - Remove alter_ptr, dfast_err_, new_line, and white_space from the source
       since they are not referenced anywhere within the source.
     - Declare "addr" and "ptr" as builtin type since they are referenced,
       but they are not defined anywhere with the source.
                                                   END HISTORY COMMENTS */


dfast_merge_: proc (force_sort, arg_edit_info_ptr, code);

/*  This procedure merges the current and alter segments.  An ordered segment follows these conventions:
   *
   *
   *   1.  All lines begin with a positive number.
   *   2.  All lines end with the new_line character.
   *   3.  There is only one line for a given number.
   *   4.  Lines are stored with line numbers in accending order.
   *
   *   There are two ways to call the procedure:
   *
   *   1.  Convert the segment to ordered form (convert = "1"b).  A code of zero is returned in
   *	 all cases, since the procedure forces an ordered segment.
   *
   *	 a.  Illegal lines (lines that do not begin with a positive number or don't end with a new_line
   *	     character) are deleted.
   *
   *	 b.  In the case of lines with the same line number, the line furthest from the beginning of the
   *	     segment is kept.  The other lines with that number are deleted.
   *
   *	 c.  Lines are sorted so that their line numbers are in accending order.
   *
   *   2.  Do not convert the segment to ordered form (convert = "0"b).  If the segment
   *	 is not ordered, an error message is printed giving the line that caused the error and an
   *	 error code is returned.  The segment is not changed.
   *
   *	   code = 0		The segment is ordered.
   *	        = error_bad_sort	At least one line is out of order.
   *	        = error_no_nl	The segment does not end in a new_line.
   *	        = error_bad_line	An illegal number (negative or too large) was found on the line.
   *	        = error_no_num	A line without a number was found.
   *
   *
   *	The scratch buffers used:
   *
   *	alter_ptr		ptr to the alter segment
   *	temp_ptr		ptr to the new current segment
   *	cur_table_ptr	ptr to the table of line information for the current segment
   *	alt_table_ptr	ptr to the table of line information for the alter segment
   *
*/
/* parameters */

dcl  force_sort bit (1) unal;
dcl  arg_edit_info_ptr ptr;
dcl  code fixed bin (35);
dcl  clean_up condition;
dcl  edit_info_ptr ptr;
dcl  dfast_get_table_ entry (bit (1) unal, ptr, fixed bin (21), ptr, fixed bin (35));
dcl  free_table_buffers bit (1) unal;			/* ON if should free;  OFF if buffers in alter segment */
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  i fixed bin (35);
dcl  one_ptr (1) ptr based;				/* overlay to use get_temp_segments_ */
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  save_ptr ptr;
dcl  table_ptr ptr;
dcl  string char (f.max_seg_size) based;
dcl  three_ptr (3) ptr based;				/* overlay to use get_temp_segments_ */
dcl  temp char (f.max_seg_size) based (temp_ptr);
dcl  temp_length fixed bin (21);
dcl (cur_index, alt_index) fixed bin (21);

dcl 1 pointers aligned,				/* A structure is used for get_temp_segments_ convience  */
    2 temp_ptr ptr,
    2 alt_table_ptr ptr,
    2 cur_table_ptr ptr;


%include dfast_error_codes;

/* based */

dcl 1 c aligned based (cur_table_ptr) like dfast_line_table;
dcl 1 a aligned based (alt_table_ptr) like dfast_line_table;


dcl (addr, divide, null, ptr, substr) builtin;

dcl 1 f aligned based (edit_info_ptr) like dfast_edit_info;
%include dfast_edit_info;
%include dfast_line_table;

/*  */
	edit_info_ptr = arg_edit_info_ptr;

	temp_ptr, alt_table_ptr, cur_table_ptr = null;
	free_table_buffers = "0"b;

	on clean_up call free_buffers;

/* If the alter and current segments are small, the tables are put at the end of the alter segment. */

	if f.current_length + f.alter_length < divide (f.max_seg_size, 4, 35) then do;
	     i = divide (f.alter_length + 3, 4, 35, 0) +1;
	     alt_table_ptr = ptr (f.alter_ptr, i);

	     call dfast_get_table_ ("1"b, f.alter_ptr, f.alter_length, alt_table_ptr, 0);
	     i = i + a.table_length *3 +2;
	     cur_table_ptr = ptr (f.alter_ptr, i);
	     call get_temp_segments_ ("fast", addr (temp_ptr) -> one_ptr, code);
	end;
	else do;
	     call get_temp_segments_ ("fast", addr (temp_ptr) -> three_ptr, code);
	     if code = 0 then free_table_buffers = "1"b;
	end;
	if code = 0 then do;
	     call dfast_get_table_ (force_sort, f.current_ptr, f.current_length, cur_table_ptr, code);
	     if code = 0 then do;

		cur_index = 1;
		alt_index = 1;
		temp_length = 0;
		do while (cur_index <= c.table_length & alt_index <= a.table_length & code = 0);

		     if c.line (cur_index).number < a.line (alt_index).number then do;
			call move (f.current_ptr, c.line (cur_index).start, c.line (cur_index).num_chars, code);
			cur_index = cur_index + 1;
		     end;

		     else do;
			call move (f.alter_ptr, a.line (alt_index).start, a.line (alt_index).num_chars, code);
			if c.line (cur_index).number = a.line (alt_index).number then cur_index = cur_index + 1;
			alt_index = alt_index + 1;
		     end;
		end;

		do while (alt_index <= a.table_length & code = 0);
		     call move (f.alter_ptr, a.line (alt_index).start, a.line (alt_index).num_chars, code);
		     alt_index = alt_index + 1;
		end;

		do while (cur_index <= c.table_length & code = 0);
		     call move (f.current_ptr, c.line (cur_index).start, c.line (cur_index).num_chars, code);
		     cur_index = cur_index + 1;
		end;

		if code = 0 then do;
		     f.current_length = temp_length;
		     f.alter_length = 0;
		     f.edit_done = "1"b;
		     save_ptr = f.current_ptr;

		     revert clean_up;

		     f.current_ptr = temp_ptr;
		     temp_ptr = save_ptr;
		end;

	     end;
	end;
	if temp_ptr ^= null then call free_buffers;

	return;
						/*  */

move:	proc (seg_ptr, start, num_chars, code);

dcl  seg_ptr ptr;					/* ptr to segment to move from */
dcl  start fixed bin (21);				/* first character in segment to be moved  */
dcl  num_chars fixed bin (21);			/* number of characters to move */
dcl  code fixed bin (35);

	     if temp_length + num_chars > f.max_seg_size then code = error_max_size;
	     else do;
		substr (temp, temp_length + 1, num_chars) = substr (seg_ptr -> string, start, num_chars);
		temp_length = temp_length + num_chars;
	     end;

	     return;

	end move;



free_buffers: proc;

dcl  code fixed bin (35);

	     if free_table_buffers then call release_temp_segments_ ("fast", addr (temp_ptr) -> three_ptr, code);
	     else if temp_ptr ^= null then call release_temp_segments_ ("fast", addr (temp_ptr) -> one_ptr, code);

	     return;

	end free_buffers;


     end dfast_merge_;




		    dfast_process_overseer_.pl1     07/13/88  1248.5r w 07/13/88  0935.7       33885



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

/* Pedigree unknown. */
/* Modified 1984-08-24 BIM for pit instead of pitmsg. */

dfast_process_overseer_: proc;

/* automatic */

dcl  bit_count fixed bin (24);			/* bit count of message of the day */
dcl  code fixed bin (35);
dcl  home_dir_string char (168);			/* home directory for dfast_ */
dcl  i fixed bin;
dcl  junk fixed bin (6);				/* unlooked at info for iox_$control */
dcl  logout_arg char (5);				/* -hold or "" output from dfast_ */
dcl  mothd_ptr ptr;					/* ptr to message of the day */
dcl  person_id_string char (28);			/* person_id for dfast_ */
dcl  pp ptr;					/* pointer to pit */
dcl  project_id_string char (28);			/* project_id for dfast_ */
dcl 1 search_rules aligned,
	2 number fixed bin init (4),
	2 names (4) char (168) aligned init ("initiated_segments", ">unb",  ">sss", ">sl1");
dcl  tty_string char (6);				/* ttynnn for dfast_ */

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

/* external */

dcl  condition_ entry (char (*) aligned, entry);
dcl  com_err_ entry options (variable);
dcl  dfast_ entry (char (*), char (*), char (*), char (*), char (*));
dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (2), ptr, 
      fixed bin (35));
dcl  hcs_$initiate_search_rules  entry  (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_$attach_iocb entry (ptr, char (*), fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$user_io ptr ext;
dcl  iox_$user_output ptr ext;
dcl  logout entry options (variable);
dcl  standard_default_handler_ entry ();
dcl  terminate_process_ ext entry (char (*), ptr);

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

/*   */
/* set arguments for dfast_ */

	call hcs_$make_seg ("", "pit", "", 01000b, pp, code);
	tty_string = pp -> pit.tty;
	i = length (pp -> pit.homedir) + 1 - verify (reverse (pp -> pit.homedir), " ");
	home_dir_string = pp -> pit.homedir;
	person_id_string = pp -> pit.login_name;
	project_id_string = pp -> pit.project;

/* print message of the day, if the user didn't login with -brief option */

	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;

	call condition_ ("any_other", standard_default_handler_);
	call hcs_$terminate_noname (pp, code);

	call hcs_$initiate_search_rules (addr(search_rules), code);
	if code ^= 0 then call com_err_ (code, "fast", "Can't set search rules");
	call iox_$control (iox_$user_io, "quit_enable", addr(junk), code);
	call dfast_ (person_id_string, substr (home_dir_string, 1, i), project_id_string, tty_string, logout_arg);

	if logout_arg = "-hold" then call logout (logout_arg);
	else call logout;

	return;

     end dfast_process_overseer_;




		    dfast_run_.pl1                  11/05/82  1316.6rew 11/04/82  1552.6       20520



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
dfast_run_: proc (edit_info_ptr, code);

/* *  This procedure execute the run command.  The alter and current segments are merged before the run unit manager
   *  is called.
*/

/* parameters */

dcl  edit_info_ptr ptr;
dcl  code fixed bin (35);

/* automatic */

dcl  directory_name char (168);
dcl  directory_name_length fixed bin;			/* number non-blank characters in directory name */
dcl  entry_name char (32);
dcl  compiler_name char (8) aligned;			/* "basic" or "fortran" */
dcl  substr builtin;

/* constant */


/* based */

dcl 1 f aligned based (edit_info_ptr) like dfast_edit_info;


/* external */

dcl  basic_$precision_length ext fixed bin;
dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  dfast_merge_ entry (bit (1) unal, ptr, fixed bin (35));
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  dfast_run_unit_manager_ entry (char (8) aligned, ptr, fixed bin (24), char (168) aligned, bit (1) aligned, fixed bin (35));

/*   */
%include dfast_edit_info;
%include dfast_error_codes;
/*  */
	if f.source_segment then if f.alter_length > 0 then call dfast_merge_ ("0"b, edit_info_ptr, code);
	if code = 0 then do;
	     if f.basic_system then do;
		if f.dbasic then do;
		     compiler_name = "dbasic";
		     basic_$precision_length = 2;
		end;
		else do;
		     compiler_name = "basic";
		     basic_$precision_length = 1;
		end;
	     end;
	     else compiler_name = "fortran";

	     if f.current_length ^= 0 then do;
		call hcs_$fs_get_path_name (f.current_ptr, directory_name, directory_name_length,
		     entry_name, code);
		if code = 0 then do;
		     call dfast_run_unit_manager_ (compiler_name, f.current_ptr, f.current_length * 9,
			substr (directory_name, 1, directory_name_length) || entry_name, "0"b, code);
		end;
	     end;
	     else code = error_cur_empty;
	end;

	if code ^= 0 then call dfast_error_ (code, "run", (f.current_name));

	return;

     end dfast_run_;




		    dfast_run_unit_manager_.pl1     08/06/87  1149.6r w 08/06/87  1047.1      341694



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


dfast_run_unit_manager_: proc (a_system, a_program_ptr, a_program_lng, a_main_name,
	     a_debug_sw, a_code);

/* coded by M. Weaver  12/75 */
/* modified  12/76 by M. Weaver to use version 2 compiler_source_info structure */
/* Modified 28 Feb 1980 by C R Davis for new fort_options include file. */

/* This program implements the DTSS-compatible FAST susbsystem.
   It finds all libraries, compiles all source, sets up a name table,
   does the linking, executes the program and terminates all segments used just by the run unit. */

/* arguments */

dcl  a_system char (8) aligned;			/* system name */
dcl  a_program_ptr ptr;				/* ptr  to main program for run unit */
dcl  a_program_lng fixed bin (24);			/* bit count of input segment */
dcl  a_main_name char (168) aligned;			/* pathname of main program (used as library name) */
dcl  a_debug_sw bit (1) aligned;			/* "1"b->in debug mode (i.e. generate symbol table) */
dcl  a_code fixed bin (35);				/* returned status code */

/* pointers */

dcl  arg_ptr ptr;					/* ptr to arglist */
dcl  mainp ptr;					/* ptr to main entry point */
dcl  ftn_io_p ptr;					/* points to fortran io_vector */
dcl  cur_lib_node_p ptr;				/* points to  library node currently being examined */
dcl  last_lib_node_p ptr;				/* points to most recent lib node entry */
dcl  scratch_ptr ptr;				/* points to beginning of scratch seg */
dcl  cur_free_p ptr;				/* points to first free word in scratch segment */
dcl  blank_common_ptr ptr;				/* points to blank common (in scratch seg) */
dcl  object_ptr ptr;				/* ptr to object segment compiled by run unit */
dcl  cp ptr;					/* used when looping through lib list */
dcl  segptr ptr;
dcl  rnt_p ptr static;				/* ptr to beginning  of run unit's rnt */
dcl  rp ptr;					/* ptr to currently examined rnt node */
dcl  program_ptr ptr;				/* ptr to current file */
dcl  array_p ptr;					/* ptr to based_array used by temp seg manager */
dcl  source_info_pt ptr;				/* ptr to source info structure used by compilers */
dcl  new_obj_symbol_p ptr;				/* for snapping ftn *symbol links */
dcl  ep ptr;
dcl  based_ptr ptr based;				/* for copying pointers */

/* fixed bin */

dcl  max_severity fixed bin;				/* max severity of errors encountered */
dcl  nfiles fixed bin;				/* number of files being chained */
dcl  scratch_lng fixed bin (19);			/* max length of scratch seg */
dcl  ru_area_size fixed bin (18);			/* max length of space used by rum itself */
dcl  code fixed bin (35);
dcl  nleft fixed bin (26);
dcl (i, j) fixed bin;
dcl  k fixed bin (18);
dcl  based_fixed fixed bin (35) based;
dcl  program_lng fixed bin (24);			/* bit count of input seg */

/* bit strings */

dcl  debug_sw bit (1) aligned;			/* "1"b->in debug mode */
dcl  terminating bit (1) aligned;			/* "1"b->in process of terminating run unit */
dcl  compiler_invoked bit (1) aligned;			/* "1"b->run unit has invoked compiler */
dcl  have_chained bit (1) aligned;			/* "1"b->main program was chained to */
dcl  is_main bit (1) aligned;				/* "1"b->are processing the main program */
dcl  save_main bit (1) aligned;			/*  "1"b->are compiling  main program */
dcl (mask, oldmask) bit (36) aligned;			/* ips masks */

/* character strings */

dcl  temp_dir char (168);				/* used by expand_pathname_ */
dcl  main_name char (168) aligned;			/* "library" name of main program */
dcl  temp_ent char (32);				/* used by expand_pathname_ */
dcl  system char (8) aligned;				/* name of current system */
dcl  interrupt_names char (32) aligned;			/* for create_ips_mask_ */
						/* external variables */

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

/*  external entries */

dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
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  expand_pathname_ entry (char (*), char (*), char (*), 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 (26), ptr);
dcl  decode_definition_$full entry (ptr, ptr, ptr) returns (bit (1) aligned);
dcl  basic_$run_unit_compiler entry
    (ptr, ptr, fixed bin, bit (1) aligned, entry, entry, fixed bin (35));
dcl  fort_$compile_run entry (ptr, ptr, fixed bin, ptr, entry, entry, fixed bin (35));
dcl  create_ips_mask_ entry (ptr, fixed bin, bit (36) aligned);
dcl (hcs_$set_ips_mask, hcs_$reset_ips_mask) entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));

/* builtins */

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

/* arrays */

dcl  based_array (1) ptr based (array_p);		/* alias for use by get/release temp segs */

/* 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 arglist aligned,				/* for passing file ptrs to basic */
    2 argcnt fixed bin (17) unaligned,			/* 2 * number of args */
    2 alcode fixed bin (17) unaligned init (4),		/* no display ptr */
    2 descnt fixed bin (17) unaligned,			/* 2 * number of descriptors */
    2 mbz fixed bin (17) unaligned init (0),
    2 argpts (16) ptr,
    2 argdescs (16) ptr;

dcl 1 dd aligned,					/* structure filled in by full entry */
    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 (256) aligned,			/* the symbolic name of the definition */
    2 symbol_lng fixed bin,				/* the actual length of symbol */
    2 flags,					/* same flags as in std def */
      3 a_new_format bit (1) unaligned,			/* def is in new format */
      3 a_ignore bit (1) unaligned,			/* linker should ignore this def */
      3 a_entrypoint bit (1) unaligned,			/* def is for entrypoint */
      3 a_retain bit (1) unaligned,
      3 a_arg_count bit (1) unaligned,			/* there is an arg count for entry */
      3 a_descr_sw bit (1) unaligned,			/* there are valid descriptors for entry */
      3 a_main bit (1) unaligned,			/* this is a main entry point */
      3 unused bit (11) unaligned,
    2 n_args fixed bin,				/* # of args entry expects */
    2 descr_ptr ptr;				/* ptr to array of rel ptrs to descriptors for entry */


dcl 1 io_vector (99) aligned based (ftn_io_p),
    2 ip ptr unaligned,				/* points to file's iocb */
    2 modes bit (36) aligned;

dcl 1 lib_list_node aligned based (cur_lib_node_p),
    2 forward_thread bit (18) unaligned,		/* offset of next node */
    2 backward_thread bit (18) unaligned,		/* offset of last node */
    2 info aligned,					/* info to determine how to terminate */
      3 source bit (1) unal,				/* "1"b->source segment */
      3 has_lote bit (1) unal,			/* "1"b->linkage section allocated before run unit entered */
      3 already_known bit (1) unal,			/* "1"b->segment was initiated before run unit */
      3 terminate bit (1) unal,			/* "1"b->terminate before leaving run unit */
      3 pad bit (32) unal,
    2 segname char (168) aligned,			/* pathname of library */
    2 segp ptr,					/* points to library */
    2 ftn_ls_p ptr,					/* ^null->points to fortran seg linkage section */
    2 ftn_symbol_p ptr,				/* ^null->points to fortran seg symbol section */
    2 segbc fixed bin (24);				/* bit count of library */


dcl 1 rnt_node aligned based (rp),			/* node in reference name table */
    2 entryp ptr,					/* ptr to entry in program */
    2 threads aligned,
      3 next_node bit (18) unaligned,			/* offset of next node */
      3 pad bit (18) unaligned,
    2 nchars fixed bin,				/* number of characters in name */
    2 name char (32) aligned;				/* entrypoint name */

	
dcl 1 oi aligned like object_info;

%include object_info;

	
%include branch_status;

	
dcl 1 source_info aligned based (source_info_pt) like compiler_source_info;

%include compiler_source_info;

	
%include linkdcl;

	
%include lot;

	
%include stack_header;
	

/* copy arguments */
	system = a_system;
	program_ptr = a_program_ptr;
	program_lng = a_program_lng;
	main_name = a_main_name;
	debug_sw = a_debug_sw;
	a_code = 0;

/* initialize automatic variables */

	arg_ptr = null;
	ftn_io_p = null;
	cur_lib_node_p = null;
	last_lib_node_p = null;
	scratch_ptr = null;
	blank_common_ptr = null;
	object_ptr = null;
	rnt_p = null;

	max_severity = 0;
	nfiles = 0;

	terminating = "0"b;
	compiler_invoked = "0"b;
	have_chained = "0"b;
	fast_related_data_$terminate_run = terminate_run_entry;
	fast_related_data_$fortran_io_initiated = "0"b;	/* runtime must reinitialize io buffer area */

	array_p = addr (scratch_ptr);
	call get_temp_segments_ ("dfast_run_unit_manager_", based_array, code);
	call hcs_$get_max_length_seg (scratch_ptr, scratch_lng, code);
	ru_area_size = scratch_lng - 300;		/* save some room for lang area */
	cur_free_p = scratch_ptr;
	have_chained = "0"b;

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

	on cleanup begin;

/* get ips mask now for later use */
	     interrupt_names = "-all";
	     call create_ips_mask_ (addr (interrupt_names), 1, mask);
	     fast_related_data_$chaining = "0"b;
	     call terminate_run_unit_;
	     array_p = addr (scratch_ptr);
	     call release_temp_segments_ ("dfast_run_unit_manager_", based_array, code);
	end;

	call set_up_run_unit_;

/* .	if a_file_info_p ^= null then call set_up_files_; /* called for execute command */

join:	if max_severity > 2 then do;
	     a_code = error_table_$not_done;
	     go to terminate;
	end;

	call find_entry_ ("main_", mainp, code);

/* if main_ename is ever given, check for it only in main program */
	if code ^= 0 then do;			/* abort run unit */
	     call ioa_ ("Main entry point not found.");
	     go to terminate;
	end;

	on fault_tag_3 call fault_tag_3_handler;

/*	if debug_sw then call probe$init_run (mainp); */

/* set bit count so can obtain statement map if error; need only for object but doesn't hurt source */
	call hcs_$set_bc_seg (program_ptr, program_lng, code);

	call cu_$gen_call (mainp, arg_ptr);

terminate:
	fast_related_data_$chaining = "0"b;		/* be sur all files are closed */
	call terminate_run_unit_;
	array_p = addr (scratch_ptr);
	call release_temp_segments_ ("dfast_run_unit_manager_", based_array, code);

main_return:
	return;

perform_chain:
	call chain_;				/* terminate old and set up neew run unit */
	go to join;				/* now treat like ordinary run unit */

/* end of main program */

	
terminate_run_unit_: proc;

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

	     call hcs_$set_bc_seg (program_ptr, 0, code);

/* terminate all segs and clean up LOT */
	     cp = last_lib_node_p;			/* lib list is also master list */
	     if cp ^= null then do;
		do while (rel (cp));
		     segptr = cp -> lib_list_node.segp;
		     if ^(cp -> lib_list_node.info.has_lote | cp -> lib_list_node.info.source)
		     & (segptr ^= null) then do;
			k = fixed (baseno (segptr), 18);
			lotp -> lot.lp (k), isotp -> isot.isp (k) = baseptr (0);
		     end;
		     if cp -> lib_list_node.info.terminate /* don't terminate first main seg */
		     then call hcs_$terminate_noname (segptr, code);
		     cp = ptr (cp, cp -> lib_list_node.backward_thread);
		end;
	     end;

/* terminate object segment */
	     if object_ptr ^= null then do;
		k = fixed (baseno (object_ptr), 18);
		lotp -> lot.lp (k), isotp -> isot.isp (k) = baseptr (0);
		call hcs_$set_bc_seg (object_ptr, 0, code);
		array_p = addr (object_ptr);
		call release_temp_segments_ ("dfast_run_unit_manager_", based_array, code);
	     end;

/* close all fortran files */
	     if system = "fortran" then if ftn_io_p ^= null
		then call fortran_io_$close_file (-1, code);

/* if necessary, close files not found during normal termination mechanisms */
/*	     if ^fast_related_data_$chaining		/* either in cleanup handler or at end */
/*	     then call clean_up_files; */

	     terminating = "0"b;
	     return;

	end;					/* terminate_run_unit_ */
	
dfast_add_to_lib_list_: proc (a_pname, al_code);

dcl  a_pname char (*);
dcl  pname char (168);
dcl  libp ptr;
dcl  libbc fixed bin (24);
dcl  al_code fixed bin (35);


	     pname = a_pname;

/* see if this name is already on the list; this may save an initiate call */
	     cp = last_lib_node_p;
	     do while (rel (cp));
		if cp -> lib_list_node.segname = pname then go to already_on;
		cp = ptr (cp, cp -> lib_list_node.backward_thread);
	     end;

/* get pointer to segment */
	     call expand_pathname_ (pname, temp_dir, temp_ent, al_code);
	     if al_code ^= 0 then return;

	     on cleanup begin;			/* be sure ips mask gets reset */
		if substr (oldmask, 36, 1) then do;	/* between calls  to set and reset ips mask */
		     mask = oldmask;
		     call hcs_$reset_ips_mask (mask, oldmask);
		end;
	     end;

	     interrupt_names = "-all";
	     call create_ips_mask_ (addr (interrupt_names), 1, mask);
	     call hcs_$set_ips_mask (mask, oldmask);	/* bit 36 of oldmask will be "1"b */


	     call hcs_$initiate_count (temp_dir, temp_ent, "", libbc, 0, libp, al_code);
	     if libp = null then goto unmask;

/* see if this segment  is already on the list */
	     cp = last_lib_node_p;
	     do while (rel (cp));
		if cp -> lib_list_node.segp = libp then do;
		     call hcs_$terminate_noname (libp, code);
		     go to already_on;
		end;
		cp = ptr (cp, cp -> lib_list_node.backward_thread);
	     end;

/* allocate new node and fill in  */
	     call allocate_ (size (lib_list_node), cp);
	     last_lib_node_p -> lib_list_node.forward_thread = rel (cp);
	     cp -> lib_list_node.backward_thread = rel (last_lib_node_p);
	     cp -> lib_list_node.forward_thread = "0"b;
	     addr (cp -> lib_list_node.info) -> based_fixed = 0;
	     if code ^= 0 then cp -> lib_list_node.info.already_known = "1"b;
						/* initiated before; may have valid lot entry */
	     cp -> lib_list_node.info.terminate = "1"b;	/* we initiated; we must terminate */
	     cp -> lib_list_node.segname = pname;
	     cp -> lib_list_node.segp = libp;
	     cp -> lib_list_node.ftn_ls_p = null;
	     cp -> lib_list_node.ftn_symbol_p = null;
	     cp -> lib_list_node.segbc = libbc;
	     last_lib_node_p = cp;

already_on:    al_code = 0;
unmask:	     mask = oldmask;			/* use oldmask to bracket ips calls */
	     call hcs_$reset_ips_mask (mask, oldmask);
	     return;
	end;					/* dfast_add_to_lib_list_ */
	
init_lib_list_: proc;

/* allocate dummy node to make process_lib_list_ cleaner */

	     call allocate_ (size (lib_list_node), cur_lib_node_p);
	     cur_lib_node_p -> lib_list_node.backward_thread = "0"b;
	     cur_lib_node_p -> lib_list_node.segp = null;
	     cur_lib_node_p -> lib_list_node.segname = "";
	     cur_lib_node_p -> lib_list_node.ftn_ls_p = null;
	     cur_lib_node_p -> lib_list_node.ftn_symbol_p = null;
	     addr (cur_lib_node_p -> lib_list_node.info) -> based_fixed = 0;


/* allocate and initialize real first node */
	     call allocate_ (size (lib_list_node), cp);
	     cp -> lib_list_node.backward_thread = rel (cur_lib_node_p);
	     cp -> lib_list_node.forward_thread = "0"b;
	     addr (cp -> lib_list_node.info) -> based_fixed = 0;
	     if have_chained then cp -> lib_list_node.info.terminate = "1"b;
	     cp -> lib_list_node.segname = main_name;
	     cp -> lib_list_node.segp = program_ptr;
	     cp -> lib_list_node.ftn_ls_p = null;
	     cp -> lib_list_node.ftn_symbol_p = null;
	     cp -> lib_list_node.segbc = program_lng;
	     last_lib_node_p = cp;

	     cur_lib_node_p -> lib_list_node.forward_thread = rel (cp);

	     is_main = "1"b;			/* start out processing main program */
	     return;
	end;
	
chain_:	proc;

/* this is just a place holder */

	     return;
	end;

	
set_up_run_unit_: proc;

dcl (blank_length, nblocks) fixed bin;
dcl (lsp, common_p) ptr;
dcl  link_list (200) ptr aligned based;
dcl 1 common_list (100) aligned,
    2 name char (32) aligned,				/* name of labelled common block */
    2 block_p ptr,
    2 block_len fixed bin;

dcl 1 ignore_source_info aligned like compiler_source_info;
dcl 1 ext aligned like ext_template;			/* holds link info */

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

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

	     call init_lib_list_;
	     compiler_invoked = "0"b;

/* compile all source and build table of object entries */
	     call process_lib_list_ (addr (ignore_source_info));
	     if max_severity > 2 then return;		/* first release treats namedups as error */

/* process links */
	     if system = "fortran" then do;
		blank_length = 0;
		nblocks = 0;
		cp = last_lib_node_p;
		if cp ^= null then do while (rel (cp));
		     call snap_ftn_links (cp -> lib_list_node.ftn_ls_p, "1"b);
		     cp = ptr (cp, cp -> lib_list_node.backward_thread);
		end;

		if object_ptr ^= null then do;	/* snap links in object  just compiled */
		     lsp = lot.lp (fixed (baseno (object_ptr), 18)); /* get ptr to object's ls */
		     call snap_ftn_links (lsp, "0"b);
		end;

		if max_severity > 2 then return;
		call allocate_ (blank_length, blank_common_ptr); /* allocate blank common in scratch seg */

		call allocate_ (size (io_vector), ftn_io_p);
		fast_related_data_$fortran_buffer_p = ftn_io_p;
	     end;
	     else do;				/* basic */
						/* be sure area begins on even word boundary */
		if mod (fixed (rel (cur_free_p), 18), 2) = 1 then cur_free_p = addrel (cur_free_p, 1);
		nleft = scratch_lng - fixed (rel (cur_free_p), 18); /* find # of words left in scratch seg */
		call area_ (nleft, cur_free_p);
		fast_related_data_$basic_area_p = cur_free_p;
	     end;

	     return;


snap_ftn_links: proc (lp, old_object);

dcl  nlinks fixed bin;				/* number of links in linkage section */
dcl  first_link_offset fixed bin (18);
dcl  dl_code fixed bin (35);
dcl (lp, link_ptr, link_list_ptr) ptr;
dcl  old_object bit (1) aligned;
dcl  length builtin;

		if lp = null then return;

		first_link_offset = fixed (lp -> header.stats.begin_links, 18);
		link_list_ptr = addrel (lp, first_link_offset);
		nlinks = divide (fixed (lp -> header.stats.block_length, 18) - first_link_offset + 1, 2, 17, 0);
		do i = 1 to nlinks;
		     link_ptr = addr (link_list_ptr -> link_list (i));
		     call decode_ftn_link_ (link_ptr, addr (ext), "1"b, dl_code);
		     if dl_code ^= 0 then do;		/* illegal link */
			if dl_code = 1 then ;	/* not a ft2 link */
			else link_ptr -> link.ft2 = "100111"b; /* get ft3 if reference */
		     end;
		     else if ext.type = 5 & ext.section = "*system" then do; /* common */
			if ext.ename = "blnk*com" then do;
			     blank_length = max (blank_length, ext.init_info_p -> init_info.length);
						/* keep track of max blank common length */
			     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 = "*symbol") then do;
			if old_object then link_ptr -> based_ptr = cp -> lib_list_node.ftn_symbol_p;
			else link_ptr -> based_ptr = new_obj_symbol_p;
		     end;
		     else do;			/* ordinary link */
			call find_entry_ ((ext.ename), ep, code);
			if code ^= 0 then do;
			     call error (2, "Unable to satisfy reference to ^a because it is not in a library.",
				substr (ext.ename, 1, length (ename)));
			     link_ptr -> link.ft2 = "100111"b; /* make  fault  tag 3 and continue */
			end;
			else link_ptr -> based_ptr = ep; /* snap link */
		     end;
		end;
		return;

find_common_block_:	proc;

/* this procedure finds or allocates common blocks */
/* global varaibles:	init_info_p,
   .			ename,
   .			common_p,
   .			code,
   .			common_list.
*/

dcl  i fixed bin;

		     code = 0;
		     do i = 1 to nblocks;		/* see if block is already allocated */
			if ext.ename = common_list (i).name then do; /* found match */
			     if common_list (i).block_len = ext.init_info_p -> init_info.length
			     then do;
				common_p = common_list (i).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.length;
				     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;

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

		     nblocks = nblocks + 1;
		     common_list (i).name = ext.ename;
		     j, common_list (i).block_len = init_info_p -> init_info.length;
		     call allocate_ (j, common_p);
		     common_list (i).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_blocks_ */
	     end;					/* snap_ftn_links */
	end;					/* set_up_run_unit_ */
	
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 call it */

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

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 (entname, entp, ecode);

/* this procedure returns  a ptr to the entrypoint corresponding to a given name */

dcl  entname char (32);
dcl  entp ptr;
dcl  ename_length fixed bin;
dcl  ecode fixed bin (35);

	     ename_length = 33 - verify (reverse (entname), " ");
	     rp = rnt_p;
	     do while (rel (rp));
		if ename_length = rnt_node.nchars
		then if entname = rnt_node.name then do;
						/* found match */
			entp = rnt_node.entryp;
			ecode = 0;
			return;
		     end;
		rp = ptr (rp, rnt_node.next_node);
	     end;

	     ecode = error_table_$name_not_found;
	     return;

	end;					/* find_entry_ */



find_entry_value: entry (a_entname, a_entp, a_ecode);

/*     This  entry is called by basic_find_proc_ */

dcl  a_entname char (32);
dcl  a_entp ptr;
dcl  a_ecode fixed bin (35);

	call find_entry_ (a_entname, a_entp, a_ecode);

	return;


	
process_object_: proc (old_object, has_lot_entry);

dcl (listptr, namep, linkage_section_p, program_header_pt) ptr;
dcl (namel, link_lng) fixed bin;
dcl  old_object bit (1) aligned;			/* "1"b->object segment is in hierarchy */
dcl  has_lot_entry bit (1) unal;
dcl  based_name char (namel) based (namep);
dcl  based_name_aligned char (namel) based (namep) aligned;
dcl 1 saved_lib_list aligned based,			/* list found in object's text */
    2 nlibs fixed bin,
    2 names (0 refer (nlibs)) aligned,
      3 offset bit (18) unaligned,
      3 length fixed bin (17) unaligned;
dcl  ls (link_lng) fixed bin (35) based;
dcl  al_code fixed bin (35);

%include basic_program_header;

/* don't mix basic and fortran programs */
	     if oi.compiler = "fortran2" then if system ^= "fortran" then go to wrong_sys;
	     if oi.compiler = "basic" then do;		/* be sure precision matches */
		if system = "fortran" then go to wrong_sys;
		if oi.textp -> basic_program_header.version_number = -1 then do;
						/* double precision program */
		     if system ^= "dbasic" then go to wrong_sys;
		end;
		else if system = "dbasic" then do;	/* single precision program */
wrong_sys:	     call error (3, "Program ^a belongs to another system.", cur_lib_node_p -> lib_list_node.segname);
		     return;
		end;
	     end;

	     dd.next_def = oi.defp;			/* initialize for loop */
	     do while (^(decode_definition_$full (dd.next_def, addr (dd), addr (oi))));
		if dd.symbol = "library_list_" then do;
		     listptr = addrel (oi.textp, dd.offset);
		     do i = 1 to listptr -> saved_lib_list.nlibs;
			namep = addrel (oi.textp, listptr -> saved_lib_list.names (i).offset);
			namel = listptr -> saved_lib_list.names (i).length;
			call dfast_add_to_lib_list_ (based_name, al_code);
			if code ^= 0 then call error (3, "Library ^a could not be processed.",
			     based_name_aligned);
		     end;
		end;
		else if dd.section = "text" then call add_to_known_names;
	     end;

/* allocate linkage */
	     if has_lot_entry then return;
	     if old_object then do;			/* must copy linkage section */
		link_lng = oi.llng;
		call allocate_ (link_lng, linkage_section_p);
		linkage_section_p -> ls = oi.linkp -> ls;
		if system = "fortran" then do;	/* need to  keep pointers for snapping links */
		     cur_lib_node_p -> lib_list_node.ftn_ls_p = linkage_section_p;
						/* set ptrs to linkage sections to be prelinked */
		     cur_lib_node_p -> lib_list_node.ftn_symbol_p = oi.symbp;
		end;
		else cur_lib_node_p -> lib_list_node.ftn_ls_p,
		     cur_lib_node_p -> lib_list_node.ftn_symbol_p = null;
	     end;
	     else do;				/* there's  no lib_list_node  for new object */
		linkage_section_p = oi.linkp;		/*  don't  copy temp  linkage  section */
		new_obj_symbol_p = oi.symbp;
	     end;

/* update LOT, ISOT */
	     k = fixed (baseno (oi.textp), 18);
	     lotp -> lot.lp (k) = linkage_section_p;

/*		/*isotp->isot.isp(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;

add_to_known_names: proc;

/* this procedure fills in the rnt */
/* global variables:	rnt_p,
   ename,
   def_ptr,
   have_main;
*/

dcl  ename_used char (32) var;
dcl  ename_length fixed bin;
dcl  saved_rp ptr;

/* copy name to be added */
/* if it's the main entry point, use main__ so we can find it easily later */

/*
   .		if dd.flags.a_main then do;
   .		     if have_main then do;		/* don't allow 2 main entry points !
   .			call error (3, "Library ^a has a main entry point.", cur_lib_node_p -> lib_list_node.segname);
   .			return;
   .		     end;
   .		     ename_used = "main__";
   .		     ename_length = length (ename_used);
   .		     have_main = "1"b;
   .		end;
*/
		ename_length = dd.symbol_lng;
		ename_used = substr (dd.symbol, 1, dd.symbol_lng);
		if ename_used = "main_" then do;
		     if ^is_main then do;
			call error (3, "Library ^a has a main entry point.",
			     cur_lib_node_p -> lib_list_node.segname);
			return;
		     end;
		end;

		if rnt_p = null then do;		/* rnt does not exist yet */
		     call fill_in_rnt_node;
		     rnt_node.next_node = "0"b;
		     rnt_p = rp;
		     return;
		end;

		rp = rnt_p;
		do while (rel (rp));
		     if ename_length = rnt_node.nchars

		     then if ename_used = rnt_node.name then do;
			     call error (2, "Duplicate subroutine name ^a.", rnt_node.name);
			     return;
			end;
		     saved_rp = rp;			/* save for filling in thread */
		     rp = ptr (rp, rnt_node.next_node);
		end;

/* add name to rnt */
		call fill_in_rnt_node;
		saved_rp -> rnt_node.next_node = rel (rp); /* thread new node to rest of list */
		return;


fill_in_rnt_node:	proc;


		     call allocate_ (size (rnt_node), rp);
		     rnt_node.entryp = addrel (oi.textp, dd.offset);
		     rnt_node.pad = "0"b;
		     rnt_node.nchars = ename_length;
		     rnt_node.name = ename_used;
		     return;

		end;				/* fill_in_rnt_node */

	     end;					/* add_to_known_names_ */
	end;					/* process_object_ */

	
process_lib_list_: proc (source_info_pointer);

dcl  source_info_pointer ptr;
dcl  fixed_lote fixed bin (35);
dcl  object_len fixed bin (24);
dcl  object_length fixed bin;

dcl 1 fort_options aligned like fortran_options;

%include fort_options;

	     source_info_pt = source_info_pointer;

/* find all library segments */
	     do while (cur_lib_node_p -> lib_list_node.forward_thread);
		cur_lib_node_p = ptr (cur_lib_node_p, lib_list_node.forward_thread);
		oi.version_number = object_info_version_2;
		call object_info_$display (lib_list_node.segp, lib_list_node.segbc, addr (oi), code);
		if code = 0 then do;		/* object */
		     fixed_lote = addr (lotp -> lot.lp (fixed (baseno (oi.textp), 18))) -> based_fixed;
		     if (fixed_lote > 0) & (lib_list_node.info.already_known)
		     then cur_lib_node_p -> lib_list_node.info.has_lote = "1"b;
		     call process_object_ ("1"b, cur_lib_node_p -> lib_list_node.info.has_lote); /* find defs, copy linkage */
		     is_main = "0"b;
		end;
		else do;
						/* source; must compile */
						/* set up source info */
		     source_info.version = compiler_source_info_version_2;
		     source_info.input_pointer = cur_lib_node_p -> lib_list_node.segp;
		     source_info.input_lng = divide (cur_lib_node_p -> lib_list_node.segbc+8, 9, 17, 0);
		     call expand_pathname_ ((cur_lib_node_p -> lib_list_node.segname), temp_dir, temp_ent, code);
		     source_info.given_ename = substr (temp_ent, 1, 33 - verify (reverse (temp_ent), " "));

		     call hcs_$status_long (temp_dir, temp_ent, 1, addr (branch_status), null, code);
						/* ignore  any error--not likely and doesn't matter */
		     source_info.date_time_modified = fixed (branch_status.date_time_modified || (16)"0"b, 71);
		     source_info.unique_id = branch_status.unique_id;

		     call hcs_$fs_get_path_name (source_info.input_pointer, temp_dir, i, temp_ent, code);
		     source_info.dirname = substr (temp_dir, 1, i);
		     source_info.segname = substr (temp_ent, 1, 33 - verify (reverse (temp_ent), " "));

		     if compiler_invoked then return;
						/* here at most  once per  run unit */

		     array_p = addr (object_ptr);
		     call get_temp_segments_ ("dfast_run_unit_manager_", based_array, code);
		     if code ^= 0 then do;
			call error (4, "Unable to obtain segment for compiled code.", " ");
			go to main_return;
		     end;

		     save_main = is_main;		/* note if compiling maan */
		     is_main = "0"b;		/*  turn off for any libraries found */
		     compiler_invoked = "1"b;

		     if system = "fortran" then do;
			unspec (fort_options) = dfast_mask;
			call fort_$compile_run (
			     source_info_pointer, object_ptr, object_length, addr (fort_options),
			     dfast_get_next_source_seg_, dfast_add_to_lib_list_, code);
		     end;

		     else call basic_$run_unit_compiler ( /* assume basic */
			source_info_pointer, object_ptr, object_length, debug_sw,
			dfast_get_next_source_seg_, dfast_add_to_lib_list_, code);

		     if code ^= 0 then do;
			call error (3, "errors in source. Program could not be run.", " ");
			return;
		     end;

		     object_len = object_length * 36;	/* convert to bit count */
		     call hcs_$set_bc_seg (object_ptr, object_len, code);
		     call object_info_$display (object_ptr, object_len, addr (oi), code);
		     is_main = save_main;

		     if code ^= 0 then call error (3, "Errors in source. Program could not be run.", " ");
		     else call process_object_ ("0"b, "0"b); /* find defs; don't copy linkage */
		     return;
		end;
	     end;

/* found all libraries; tell compiler to finish object */
	     if compiler_invoked then source_info.input_pointer = null;

	     return;
	end;
	
dfast_get_next_source_seg_: proc (source_info_pointer);

dcl  source_info_pointer ptr;

	     call process_lib_list_ (source_info_pointer);

	     return;
	end;					/* dfast_get_next_source_seg_ */

	
allocate_: proc (nwords, newptr);

/* this routine allocates spece in the scratch segment; it is used when
   the run unit is being set up */

dcl  nwords fixed bin;
dcl  newptr ptr;

/* always allocate on even word boundary */
	     if mod (fixed (rel (cur_free_p), 18), 2) = 1 then cur_free_p = addrel (cur_free_p, 1);
	     newptr = cur_free_p;
	     cur_free_p = addrel (cur_free_p, nwords);
	     if fixed (rel (cur_free_p), 18) > ru_area_size then do;
		call error (4, "Attempt to overflow run unit scratch area.", " ");
		go to main_return;			/* abort completely; can't continue at all */
	     end;

	     return;
	end;					/* allocate_ */

	
error:	proc (severity, control_string, arg_string);

dcl  severity fixed bin;
dcl (control_string, arg_string) char (*) aligned;

	     max_severity = max (max_severity, severity);
	     call ioa_ (control_string, arg_string);

	     return;
	end;					/* error */




terminate_run_entry: proc;

	     goto terminate;

	end;					/* terminate_run_entry */


	
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 (35);
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), dl_code);
	     if dl_code ^= 0 then goto continue_ft3;

	     scup = addr (cond_info.mcptr -> mc.scu (0));
	     link_ptr = ptr (baseptr (fixed (fixed (scup -> scu.ppr.psr, 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;




		    dfast_set_system_.pl1           11/05/82  1316.6rew 11/04/82  1552.7       17829



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
dfast_set_system_: proc (name, basic_system, tag, code);

/*  This procedure parses the name and sets basic_system if there is an appropriate language suffix.
   If basic_system is changed, a warning message is printed.

   _s_u_f_f_i_x		_c_o_d_e		_b_a_s_i_c___s_y_s_t_e_m

   .basic		0		"1"b

   .fortran		0		"0"b

   neither		no_suffix		not changed

*/

dcl  name char (256) var;				/* name to be parsed for language suffix */
dcl  basic_system bit (1) unal;			/* ON if basic;  OFF if fortran */
dcl  tag char (*);
dcl  code fixed bin (35);				/* fast error code */

dcl  len fixed bin;					/* length of the object name */

dcl (length, substr, reverse) builtin;

dcl  iox_$user_output ptr ext static;
dcl  ioa_$ioa_switch entry options (variable);

%include dfast_error_codes;

/*  */

	tag = "";
	if substr (reverse (name), 1, 6) = reverse (".basic") then do;
	     len = length (name) - 6;
	     if len > 0 then do;
		if ^basic_system then call message;
		tag = "basic";
		return;
	     end;
	end;
	else if substr (reverse (name), 1, 8) = reverse (".fortran") then do;
	     len = length (name) - 7;
	     if len > 0 then do;
		if basic_system then call message;
		tag = "fortran";
		return;
	     end;
	end;

	code = error_no_suffix;

	return;

/*  */

/*  This procedure changes the system and prints a warning message. */
message:	proc;

dcl  system_name char (7);

	     basic_system = ^basic_system;
	     if basic_system then system_name = "basic";
	     else system_name = "fortran";
	     call ioa_$ioa_switch (iox_$user_output, "system changed to ^a", system_name);

	     return;

	end message;

     end dfast_set_system_;




		    dfast_terminal_control_.pl1     11/05/82  1316.6rew 11/04/82  1552.7       18576



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
dfast_terminal_control_: proc (request, terminal_type, arg_edit_info_ptr, code);

/*  This procedure changes the input/output mode of the terminal:
   *
   *	(1)	fullduplex
   *	(2)	halfduplex
   *	(3)	uppercase
   *	(4)	lowercase
   *	(5)	tape		not implemented
   *	(6)	keyboard		not implemented
   *	(7)	direct		not implemented
   *	(8)	terminal type	not implemented
*/

dcl  request fixed bin;				/* number indicating request */
dcl  terminal_type char (*);				/* terminal type to use */
dcl  arg_edit_info_ptr ptr;				/* pointer to edit_info_structure */
dcl  code fixed bin (35);				/* FAST or Multics error code  */

dcl  iox_$user_io ptr ext static;
dcl  iox_$user_output ptr ext static;
dcl  iox_$user_input ptr ext static;

dcl  old_modes char (132);				/* save old modes for restore */
dcl  string char (100) var based;

dcl  dfast_error_ entry (fixed bin (35), char (*), char (*));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  set_tty entry options (variable);
dcl (addr, null, substr)builtin;

/* constants */

dcl  modes (4) char (18) int static options (constant) init (
     "fulldpx,echoplex",
     "^fulldpx,^echoplex",
     "capo,edited",
     "^capo,^edited");
dcl  CAPS fixed bin int static options (constant) init (3); /* change to caps for output */
dcl  DIRECT fixed bin int static options (constant) init (7);
dcl  TYPE fixed bin int static options (constant) init (8);

/* based */

%include dfast_error_codes;

/*  */
	if request <= 4 then do;
	     call iox_$modes (iox_$user_io, (modes (request)), old_modes, code);
	     if code ^= 0 then call dfast_error_ (code, "modes", "");
	end;

	return;

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